'Hamster Republic Productions Classic Game Source Code '(C) Copyright Brian Fisher and James Paige and Hamster Republic Productions 'GPL software: Please read LICENSE.TXT ' 'This is "Bob the Hamster VGA", an arcade-style action game inspired by DigDug. ' 'This is a FreeBasic port of the QuickBasic port of the GWBASIC source code 'of the first ever Bob the Hamster game, "Bob the Hamster EGA". 'There are no known remaining copies of "Bob the Hamster EGA" ' 'Portions of this code are adapted from the OHRRPGCE, many thanks to Simon 'Bradley who pioneered the technique of porting allmodex QB code to FreeBasic 'And to all the other OHR developers. ' ' '$DYNAMIC DEFINT A-Z #include "compat.bi" #include "allmodex.bi" #include "common.bi" 'Local subs and functions processcommandline DIM SHARED homedir AS STRING DIM SHARED tmpdir AS STRING DIM SHARED workingdir AS STRING workingdir = exepath$ + SLASH #IFDEF __FB_LINUX__ homedir = ENVIRON$("HOME") tmpdir = homedir + SLASH + ".bobvga" + SLASH IF NOT isdir(tmpdir) THEN makedir tmpdir #ELSE 'Custom on Windows works in the current dir homedir = ENVIRON$("USERPROFILE") & SLASH & "My Documents" 'Is My Documents called something else for non-English versions of Windows? tmpdir = exepath$ + SLASH #ENDIF 1 RANDOMIZE TIMER setmodex setwindowtitle "Bob the Hamster VGA Level Editor" DIM newpal(255) AS RGBColor DIM oldpalbuf(767) DIM SHARED AS INTEGER vpage, dpage DIM map(-1 TO 22, -1 TO 14), pic(138), bobpal(300), baspal(8), nme$(6), txt(1024), mess$(31, 1), pict(15), pal(15), scln$(3), btype$(8) DIM ppic(30), pex(30), pded(30), ap(30), bp(30) DIM levelloader AS STRING DIM AS INTEGER pt, spmx, spmy, vladp, lflg, b, a, rs, ar, br, sh, ash, bsh, bw, awb, bwb, lg, lga, lgb, pl, shded, cb, rded, wbded, lded, ct, pnt, ltm, btyp, bgol DIM AS INTEGER cex(15), cbp(15), cded(15), abug(15), bbug(15) DIM SHARED sound_names(45) AS STRING DIM SHARED allow_sound AS INTEGER = YES setupsound FOR i = -1 TO 22: FOR j = -1 TO 14: map(i, j) = 14: NEXT j: NEXT i FOR i = 0 TO 3: READ scln$(i): NEXT i FOR i = 0 TO 7: READ btype$(i): NEXT i FOR i = 0 TO 15: READ mess$(i, 0): NEXT i FOR i = 0 TO 15: READ pict(i): NEXT i FOR i = 0 TO 15: READ pal(i): NEXT i vlad = 0: hat = 0: bobpic = 0: invis = 0: ld = 1: lang = 0: dvc = 1: lvlb = 1 'FOR i = 0 TO 15: POKE VARPTR(baspal(0)) + i, i: NEXT i xbload data_file("palette.mas"), oldpalbuf(), "master palette missing" convertpalette oldpalbuf(), newpal() setpal newpal() xbload data_file("bobtext.ohf"), txt(), "font missing" setfont txt() loadpage data_file("bobgraph.mxs"), 0, 3 xbload data_file("bobgraph.pal"), bobpal(), "16-color palettes missing" DIM ded(138), car(138), cabag(138), spm(138), sun(138), dirt(138), con(138), digup(138), web(138), tore(138) GOSUB 1915 setvispage 0 FOR i = 1 TO 11 textcolor 32 - i, 0 READ txt$: printstr txt$, 160 - LEN(txt$) * 4, i * 11 + 20, 0 NEXT i RESTORE soundeffects FOR i = 0 TO UBOUND(sound_names) READ sound_names(i) NEXT i setkeys lvl = 1: speed# = .06 loadsprite pic(), 0, vlad, 131, 16, 17, 3 drawsprite pic(), 0, baspal(), 0, 0, 183, 3 x = 1: y = 1: ptyp = 0 thing = 0 wigglex = 0 wiggley = -1 vpage = 1: dpage = 0 223 GOSUB 1600 225 clearpage 2 GOSUB 1800 GOSUB 1930 copypage 2, vpage setvispage vpage loadsprite pic(), 0, vlad, 4, 16, 17, 3: smy = 1 setkeys 570 setwait 110 setkeys copypage 2, dpage IF keyval(1) > 1 THEN GOTO 1100 IF keyval(74) > 1 THEN IF speed# < .1 THEN speed# = speed# + .01 IF keyval(78) > 1 THEN IF speed# > .01 THEN speed# = speed# - .01 IF keyval(25) > 1 THEN GOSUB 1920 IF keyval(88) > 1 THEN GOSUB allonpage IF ptyp = 0 THEN IF keyval(72) > 0 AND y > 1 THEN y = y - 1 IF keyval(75) > 0 AND x > 1 THEN x = x - 1 IF keyval(77) > 0 AND x < 20 THEN x = x + 1 IF keyval(80) > 0 AND y < 12 THEN y = y + 1 IF keyval(52) > 1 THEN IF thing < 15 THEN thing = thing + 1 ELSE thing = 0 IF keyval(51) > 1 THEN IF thing > 0 THEN thing = thing - 1 ELSE thing = 15 IF keyval(31) > 1 THEN IF spmx = x AND spmy = y THEN spmx = 0 ELSE spmx = x: spmy = y IF keyval(28) > 1 THEN ptyp = ptyp XOR 1 IF keyval(57) > 1 THEN map(x, y) = thing GOSUB 1800 SELECT CASE thing CASE 2 IF b > 0 THEN map(a / 16 + 1, (b - 7) / 16 + 1) = 0 CASE 7 IF rs > 0 THEN map(ar / 16 + 1, (br - 7) / 16 + 1) = 0 CASE 9 IF sh > 0 THEN map(ash / 16 + 1, (bsh - 7) / 16 + 1) = 0 CASE 10 IF bw > 0 THEN map(awb / 16 + 1, (bwb - 7) / 16 + 1) = 0 CASE 15 IF lg > 0 THEN map(lga / 16 + 1, (lgb - 7) / 16 + 1) = 0 END SELECT GOSUB 1930 END IF ELSE IF keyval(75) > 1 THEN IF thing > 0 THEN thing = thing - 1 ELSE thing = 15 IF keyval(77) > 1 THEN IF thing < 15 THEN thing = thing + 1 ELSE thing = 0 IF keyval(28) > 1 OR keyval(57) > 1 THEN ptyp = ptyp XOR 1 END IF IF b <> 0 THEN hp = hp XOR 1 loadsprite pic(), 0, vlad, 4 + hp, 16, 17, 3 drawsprite pic(), 0, bobpal(), vladp, a, b, dpage END IF FOR i = 1 TO pl IF pex(i) <> 0 THEN ppic(i) = ppic(i) XOR 1 IF pded(i) = 1 THEN IF ppic(i) < 8 THEN ppic(i) = 8 ELSE pex(i) = 0 loadsprite pic(), 0, vlad, 20 + ppic(i), 16, 17, 3 drawsprite pic(), 0, bobpal(), 16 + vladp, ap(i), bp(i), dpage END IF NEXT i IF sh <> 0 THEN shp = shp XOR 1 IF shded = 1 THEN IF shp < 8 THEN shp = 8 ELSE sh = 0: shp = 0 loadsprite pic(), 0, vlad, 52 + shp, 16, 17, 3 drawsprite pic(), 0, bobpal(), 48 + vladp, ash, bsh, dpage END IF FOR i = 1 TO cb IF cex(i) <> 0 THEN cbp(i) = cbp(i) XOR 1 IF cded(i) = 1 THEN IF cbp(i) < 8 THEN cbp(i) = 8 ELSE cbp(i) = 0: cex(i) = 0 loadsprite pic(), 0, vlad, 36 + cbp(i), 16, 17, 3 drawsprite pic(), 0, bobpal(), 32 + vladp, abug(i), bbug(i), dpage END IF NEXT i IF rs <> 0 THEN rp = rp XOR 1 IF rded = 1 THEN IF rp < 8 THEN rp = 8 ELSE rs = 0 loadsprite pic(), 0, vlad, 68 + rp, 16, 17, 3 drawsprite pic(), 0, bobpal(), 64 + vladp, ar, br, dpage END IF IF bw <> 0 THEN wbp = wbp XOR 1 IF wbded = 1 THEN IF wbp < 8 THEN wbp = 8 ELSE bw = 0 loadsprite pic(), 0, vlad, 84 + hp, 16, 17, 3 drawsprite pic(), 0, bobpal(), 80 + vladp, awb, bwb, dpage END IF IF lg <> 0 THEN lgp = lgp XOR 1 IF lded = 1 THEN IF lgp < 8 THEN lgp = 8 ELSE lg = 0 loadsprite pic(), 0, vlad, 100 + lgp, 16, 17, 3 drawsprite pic(), 0, bobpal(), 96 + vladp, lga, lgb, dpage END IF IF spmx > 0 THEN drawsprite spm(), 0, bobpal(), 192 + vladp, spmx * 16 - 16, spmy * 16 - 9, dpage textcolor 15, 0: printstr STR$(lvl), 152, 0, dpage printstr STR$(ct), 64, 0, dpage printstr mess$(thing, lang), 200, 0, dpage IF hat > 0 THEN drawsprite spm(), 0, bobpal(), 176 + vladp, a, b - 12, dpage IF pnt = 5 THEN pnt = 0 ELSE pnt = pnt + 1 textcolor 88 + pnt, 0 IF ptyp = 0 THEN printstr "|", (x - 1) * 16 + 5, (y - 1) * 16 + 3, dpage wigglex += 1 : IF wigglex > 1 THEN wigglex = -1 wiggley += 1 : IF wiggley > 1 THEN wiggley = -1 loadsprite pic(), 0, vlad, pict(thing), 16, 17, 3 drawsprite pic(), 0, bobpal(), vladp + pal(thing), (x - 1) * 16 + wigglex, (y - 1) * 16 + 7 + wiggley, dpage ELSE rectangle 30, 78, 260, 21, 1, dpage rectangle 32, 80, 256, 17, 0, dpage FOR i = 0 TO 15 loadsprite pic(), 0, vlad, pict(i), 16, 17, 3 drawsprite pic(), 0, bobpal(), vladp + pal(i), 32 + i * 16, 80, dpage NEXT i printstr "|", 36 + thing * 16, 72, dpage END IF SWAP vpage, dpage setvispage vpage dowait GOTO 570 1010 fadeto 0, 0, 0 lvl = lvl + 1 GOTO 223 1100 'settings pt = 0 leave = 0 setkeys WHILE leave = 0 setwait 110 setkeys copypage 2, dpage textcolor 11, 0 printstr "Level-", 80, 20, dpage printstr "Extra Life-", 40, 35, dpage printstr "Thick Dirt-", 40, 50, dpage printstr "Angry Shrew-", 32, 65, dpage printstr "Hero Select-", 32, 80, dpage printstr "Bonus Level-", 32, 95, dpage textcolor 14, 0 printstr "Undo Last Changes", 56, 155, dpage printstr "Save Current Level", 52, 170, dpage printstr "Quit Editor", 88, 185, dpage textcolor 10, 0 printstr STR$(lvl), 128, 20, dpage IF spmx > 0 THEN printstr STR$(spmx) + "," + STR$(spmy), 128, 35, dpage ELSE printstr "No", 128, 35, dpage IF lflg AND 1 THEN printstr "Yes", 128, 50, dpage ELSE printstr "No", 128, 50, dpage IF lflg AND 2 THEN printstr "Vlad", 128, 80, dpage ELSE printstr "Bob", 128, 80, dpage IF lflg AND 8 THEN printstr "Yes", 128, 65, dpage ELSE printstr "No", 128, 65, dpage IF lflg AND 4 THEN textcolor 11, 0 printstr "Bonus Time-", 40, 110, dpage printstr "Goal Type-", 48, 125, dpage printstr "Goal Num-", 56, 140, dpage textcolor 10, 0 printstr "Yes", 128, 95, dpage printstr STR$(ltm), 128, 110, dpage printstr btype$(btyp), 128, 125, dpage printstr STR$(bgol), 128, 140, dpage IF keyval(72) > 1 THEN pt = pt - 1: IF pt < 0 THEN pt = 11 IF keyval(80) > 1 THEN pt = pt + 1: IF pt > 11 THEN pt = 0 ELSE IF keyval(72) > 1 THEN pt = pt - 1: IF pt < 0 THEN pt = 11 ELSE IF pt > 5 AND pt < 9 THEN pt = 5 IF keyval(80) > 1 THEN pt = pt + 1: IF pt > 11 THEN pt = 0 ELSE IF pt > 5 AND pt < 9 THEN pt = 9 printstr "No", 128, 95, dpage END IF textcolor 14, 0: printstr "|", 130, pt * 15 + 12, dpage SELECT CASE pt CASE 0 IF keyval(75) > 1 THEN IF lvl > 1 THEN save_blank = NO GOSUB 1700 lvl = lvl - 1 GOSUB 1600 GOSUB 1800 END IF END IF IF keyval(77) > 1 THEN IF lvl < 100 THEN save_blank = NO GOSUB 1700 lvl = lvl + 1 GOSUB 1600 GOSUB 1800 END IF END IF CASE 2 IF keyval(75) > 1 OR keyval(77) > 1 OR keyval(57) > 1 THEN lflg = lflg XOR 1 GOSUB 1800 END IF CASE 3 IF keyval(75) > 1 OR keyval(77) > 1 OR keyval(57) > 1 THEN lflg = lflg XOR 8 CASE 4 IF keyval(75) > 1 OR keyval(77) > 1 OR keyval(57) > 1 THEN lflg = lflg XOR 2 GOSUB 1915 GOSUB 1800 END IF CASE 5 IF keyval(75) > 1 OR keyval(77) > 1 OR keyval(57) > 1 THEN lflg = lflg XOR 4 CASE 6 IF keyval(75) > 1 AND (lflg AND 4) AND ltm > 0 THEN ltm = ltm - 1 IF keyval(77) > 1 AND (lflg AND 4) AND ltm < 255 THEN ltm = ltm + 1 CASE 7 IF keyval(75) > 1 AND (lflg AND 4) AND btyp > 0 THEN btyp = btyp - 1 IF keyval(77) > 1 AND (lflg AND 4) AND btyp < 7 THEN btyp = btyp + 1 IF keyval(57) > 1 THEN btyp = btyp + 1: IF btyp > 7 THEN btyp = 0 CASE 8 IF keyval(75) > 1 AND (lflg AND 4) AND bgol > 0 THEN bgol = bgol - 1 IF keyval(77) > 1 AND (lflg AND 4) AND bgol < 255 THEN bgol = bgol + 1 CASE 9 IF keyval(57) > 1 OR keyval(28) > 1 THEN GOSUB 1600 GOSUB 1915 GOSUB 1800 END IF CASE 10 IF keyval(57) > 1 OR keyval(28) > 1 THEN save_blank = YES GOSUB 1700 END IF CASE 11 IF keyval(57) > 1 OR keyval(28) > 1 THEN leave = 2 END SELECT IF keyval(1) > 1 THEN leave = 1 SWAP vpage, dpage setvispage vpage dowait WEND save_blank = NO GOSUB 1700 IF leave = 2 THEN fadeto 0, 0, 0: GOTO 1999 ELSE GOTO 223 1600 'load level levelloader = STRING(128, 0) OPEN data_file("custom.dat") FOR BINARY ACCESS READ AS #1 GET #1, 1 + (lvl - 1) * 128, levelloader CLOSE #1 spmx = ASC(MID(levelloader, 121, 1)) spmy = ASC(MID(levelloader, 122, 1)) lflg = ASC(MID(levelloader, 123, 1)) ltm = ASC(MID(levelloader, 124, 1)) btyp = ASC(MID(levelloader, 125, 1)) bgol = ASC(MID(levelloader, 126, 1)) IF spmx > 20 THEN spmx = 20: IF spmy > 12 THEN smpy = 12 FOR j = 1 TO 12: FOR i = 1 TO 10 map(i * 2 - 1, j) = ASC(MID$(levelloader, i + (j - 1) * 10, 1)) AND 15: map(i * 2, j) = (ASC(MID$(levelloader, i + (j - 1) * 10, 1)) AND 240) / 16 NEXT i: NEXT j GOSUB 1915 RETRACE 1700 'save level tld$ = "" FOR j = 1 TO 12 FOR i = 1 TO 10 tld$ = tld$ + CHR$(map(i * 2 - 1, j) + map(i * 2, j) * 16) NEXT i NEXT j IF tld$ = STRING(120, 0) AND save_blank = NO THEN RETRACE MID(levelloader, 1, 120) = tld$ MID(levelloader, 121, 1) = CHR(spmx) MID(levelloader, 122, 1) = CHR(spmy) MID(levelloader, 123, 1) = CHR(lflg) MID(levelloader, 124, 1) = CHR(ltm) MID(levelloader, 125, 1) = CHR(btyp) MID(levelloader, 126, 1) = CHR(bgol) MID(levelloader, 127, 2) = STRING(2, 0) OPEN data_file("custom.dat") FOR BINARY AS #1 PUT #1, 1 + (lvl - 1) * 128, levelloader CLOSE #1 RETRACE 1800 'draw level clearpage 2 FOR i = 12 TO 1 STEP -1: FOR j = 20 TO 1 STEP -1 k = (j - 1) * 16: l = (i - 1) * 16 + 7: m = map(j, i) drawsprite dirt(), 0, bobpal(), 224 + vladp, k, l, 2 IF (lflg AND 1) AND m = 1 THEN drawsprite con(), 0, bobpal(), 224 + vladp, k, l, 2 IF m = 0 OR m = 2 OR m > 5 THEN rectangle k, l, 16, 17, 0, 2 IF m = 3 THEN drawsprite car(), 0, bobpal(), 160 + vladp, k, l, 2 IF m = 4 OR m = 13 THEN drawsprite cabag(), 0, bobpal(), 144 + vladp, k, l, 2 IF m = 5 THEN drawsprite sun(), 0, bobpal(), 176 + vladp, k, l, 2 IF m = 11 THEN drawsprite web(), 0, bobpal(), 208 + vladp, k, l, 2 IF m = 12 THEN drawsprite ded(), 0, bobpal(), 128 + vladp, k, l, 2 IF m = 14 THEN drawsprite con(), 0, bobpal(), 224 + vladp, k, l, 2 NEXT j: NEXT i textcolor 15, 0 printstr scln$(lang + vlad / 80), 0, 0, 2 RETRACE 1900 'delay of 1 second t = TIMER + 1: WHILE t > TIMER: WEND RETRACE allonpage: clearpage vpage tempx = 0: tempy = 0 FOR i = 0 TO 6 FOR o = 0 TO 8 loadsprite pic(), 0, 0, i * 16 + o, 16, 17, 3 drawsprite pic(), 0, bobpal(), i * 16, tempx, tempy, vpage tempx = tempx + 16: IF tempx > 300 THEN tempx = 0: tempy = tempy + 17 loadsprite pic(), 0, 160, i * 16 + o, 16, 17, 3 drawsprite pic(), 0, bobpal(), (i + 15) * 16, tempx, tempy, vpage tempx = tempx + 16: IF tempx > 300 THEN tempx = 0: tempy = tempy + 17 NEXT o NEXT i setvispage vpage screenshot "sprites.bmp", vpage, newpal() w = getkey RETRACE 1915 IF (lflg AND 2) = 0 THEN vlad = 0: vladp = 0 ELSE vlad = 160: vladp = 240 loadsprite ded(), 0, vlad, 124, 16, 17, 3 loadsprite cabag(), 0, vlad, 125, 16, 17, 3 loadsprite car(), 0, vlad, 126, 16, 17, 3 loadsprite sun(), 0, vlad, 127, 16, 17, 3 loadsprite spm(), 0, vlad, 128, 16, 17, 3 loadsprite web(), 0, vlad, 129, 16, 17, 3 loadsprite tore(), 0, vlad, 130, 16, 17, 3 loadsprite dirt(), 0, vlad, 131, 16, 17, 3 loadsprite digup(), 0, vlad, 132, 16, 17, 3 loadsprite con(), 0, vlad, 134, 16, 17, 3 RETRACE 1920 'pause fadeto INT(RND(1) * 64), INT(RND(1) * 64), INT(RND(1) * 64) lk = getkey fadetopal newpal() RETRACE 1930 'setstuff FOR i = 1 TO pl: pex(i) = 0: pded(i) = 1: NEXT i FOR i = 1 TO cb: cex(i) = 0: cded(i) = 1: NEXT i rded = 1: shded = 1: wbded = 1: lded = 1 b = 0 ct = 0 pl = 0 cb = 0 FOR i = 1 TO 12: FOR j = 1 TO 20 ta = (j - 1) * 16: tb = (i - 1) * 16 + 7 IF map(j, i) = 2 THEN a = ta: b = tb IF map(j, i) = 3 THEN ct = ct + 1 IF map(j, i) = 6 THEN IF pl < 30 THEN pl = pl + 1: ppic(pl) = 0: pex(pl) = 1: pded(pl) = 0: ap(pl) = ta: bp(pl) = tb ELSE map(j, i) = 0 IF map(j, i) = 7 THEN rded = 0: rp = 0: ar = ta: br = tb: rs = 1 IF map(j, i) = 8 THEN IF cb < 9 THEN cb = cb + 1: cbp(cb) = 0: cex(cb) = 1: cded(cb) = 0: abug(cb) = ta: bbug(cb) = tb ELSE map(j, i) = 0 IF map(j, i) = 9 THEN shded = 0: shp = 0: ash = ta: bsh = tb: sh = 1 IF map(j, i) = 10 THEN wbded = 0: wbp = 0: awb = ta: bwb = tb: bw = 1 IF map(j, i) = 15 THEN lded = 0: lgp = 0: lga = ta: lgb = tb: lg = 1 NEXT j: NEXT i RETRACE 'top lines DATA "Carrots: Level:" DATA " ’­Œ‚ : ÊÔ~É:" DATA " Coins: Stage:" DATA " …œ: ¿Å´¾~:" 'bonus level types DATA "Eat Carrots/Get Money","Kill Plips/Walruses","Kill Beetles/Worms","Kill Sharks/Pavenders","Shoot Shrews/Turks","Get Turks/Shrews Killed","Save Turks/Shrews","Kill Lagomorph/Soldier" 'item types DATA "Space","Dirt","Bob","Carrot","Cabbage","Sunseed","Plip","Shrew","Beetle","Shark","Spider","Web","Bones","Magic Cabbage","Rocks","Rabbit" 'pictures DATA 133,131,4,126,125,127,20,68,36,52,84,129,124,125,134,100 DATA 224,224,0,160,144,176,16,64,32,48,80,208,128,144,224,96 'How to DATA "Bob the Hamster Level Editor" DATA "Press Enter to Bring up the object menu" DATA "Press space to place an object/enemy" DATA "Press Escape to bring up the level menu" DATA "Press left and right to change options" DATA "space and enter select an option" DATA "Levels are automatically saved when you" DATA "Change levels or quit" DATA "To play your levels set the level type" DATA "to ~custom~ from the Bob the Hamster" DATA "Options menu." soundeffects: 'bob DATA "hock","spit","squish","clang","crunch","shrew","spider" DATA "carrot","spitup","stuck","spam","goodspam","spif" DATA "dead5","dead4","dead1","dead3","dead2" DATA "win1","win2","win3","win4","win5" 'vlad DATA "cutnhlf","grrrah","walpop","pop","cutnhlf","turk","hey" DATA "money","haha","wrath","gimmie","vladhat","spif" DATA "lose1","lose2","lose3","lose4","lose1" DATA "vict1","vict2","vict3","vict4","vict5" 1999 closesound SYSTEM: 'quit routine