This entry was for a competition to design a game using only ONE key.
To Play:
Use ONLY the alt key to move and fire. When you release the alt key, your tank will stop. When you press alt again, your tank will move in the opposite direction.
Shoot all invaders before they shoot you. Bonus points for shooting the mother ship.
If invaders get a couple rows above your tank, they land and you die.
To win you must complete all 3 levels.
If you get a top 5 high score, you get to enter your initials. To do so, follow these instructions.
Tap the alt key to display initials A-Z. Stop tapping when your initial appears. Wait 2-seconds and it will be auto-input. If you goofed, hold down the alt key while waiting. It will allow you to redo input from start.
When you input your 3rd and last initial, all your initials will begin to flash for 2.5 seconds, and then they will be recorded. If you goofed, press the alt key within the 2.5 second time period, and you will be able to redo input from start.
FILE WARNING: This routine makes and overwrites a file in your local folder named: ascii-invaders-high-score.dat
REM Set up aliens
ialiencol = ialiencolstat
LOCATE 2, ialiencol
FOR i = 1 TO imaxalienforce
IF i MOD 1 = 0 THEN PRINT
LOCATE , ialiencol
IF i = imaxalienforce THEN
ileadingrow = CSRLIN: ileadingmax = ileadingrow
END IF
IF i \ 2 = i / 2 THEN a(i) = a$ ELSE a(i) = alt$
PRINT a(i)
NEXT
COLOR 0 + 16, 3
LOCATE 25, 68: PRINT "Score ";
COLOR 0, 3
PRINT score$;
COLOR 6, ibk
REM Station
LOCATE 24, 40
tanky% = CSRLIN: tankx% = POS(0) + 1
PRINT tank$;: LOCATE , POS(0) - 2
_DELAY 1
DO
z1 = TIMER
DO
IF zbonus THEN
IF ABS(zbonus - TIMER) > 1.5 THEN
yy% = CSRLIN: xx% = POS(0)
COLOR 6, 0: LOCATE topmargin%, lmargin%: PRINT SPACE$(screenwidth%);
LOCATE yy%, xx%
zbonus = 0
END IF
END IF
IF topmargin% + ileadingmax - (imaxalienforce * 2) >= topmargin% + 2 THEN
IF imothership <> 0 THEN CALL mship(imothership)
END IF
IF ABS(TIMER - z1aliens) > level THEN
CALL movealiens(ialiencol, ialiencolstat, iresults)
z1aliens = TIMER
END IF
IF iresults < 0 THEN EXIT DO
IF ABS(TIMER - z1ia) > .3 THEN CALL alienmissile(iresults): z1ia = TIMER
DEF SEG = 0
IF PEEK(1047) MOD 16 = 7 OR PEEK(1047) MOD 16 = 8 THEN
key$ = CHR$(32) ' Alt
ELSE
key$ = ""
END IF
DEF SEG
SELECT CASE key$
CASE CHR$(32)
IF flag = 0 THEN switch = switch * -1 - 1: flag = -1
SELECT CASE switch
CASE 0
IF ABS(z9 - TIMER) > .15 THEN
IF POS(0) < screenwidth% THEN COLOR icolor, ibk: LOCATE , POS(0) - 1: PRINT " " + tank$;: LOCATE , POS(0) - 2
tanky% = CSRLIN: tankx% = POS(0)
IF SCREEN(tanky%, tankx% - 2) = 25 OR SCREEN(tanky%, tankx% + 2) = 25 THEN result = -1: EXIT DO
z9 = TIMER
END IF
CASE -1
IF ABS(z9 - TIMER) > .15 THEN
IF POS(0) > lmargin% + 1 THEN COLOR icolor, ibk: LOCATE , POS(0) - 2: PRINT tank$ + " ";: LOCATE , POS(0) - 3
tanky% = CSRLIN: tankx% = POS(0)
IF SCREEN(tanky%, tankx% - 2) = 25 OR SCREEN(tanky%, tankx% + 2) = 25 THEN result = -1: EXIT DO
z9 = TIMER
END IF
END SELECT
IF icolor = 6 THEN
FOR i2 = 1 TO 5
IF bullet%(i2) = 0 THEN
icolor = 12: COLOR icolor, ibk: GOSUB redraw
bullet%(i2) = -1: reload = TIMER: EXIT FOR
END IF
NEXT
END IF
CASE ""
IF flag THEN skip = 0: flag = 0
CASE CHR$(27): SYSTEM
END SELECT
IF ABS(z1 - reload) > .6 AND reload <> 0 THEN
GOSUB redraw
icolor = 6: reload = 0
END IF
REM Fire
FOR i = 1 TO 5
SELECT CASE bullet%(i)
CASE -1: bullet%(i) = tanky% - 1: bulletcol%(i) = tankx%
CASE IS > 0
IF bulletdelay%(i) = -1 OR bullet%(i) = tanky% - 1 THEN
CALL checkcollision(ihitaliens, ialiencol, i4, i)
z2bullet = TIMER: bulletdelay%(i) = 0
COLOR 6, ibk
LOCATE bullet%(i), bulletcol%(i)
IF bullet%(i) = topmargin% AND imothership <> 0 THEN ' Hit mother ship.
IF SCREEN(ABS(bullet%(i)), bulletcol%(i)) <> 32 THEN
SOUND 1000, .75
SELECT CASE iresults + 1
CASE 1: bonus = 1500
CASE 2: bonus = 2500
CASE 3: bonus = 5000
END SELECT
score$ = LTRIM$(STR$(VAL(score$) + bonus))
score$ = STRING$(6 - LEN(score$), "0") + score$
yy% = CSRLIN: xx% = POS(0)
SOUND 800, .5: SOUND 1600, .5: SOUND 2400, .5
LOCATE topmargin%, lmargin%: PRINT SPACE$(screenwidth%);
kbonus = bulletcol%(i) - 4
IF kbonus < lmargin% THEN kbonus = lmargin%
IF kbonus + 10 > screenwidth% THEN kbonus = screenwidth% - 11
zbonus = TIMER
LOCATE yy%, xx%
imothership = 0
END IF
END IF
PRINT CHR$(24) ' Tank missile.
IF CSRLIN <> 24 THEN LOCATE , bulletcol%(i): PRINT " ";
IF ihitaliens <> 0 THEN CALL reprintaliens(ialiencol, ihitaliens, iresults, i4, i, imothership)
LOCATE tanky%, tankx%
IF bullet%(i) > topmargin% THEN
bullet%(i) = bullet%(i) - 1
ELSE
GOSUB erasebullet
END IF
IF zbonus THEN
yy% = CSRLIN: xx% = POS(0)
LOCATE topmargin%, kbonus: COLOR 2 + 16: PRINT "BONUS " + LTRIM$(STR$(bonus));
LOCATE yy%, xx%
END IF
END IF
END SELECT
NEXT
REM Bullet timer delay
IF z2bullet <> 0 THEN
IF z1 < z2bullet THEN z2bullet = z2bullet - 86400
IF z1 - z2bullet >= .06 THEN
FOR i2 = 1 TO 5
IF bullet%(i2) <> 0 THEN bulletdelay%(i2) = -1
NEXT i2
END IF
EXIT DO
END IF
LOOP
IF iresults < 0 THEN EXIT DO
IF alienforce% = 0 OR iresults = iwin THEN
FOR i = 1 TO imaxalienmissiles
IF ia(i) <> 0 THEN EXIT FOR
NEXT
IF i > imaxalienmissiles THEN iwait = -1
IF iwait = -1 THEN
EXIT DO
END IF
ELSE
iwait = 1
END IF
LOOP
IF iresults = iwin OR iresults < 0 THEN
REM end game
EXIT DO
END IF
inextrnd = -1
LOOP
SELECT CASE iresults
CASE -1 ' Tank destroyed!
SOUND 800, .3: SOUND 250, 1
FOR i = 1 TO 5
COLOR 14, 4
LOCATE tanky%, tankx% - 1: PRINT tank$;
_DELAY .1
COLOR 8, ibk
LOCATE tanky%, tankx% - 1: PRINT tank$;
_DELAY .1
NEXT
FOR j = imaxalienforce TO 1 STEP -1
IF a(j) <> "" THEN EXIT FOR
NEXT
FOR i = j TO 1 STEP -1
IF INSTR(a(i), CHR$(79)) THEN
LOCATE , ialiencol + INSTR(a(i), CHR$(79)) - 2
PRINT LTRIM$(RTRIM$(a(i)));
LOCATE CSRLIN - 2
END IF
NEXT
redraw:
COLOR , ibk: LOCATE tanky%, tankx% - 1: PRINT tank$;: LOCATE tanky%, tankx%: COLOR 7, ibk
RETURN
first_play:
DATA "The Great Pumpkin has fired an EM pulse at your computer."
DATA ""
DATA "All that's working is your Alt key."
DATA ""
replay:
DATA "Loading..."
DATA "EOF"
DATA "Game Over. Press Alt to play again..."
DATA "EOF2"
winner:
DATA "Congratulations, you saved the planet!"
DATA ""
DATA "Press Alt to play again..."
DATA "EOF3"
SUB alienattack (ialiencol)
z2alienfire = TIMER
i3 = INT(RND * 10)
FOR i = 1 TO imaxalienmissiles
IF ia(i) = 0 THEN
FOR i2 = imaxalienforce TO 1 STEP -1
IF RTRIM$(a(i2)) <> "" THEN
IF MID$(matrix(i2), i3 + 1, 1) <> "0" THEN
i4 = INSTR(i3 * 7 + 1, a(i2), CHR$(79)) + ialiencol
EXIT FOR
END IF
END IF
NEXT i2
IF i4 <> 0 THEN
ia(i) = (ileadingmax - (imaxalienforce - i2) * 2) * 80 + i4
EXIT FOR
END IF
END IF
NEXT i
END SUB
SUB alienmissile (iresults)
irow = CSRLIN: icol = POS(0)
FOR i = 1 TO imaxalienmissiles
IF ia(i) <> 0 THEN
IF iy(i) = 0 THEN
iy(i) = ia(i) \ 80: ix(i) = ia(i) MOD 80
IF ix(i) = 0 THEN ix(i) = screenwidth%
END IF
LOCATE iy(i) + 1, ix(i)
COLOR 6, ibk
IF CSRLIN <= 24 THEN
IF CSRLIN = 24 THEN IF SCREEN(CSRLIN, ix(i)) <> 32 THEN iresults = -1
PRINT CHR$(25);
ELSE
ia(i) = 0
LOCATE iy(i), ix(i)
PRINT " ";: iy(i) = 0
ia(i) = 0
LOCATE irow, icol
EXIT SUB
END IF
LOCATE iy(i), ix(i): PRINT " ";
iy(i) = iy(i) + 1
END IF
NEXT
LOCATE irow, icol
END SUB
SUB checkcollision (ihitaliens, ialiencol, i4, i)
ihitaliens = 0
IF ileadingmax MOD 2 = bullet%(i) MOD 2 THEN
i4 = imaxalienforce - (ileadingmax - bullet%(i)) \ 2
IF bullet%(i) <= ileadingrow AND i4 > 0 AND i4 <= imaxalienforce THEN
IF RTRIM$(a(i4)) <> "" THEN
IF bulletcol%(i) >= iltalien(i4) AND bulletcol%(i) - ialiencol <= LEN(RTRIM$(a(i4))) THEN
IF MID$(a(i4), bulletcol%(i) - ialiencol, 1) > CHR$(32) THEN
SOUND 1100, .2: SOUND 334, .1: SOUND 590, .4
ihitaliens = bulletcol%(i) - ialiencol + 1
i3 = ihitaliens - 7 + 1
IF i3 < 1 THEN i3 = 1
i2 = INSTR(i3 + 1, a(i4), "^" + CHR$(79)) - 1
i2 = INSTR(i3 + 1, a(i4), CHR$(79)) - 2
MID$(a(i4), i2, 7) = SPACE$(7)
MID$(matrix(i4), (i2 + 1) \ 7 + 1, 1) = "0"
END IF
END IF
END IF
END IF
END IF
FOR i2 = 1 TO imaxalienmissiles
IF ia(i2) <> 0 THEN
IF iy(i2) >= bullet%(i) AND ix(i2) = bulletcol%(i) THEN
ihitaliens = -i2
EXIT FOR
END IF
END IF
NEXT
END SUB
SUB instructions
IF in$ = "" THEN
LOCATE 3, 3, 1, 7, 0: COLOR 6, ibk
_DELAY 2
DO
READ in$
IF MID$(in$, 1, 3) = "EOF" THEN EXIT DO
FOR i = 1 TO LEN(in$)
SOUND 400, .06
LOCATE , 2 + i
PRINT MID$(in$, i, 1);
z = TIMER
DO
IF ABS(z - TIMER) > .06 THEN EXIT DO
LOOP
NEXT
LOCATE , , 0, 7, 0
_DELAY 1
PRINT
LOCATE , 3
LOOP
_DELAY .75
END IF
IF in$ = "EOF" THEN
COLOR 7, 0
FOR i = 0 TO 19 ' Blank out intro message space.
LOCATE topmargin% + i, lmargin%: PRINT SPACE$(screenwidth%);
NEXT
FOR i = 3 TO 24
LOCATE i, 80: PRINT CHR$(179);
NEXT
LOCATE 21, 2: PRINT STRING$(screenwidth%, " ");
LOCATE 22, 1: PRINT CHR$(179);
LOCATE 22, 80: PRINT CHR$(179);
LOCATE 22, 2: PRINT STRING$(screenwidth%, " ");
ELSE
COLOR 0, 3
END IF
IF in$ <> "EOF2" AND iresults <> iwin THEN COLOR 0 + 16, 3 ELSE COLOR 0, 3
yy% = CSRLIN: xx% = POS(0)
LOCATE 25, 68: PRINT "Score ";
COLOR 0, 3
PRINT score$;
LOCATE yy%, xx%
PCOPY 0, 3: REM save skin
END SUB
SUB marchdown (ialiencol, ialiencolstat, imotion, iresults)
COLOR 6, ibk
ileadingrow = ileadingrow + 1
ileadingmax = ileadingmax + 1
COLOR 6, ibk
FOR i = 1 TO imaxalienforce
REM SOUND 400, .2 ' Level down.
IF RTRIM$(a(i)) <> "" THEN
ialiencol = ialiencolstat + imotion
LOCATE ileadingmax - (imaxalienforce * 2) + i * 2 - 1, lmargin%
PRINT STRING$(screenwidth%, " ")
LOCATE , ialiencol + INSTR(a(i), CHR$(79)) - 2
iltalien(i) = POS(0)
PRINT LTRIM$(RTRIM$(a(i)))
END IF
NEXT
LOCATE irow, icol
level = level - .025
IF ileadingrow = 22 THEN iresults = -2 ' Aliens have landed!
END SUB
DEFSNG I
DEFINT I
SUB movealiens (ialiencol, ialiencolstat, iresults)
STATIC imotion, imarch, imotiondir
FOR i = imaxalienforce TO 1 STEP -1
IF RTRIM$(a(i)) <> "" THEN
FOR k = 1 TO LEN(a(i))
k$ = MID$(a(i), k, 1)
IF k$ = "^" THEN
MID$(a(i), k, 1) = "-"
ELSEIF k$ = "-" THEN
MID$(a(i), k, 1) = "^"
END IF
NEXT
i2 = i2 + 2
ialiencol = ialiencolstat + imotion
LOCATE ileadingmax - (imaxalienforce - i) * 2, ialiencol + INSTR(a(i), CHR$(79)) - 2
IF POS(0) = lmargin% THEN imarch = 1
iltalien(i) = POS(0)
IF imotiondir = 0 THEN
PRINT LTRIM$(RTRIM$(a(i))); " "
ELSE
LOCATE , POS(0) - 1
PRINT " "; LTRIM$(RTRIM$(a(i)))
END IF
IF ialiencol + LEN(RTRIM$(a(i))) = screenwidth% THEN imarch = -1
END IF
NEXT
IF imarch = 1 THEN imotiondir = 1: CALL marchdown(ialiencol, ialiencolstat, imotion, iresults)
IF imarch = -1 THEN imotiondir = 0: CALL marchdown(ialiencol, ialiencolstat, imotion, iresults)
IF imarch = 0 THEN
IF ABS(TIMER - z2alienfire) > firerate THEN
firerate = (INT(RND * 10) + 1) / 20
IF iwait = 0 THEN CALL alienattack(ialiencol)
END IF
ELSE
imarch = 0
END IF
PCOPY 1, 0: SCREEN 0, 0, 0, 0
LOCATE irow, icol, 1, 7, 0
END SUB
SUB mship (imothership)
STATIC x%, mov%, z4, mothership$
yy% = CSRLIN: xx% = POS(0): COLOR 6, ibk
IF imothership = -1 THEN
imothership = 1
x% = lmargin%
mothership$ = "(" + CHR$(127) + CHR$(179) + CHR$(127) + ")" 'CHR$(254) + CHR$(254) + "O" + CHR$(254) + CHR$(254)
mov% = 1
END IF
IF ABS(TIMER - z4) > .05 THEN GOSUB mothership: z4 = TIMER
LOCATE yy%, xx%
EXIT SUB
mothership:
IF x% + LEN(mothership$) = screenwidth% + lmargin% THEN mov% = -1 ELSE IF x% = lmargin% THEN mov% = 1
x% = x% + mov%
LOCATE topmargin%, x%
COLOR 7, 6: PRINT MID$(mothership$, 1, 1);
COLOR 14, 6: PRINT MID$(mothership$, 2, 1);
COLOR 7, 6: PRINT MID$(mothership$, 3, 1);
COLOR 14, 6: PRINT MID$(mothership$, 4, 1);
COLOR 7, 6: PRINT MID$(mothership$, 5, 1);
COLOR 7, ibk
IF x% > 1 AND mov% = 1 THEN
LOCATE , POS(0) - LEN(mothership$) - 1: PRINT " ";
END IF
IF mov% = -1 THEN PRINT " ";
RETURN
END SUB
DEFINT A-H, J-Z
SUB qbide
PALETTE 2, 59
COLOR 15, 0
CLS
DEFSNG A-H, J-Z
SUB reprintaliens (ialiencol, ihitaliens, iresults, i4, i, imothership)
IF ihitaliens > 0 THEN
ihits = ihits + 1
SELECT CASE iresults + 1
CASE 1: score$ = LTRIM$(STR$(VAL(score$) + 150))
CASE 2: score$ = LTRIM$(STR$(VAL(score$) + 250))
CASE 3: score$ = LTRIM$(STR$(VAL(score$) + 350))
END SELECT
score$ = STRING$(6 - LEN(score$), "0") + score$
IF (ihits + 15) MOD 20 = 0 AND imothership = 0 THEN imothership = -1
LOCATE bullet%(i), lmargin%: PRINT SPACE$(screenwidth%);
iltalien(i4) = POS(0)
IF RTRIM$(a(i4)) = "" THEN
alienforce% = alienforce% - 1
IF alienforce% = 0 THEN iresults = iresults + 1 ' Level completed. Goto to next level.
IF bullet%(i) = ileadingrow THEN ileadingrow = ileadingrow - 2
ELSE
LOCATE bullet%(i), ialiencol + INSTR(a(i4), CHR$(79)) - 2
PRINT LTRIM$(RTRIM$(a(i4)))
END IF
ELSE
i2 = ABS(ihitaliens)
LOCATE iy(i2), ix(i2)
PRINT " ";: iy(i2) = 0
ia(i2) = 0
LOCATE irow, icol
IF soundfile% = 0 THEN
SOUND 1000, .5
ELSE
z4 = TIMER
DO
IF eflag THEN
IF ABS(z4 - TIMER) > .1 THEN
eflag = 0
PALETTE 0, 0
EXIT DO
ELSE
j = -j * -1
IF j = 0 THEN
PALETTE 0, 63
_DELAY .05
ELSE
PALETTE 0, 0
_DELAY .05
END IF
END IF
END IF
IF eflag = 0 THEN
PALETTE 0, 36
IF soundfile% THEN
_SNDPLAY t1&
_DELAY .05
_SNDPLAY t7&
ELSE
_DELAY .075
END IF
eflag = -1
z4 = TIMER
END IF
LOOP
SELECT CASE iresults + 1
CASE 1: bonus = 500
CASE 2: bonus = 1500
CASE 3: bonus = 2500
END SELECT
score$ = LTRIM$(STR$(VAL(score$) + bonus))
score$ = STRING$(6 - LEN(score$), "0") + score$
END IF
END IF
ihitaliens = 0
bullet%(i) = -bullet%(i)
COLOR 0, 3
yy% = CSRLIN: xx% = POS(0)
LOCATE 25, 74: PRINT score$;
LOCATE yy%, xx%
COLOR 6, ibk
SUB TheBOB
SCREEN _NEWIMAGE(800, 600, 256)
WIDTH 80, 25
OUT &H3C8, 1: OUT &H3C9, 40: OUT &H3C9, 12: OUT &H3C9, 0
OUT &H3C8, 2: OUT &H3C9, 6: OUT &H3C9, 12: OUT &H3C9, 0
OUT &H3C8, 3: OUT &H3C9, 30: OUT &H3C9, 8: OUT &H3C9, 0
OUT &H3C8, 4: OUT &H3C9, 3: OUT &H3C9, 8: OUT &H3C9, 0
OUT &H3C8, 7: OUT &H3C9, 63: OUT &H3C9, 0: OUT &H3C9, 0
OUT &H3C8, 8: OUT &H3C9, 46: OUT &H3C9, 0: OUT &H3C9, 0
OUT &H3C8, 9: OUT &H3C9, 63: OUT &H3C9, 63: OUT &H3C9, 63
OUT &H3C8, 12: OUT &H3C9, 20: OUT &H3C9, 20: OUT &H3C9, 20
OUT &H3C8, 13: OUT &H3C9, 0: OUT &H3C9, 0: OUT &H3C9, 0
OUT &H3C8, 14: OUT &H3C9, 55: OUT &H3C9, 35: OUT &H3C9, 0
FOR Reps = 1 TO 4
SELECT CASE Reps
DATA 1,1.2,1.8,5
CASE 1: Elipse = 1
CASE 2: Elipse = 1.2
CASE 3: Elipse = 1.8
CASE 4: Elipse = 5
END SELECT
FOR E = Elipse TO Elipse + .1 STEP .01
CIRCLE (320, 240), 100, 3, , , E
NEXT E
NEXT Reps
FOR Radius = 38 TO 43
CIRCLE (320, 160), Radius, 3, , , .4
NEXT Radius
CIRCLE (320, 160), 40, 14, 3.3, 6, .4
CIRCLE (320, 240), 100, 5, , , .9
PAINT (0, 0), 5
CIRCLE (320, 240), 100, 0, , , .9
PAINT (0, 0), 0
FOR Radius = 12 TO 18
CIRCLE (320, 153), Radius, 2, , , .3
NEXT Radius
FOR x% = 58 TO 142
FOR y% = 198 TO 282
IF POINT(x%, y%) = 13 THEN
IF POINT(x% + 220, y%) = 15 THEN PSET (x% + 220, y%), 9
END IF
NEXT y%
NEXT x%
COLOR 13: LOCATE 1, 1: PRINT "HAPPY HALLOWEEN!"
xx = 64: yy = 360 - 330
FOR x% = 0 TO 300
FOR y% = 0 TO 16
IF POINT(x%, y%) = 13 THEN
IF y% > 6 THEN Colr = 8 ELSE Colr = 7
LINE (x% * 4 + xx, y% * 4 + yy)-(x% * 4 + xx + 3, y% * 4 + yy + 3), Colr, BF
END IF
NEXT y%
NEXT x%
FOR x% = 0 TO 639
IF POINT(x%, 368) <> 0 THEN PSET (x%, 368), 14
NEXT x%
z1 = TIMER
DO UNTIL ABS(TIMER - z1) > 4
FOR Reps = 1 TO 3
WAIT &H3DA, 8
WAIT &H3DA, 8, 8
NEXT Reps
Flicker = FIX(RND * 20)
OUT &H3C8, 14
OUT &H3C9, 40 + Flicker
OUT &H3C9, 25 + Flicker
OUT &H3C9, 10 + Flicker
OUT &H3C8, 15
OUT &H3C9, 43 + Flicker
OUT &H3C9, 38 + Flicker
OUT &H3C9, 20 + Flicker
LOOP
SCREEN 0, 0, 0, 0
END SUB
SUB displayhighscores
COLOR 0, 3
LOCATE 25, 68: PRINT "Score "; score$;
DIM hs AS STRING * 25
REDIM highscore$(6), hsdata$(6)
DO
IF _FILEEXISTS("ascii-invaders-high-score.dat") THEN
OPEN "ascii-invaders-high-score.dat" FOR RANDOM AS #1 LEN = 25
FOR i = 1 TO 5
GET #1, i, hs
highscore$(i) = MID$(hs, 10, 6): hsdata$(i) = hs
NEXT
CLOSE #1
ELSE
FOR i = 1 TO 5
hsdata$(i) = SPACE$(25)
NEXT
END IF
IF VAL(score$) > VAL(highscore$(5)) THEN
IF VAL(score$) > VAL(highscore$(1)) THEN
msg$ = " HIGH SCORE / Enter Your Initials! "
ELSE
msg$ = " Top 5 Score. Enter Your Initials! "
END IF
GOSUB hiscore
a = 14
OUT &H3C8, 0
OUT &H3C9, 20 - a
OUT &H3C9, 20 - a
OUT &H3C9, 20 - a
OUT &H3C8, 8
OUT &H3C9, 30 - a
OUT &H3C9, 30 - a
OUT &H3C9, 30 - a
OUT &H3C8, 7
OUT &H3C9, 30 - a
OUT &H3C9, 30 - a
OUT &H3C9, 30 - a
OUT &H3C8, 3
OUT &H3C9, 30 - a
OUT &H3C9, 30 - a
OUT &H3C9, 30 - a
font = _LOADFONT("lucon.ttf", 20, "monospace")
IF font <= 0 THEN font = 16
_FONT font
DEF SEG = 0
delay = .4
lscr = 19
z3 = TIMER
DO
initials$ = "": i = 0: nxt = 0
COLOR , _RGB(24, 24, 24): t$ = " " ' Blank initials for redo. Okay to blank at start.
PSL 5 + rank * 2, lscr, t$
_DISPLAY
DO
_LIMIT 60
IF ABS(z3 - TIMER) > .3 AND kflag > -2 THEN
underline 5 + rank * 2, lscr + nxt, 0
_DISPLAY
z3 = TIMER
END IF
SELECT CASE kflag
CASE 0
IF ABS(z1 - TIMER) > 1.5 AND i AND nxt < 3 THEN
SOUND 1500, 1
underline 5 + rank * 2, lscr + nxt, -1: uflag = 0
_DISPLAY
initials$ = initials$ + CHR$(64 + i)
nxt = nxt + 1 ' Next initial
i = 0 ' Reset alphabet.
z1 = TIMER
IF nxt = 3 THEN
kflag = -2 ' All 3 initials have been input.
underline 5 + rank * 2, lscr + nxt, -1: uflag = 0
_DISPLAY
END IF
END IF
IF PEEK(1047) MOD 16 = 7 OR PEEK(1047) MOD 16 = 8 THEN
kflag = -1 ' Alt key pressed.
z1 = TIMER: z2 = TIMER
i = i + 1: IF i > 26 THEN i = 1
COLOR , _RGB(24, 24, 24): t$ = " "
PSL 5 + rank * 2, lscr + nxt, t$
COLOR DarkOrange: t$ = CHR$(64 + i)
SOUND 1000, .1
PSL 5 + rank * 2, lscr + nxt, t$
underline 5 + rank * 2, lscr + nxt, 0
_DISPLAY
END IF
CASE -1
IF ABS(z2 - TIMER) > 2 THEN ' Key down long enough to indicate redo input.
IF nxt > 0 THEN ' Redo last initial input.
SOUND 300, .5
FOR nxt = 0 TO 3
underline 5 + rank * 2, lscr + nxt, -1: uflag = 0
NEXT
nxt = 0: i = 0
initials$ = ""
COLOR , _RGB(24, 24, 24): t$ = " "
PSL 5 + rank * 2, lscr, t$
_DISPLAY
z1 = TIMER ' Reset enter timer.
ELSE
SOUND 300, .5
i = 0
COLOR , _RGB(24, 24, 24): t$ = " "
PSL 5 + rank * 2, lscr, t$
_DISPLAY
z1 = TIMER ' Reset enter timer.
END IF
z2 = TIMER
END IF
IF PEEK(1047) MOD 16 <> 7 AND PEEK(1047) MOD 16 <> 8 THEN ' Alt key was released.
kflag = 0 ' Alt key up
z1 = TIMER
END IF
CASE -2 ' Finished. Initials will flash until confirmed by 2-second timer.
z1 = TIMER: z2 = TIMER
j = 0
DO
IF ABS(z1 - TIMER) > .3 THEN j = -j - 1: z1 = TIMER
IF j THEN
COLOR DarkOrange: t$ = initials$
PSL 5 + rank * 2, lscr, t$
_DISPLAY
ELSE
COLOR _RGB(24, 24, 24): t$ = initials$
PSL 5 + rank * 2, lscr, t$
_DISPLAY
END IF
IF ABS(z2 - TIMER) > 2.5 AND j THEN
kflag = -3
EXIT DO
END IF
IF PEEK(1047) MOD 16 = 7 OR PEEK(1047) MOD 16 = 8 THEN
BEEP
kflag = -4
EXIT DO
END IF
LOOP
CASE -3
_DELAY 1
l$ = "8"
n$ = "n24": PLAY "L" + l$ + n$
n$ = "n28": PLAY "L" + l$ + n$
n$ = "n28": PLAY "L" + l$ + n$
l$ = "7"
n$ = "n31": PLAY "L" + l$ + n$
l$ = "9"
n$ = "n28": PLAY "L" + l$ + n$
l$ = "3"
n$ = "n31": PLAY "L" + l$ + n$
kflag = 1
_DELAY 1: EXIT DO
CASE -4
kflag = 0 ' Repeat enter initials
nxt = 0
i = 0
EXIT DO
END SELECT
LOOP
IF kflag > 0 THEN kflag = 0: EXIT DO ' Exit routine.
LOOP
DEF SEG
hsname$ = initials$
MID$(hsdata$(rank), 5, 3) = hsname$ + SPACE$(3 - LEN(hsname$))
OPEN "ascii-invaders-high-score.dat" FOR RANDOM AS #1 LEN = 25
FOR i = 1 TO 5
hs = hsdata$(i)
IF LEFT$(hs, 1) = "" THEN MID$(hs, 1, 2) = "0" + LTRIM$(STR$(i))
PUT #1, i, hs
NEXT
CLOSE #1
_DELAY 1
_DISPLAY ' Remove scoreboard.
_DELAY 1
_FREEIMAGE Overlay
_FONT 16 'select inbuilt 8x16 default font
_FREEFONT font
bxy% = 4
COLOR Black, DarkOrange
t$ = " NAME SCORE DATE "
PSL bxy% + 1, bxx% + 1, t$
COLOR DarkOrange, 0
FOR i = 1 TO 5
t$ = hsdata$(i)
PSL bxy% + 1 + i * 2, bxx% + 2, t$
NEXT
_DISPLAY
RETURN
hiscore:
FOR i = 1 TO 5
IF VAL(score$) > VAL(highscore$(i)) THEN rank = i: EXIT FOR
NEXT
hsdata$(6) = SPACE$(25)
MID$(hsdata$(6), 10, 6) = score$
MID$(hsdata$(6), 18, 8) = MID$(DATE$, 1, 6) + MID$(DATE$, 9, 2)
highscore$(6) = score$
FOR i = 1 TO 6
FOR j = 1 TO 6
IF i <> j THEN
IF VAL(highscore$(i)) > VAL(highscore$(j)) THEN
SWAP highscore$(i), highscore$(j)
SWAP hsdata$(i), hsdata$(j)
END IF
END IF
NEXT
NEXT
FOR i = 1 TO 5
MID$(hsdata$(i), 1, 2) = "0" + LTRIM$(STR$(i))
NEXT
RETURN
END SUB
SUB PSLC (y, x, t$)
_PRINTSTRING ((x - 1) * 8, (y - 1) * 16), t$
END SUB
SUB PSL (y, x, t$)
_PRINTSTRING ((x - 1) * _FONTWIDTH, (y - 1) * _FONTHEIGHT), t$
Overlay_Hardware = _COPYIMAGE(Overlay, 33)
_PUTIMAGE (0, 0), Overlay_Hardware
END SUB
SUB underline (y, x, uflag)
STATIC ucnt
ucnt = -ucnt - 1
IF ucnt OR uflag THEN
LINE ((x - 1) * _FONTWIDTH, y * _FONTHEIGHT)-((x - 1) * _FONTWIDTH + 12, y * _FONTHEIGHT), _RGB(24, 24, 24), BF
ELSE
LINE ((x - 1) * _FONTWIDTH, y * _FONTHEIGHT)-((x - 1) * _FONTWIDTH + 12, y * _FONTHEIGHT), DarkOrange, BF
END IF
Overlay_Hardware = _COPYIMAGE(Overlay, 33)
_PUTIMAGE (0, 0), Overlay_Hardware
END SUB
SUB thunder
SCREEN 0, 0, 1, 1
_DELAY 2
IF _FILEEXISTS("Thunder6.ogg") AND _FILEEXISTS("Thunder6.ogg") AND _FILEEXISTS("Thunder6.ogg") THEN
soundfile% = -1
END IF
FOR i = 1 TO 15
_DELAY i / 150
IF i / 2 = i \ 2 THEN
SOUND 250, .1
SCREEN 0, 0, 1, 1
ELSE
SCREEN 0, 0, 2, 2
IF i < 13 THEN _DELAY i / 100: SCREEN 0, 0, 3, 3: COLOR 0, 7: CLS
END IF
NEXT
PCOPY 2, 0
SCREEN 0, 0, 0, 0
_DELAY 1.5
END SUB
For much better sound effects, download and unzip the .ogg files, in the attachment, to your local folder.
I've noticed people posting code snippets and referring to the game tutorial as inspiration. If you write a game and wish it to be included in the list of games on the tutorial site let me know. I'm more than happy to showcase your game for you.
One thing you'll need to agree to though is that the source code must be included for others to learn from. I won't post pre-compiled .EXEs since there's no learning value there and no way to verify the program is destructive in any way.
I wanted to learn more about collisions, so I tried this.
I'm sure most people here already know about this but I figured I'd share anyway. The subject that is central here is "collision response", and in this case it's the "dynamic / static" variety. Interesting stuff for a mathematician I'm sure. Rather than deep dive into the physics I was able to accomplish a decent result using Terry's game tutorial (have I mentioned how great that is yet? haha)
Sound files are attached.
(Edit: use mouse to position chip and click to drop it)
Code: (Select All)
'Plinko
'james2464
'Oct 2022
Dim Shared scx, scy As Integer
'screen size
scx = 500 '
scy = 700 '
Screen _NewImage(scx, scy, 32)
Type movingchip
x As Single
y As Single
xv As Single
yv As Single
spd As Single
live As Integer
age As Integer
rad As Integer
colour As Integer
x1 As Integer
x2 As Integer
y1 As Integer
y2 As Integer
End Type
Dim Shared ch(10) As movingchip
Type fixedpin
x As Single
y As Single
rad As Integer
colour As Integer
x1 As Integer
x2 As Integer
y1 As Integer
y2 As Integer
End Type
Dim Shared pin(200) As fixedpin
Line (0, 0)-(scx, scy), c0(10), BF 'background colour
Line (1, 1)-(30, scy), c0(5), BF 'side borders
Line (scx, 1)-(scx - 30, scy), c0(5), BF
Line (30, 637)-(scx - 30, 639), c0(0), BF 'result position slots
Line (29, 600)-(31, 639), c0(0), BF
Line (scx - 29, 600)-(scx - 31, 639), c0(0), BF
For t = 1 To 8
Line (24 + 50 * t, 600)-(26 + 50 * t, 637), c0(0), BF
Next t
'result slot colours
Line (31, 640)-(75, scy), c0(11), BF
Line (76, 640)-(125, scy), c0(12), BF
Line (126, 640)-(175, scy), c0(13), BF
Line (176, 640)-(225, scy), c0(14), BF
Line (226, 640)-(275, scy), c0(15), BF
Line (276, 640)-(325, scy), c0(16), BF
Line (326, 640)-(375, scy), c0(17), BF
Line (376, 640)-(425, scy), c0(18), BF
Line (426, 640)-(scx - 30, scy), c0(19), BF
Dim Shared vx, vy, lv1, vx2, vy2, vx3, vy3, lv2, sp As Single
Dim Shared j As Integer
'define chip and pin
ch(1).rad = 16
Dim pintot As Integer
pintot = 93
t = 0
t2 = 0
t3 = 0
Do
t3 = t3 + 1
If t2 = 0 Then
For t1 = 1 To 8
t = t + 1
pin(t).x = 25 + t1 * 50
pin(t).y = 30 + t3 * 50
Next t1
t2 = 1
Else
For t1 = 1 To 9
t = t + 1
pin(t).x = 0 + t1 * 50
pin(t).y = 30 + t3 * 50
Next t1
t2 = 0
End If
Loop Until t = pintot
For t = 1 To pintot
pin(t).rad = 4
pin(t).x1 = pin(t).x - pin(t).rad
pin(t).x2 = pin(t).x + pin(t).rad
pin(t).y1 = pin(t).y - pin(t).rad
pin(t).y2 = pin(t).y + pin(t).rad
Next t
'draw pins
For t = 1 To pintot
_PutImage (pin(t).x - 10, pin(t).y - 10)-(pin(t).x + 10, pin(t).y + 10), pin1&, 0 ' draw pin
Next t
For j = 1 To pintot 'check for collision
If collide1 = 1 Then 'quick rectangle check
If collide2 = 1 Then 'if rectangle check confirmed, then circle collision check
vectorupdate 'change chip vector based on collision angle
End If
End If
Next j
Function collide1 'rectangle - early detection
collide1 = 0
If ch(1).x2 >= pin(j).x1 Then
If ch(1).x1 <= pin(j).x2 Then
If ch(1).y2 >= pin(j).y1 Then
If ch(1).y1 <= pin(j).y2 Then
collide1 = 1
End If
End If
End If
End If
End Function
Function collide2 'circle detection
Dim SideA%
Dim SideB%
Dim Hypot&
If ch(1).x = pin(j).x Then 'prevent chip from being perfectly above a pin (randomize and nudge)
t = Rnd * 100
If t > 49 Then
ch(1).x = ch(1).x + .05
Else
ch(1).x = ch(1).x - .05
End If
End If
collide2 = 0
SideA% = ch(1).x - pin(j).x
SideB% = ch(1).y - pin(j).y
Hypot& = SideA% * SideA% + SideB% * SideB%
If Hypot& <= ((ch(1).rad + pin(j).rad) * (ch(1).rad + pin(j).rad) + 4) Then 'added + 4 to prevent late detection
_SndPlayCopy click&
collide2 = 1
End If
End Function
Sub vectorupdate 'change chip movement based on collision
'update chip velocity vectors
If sp > .5 Then sp = sp * .65 'govern speed to prevent craziness
If ch(1).x <= pin(j).x Then
ch(1).xv = sp * vx3
If ch(1).xv > -.3 Then ch(1).xv = -.3 'keep things moving - override
Else
ch(1).xv = sp * vx3
If ch(1).xv < .3 Then ch(1).xv = .3 'keep things moving - override
End If
If ch(1).y <= pin(j).y Then
ch(1).yv = vy3 * sp
If ch(1).yv > -.3 Then ch(1).yv = -.3 'keep things moving - override
Else
ch(1).yv = 0 - vy3 * sp
If ch(1).yv < .3 Then ch(1).yv = .3 'keep things moving - override
End If
If you ever wanted to move a player in any direction by holding down the cursor arrow keys while still being able to process other events and even type other keys while still moving, this might be of interest to you.
Controls: (Hold down keys for perpetual movement.)
Right arrow = move right.
Left arrow = move left.
Up arrow = move up
Down arrow = move down... Duh, this sounds so stupid up to now, but wait...
Up arrow + left arrow = diagonal up and to the left.
Up arrow + right arrow = diagonal up and to the right.
Down arrow + left arrow = diagonal down and to the left.
Down arrow + right arrow = diagonal down and to the right.
Left ctrl + or without any arrow keys held and while or while not moving increases speed.
Left alt + or without any arrow keys held and while or while not moving decreases speed.
Type any key to print key character to the upper right screen while or while not moving.
space bar honks horn.
esc to quit.
An old problem with QBasic was not being able to detect more than two key presses. Special keys like ctrl, alt, and shift all had to be recognized with DEF SEG PEEK/POKE routines. (BTW - we can still use those PEKK/POKE (1046) routines in QB64.)
Anyway, here's the demo...
Code: (Select All)
' Note: timer is not adjusted for stroke of midnight event, so don't stay up late playing this.
WIDTH 140, 42
_SCREENMOVE 0, 0
DIM move_speed AS DOUBLE
top = 2: bottom = _HEIGHT: left = 1: right = _WIDTH
PRINT "Press single or combo of arrow keys to move. Rt. Ctrl = faster / Rt. Alt = slower. "
LOCATE 2, 1: PRINT STRING$(_WIDTH, "_");
move_speed = 25
player_y = _HEIGHT \ 2 + 1: player_x = _WIDTH \ 2
LOCATE player_y, player_x: PRINT "*";
_KEYCLEAR
DO
_LIMIT 60
LOCATE 1, 50: PRINT "Movement y, x: "; mpy; mpx; " Speed Delay ="; move_speed;
' If you only want speed changes when a player moves then remove the timer and move this routine to: IF move_player = -1 AND ABS(z1 - TIMER) > .07 THEN
IF ABS(z3 - TIMER) > .1 THEN ' Check every .1 seconds for a speed change.
IF _KEYDOWN(100307) AND move_speed < 50 THEN move_speed = move_speed + 1
IF _KEYDOWN(100305) AND move_speed > 0 THEN move_speed = move_speed - 1
z3 = TIMER
END IF
IF ABS(z2 - TIMER) > move_speed / 100 THEN ' Moving lag. Note: Division needed because computer math can't add decimal numbers correctly.
IF move_player = 0 THEN
IF _KEYDOWN(18432) OR _KEYDOWN(19200) OR _KEYDOWN(19712) OR _KEYDOWN(20480) THEN ' Arrow keys.
move_player = -1
z1 = TIMER ' Delay timer for key lag.
END IF
END IF
END IF
IF move_player = -1 THEN
IF ABS(z1 - TIMER) > .05 THEN ' Key lag. A slight delay to allow player to press two keys together within a reasonable amout of time.
DO ' Falx loop to throw out illegal key combos like up + down.
mpx = 0: mpy = 0
' Eliminate illegal combos.
IF _KEYDOWN(18432) AND _KEYDOWN(20480) THEN move_player = 0: z2 = TIMER: EXIT DO
IF _KEYDOWN(19712) AND _KEYDOWN(19200) THEN move_player = 0: z2 = TIMER: EXIT DO
' IF female THEN STOP AND GET #1, directions.
IF _KEYDOWN(18432) THEN ' Up-arrow.
mpy = -1
END IF
IF _KEYDOWN(19712) THEN ' Right-arrow.
mpx = 1
END IF
IF _KEYDOWN(20480) THEN ' Down-arrow.
mpy = 1
END IF
IF _KEYDOWN(19200) THEN ' Left-arrow.
mpx = -1
END IF
IF mpx AND mpy THEN ' Routine to cancel keys as a double hold is being lifted. This allows for the difference of both keys cannot be released at exactly the same time.
combo = -1
ELSE
IF combo THEN combo = 0: move_player = 0: EXIT DO
END IF
' Move player
IF player_y + mpy > top AND player_y + mpy <= bottom AND player_x + 2 * mpx > left AND player_x + 2 * mpx < right THEN
LOCATE player_y, player_x
PRINT " ";
player_y = player_y + mpy: player_x = player_x + 2 * mpx
LOCATE player_y, player_x
PRINT "*";
ELSE
BEEP ' Hit the wall!
END IF
move_player = 0
z2 = TIMER ' Timer for moving lag regulated by the move_speed variable.
EXIT DO
LOOP
END IF
ELSE ' If you want additional key routines, put them here...
ky$ = INKEY$
IF LEN(ky$) = 1 THEN ' For demo, exclude keys that start with chr$(0). Note without this arrow keys would still register here.
LOCATE 1, _WIDTH - 22: PRINT SPACE$(22);
LOCATE 1, _WIDTH - 22
PRINT "You pressed key: "; ky$;
SELECT CASE ky$
CASE CHR$(32) ' Space bar
BEEP
CASE CHR$(27) ' Esc
END
END SELECT
END IF
END IF
LOOP
'Spooky pentagram of doom for Halloween
'juts a little halloween season fun
Screen _NewImage(800, 500, 32)
_Define K As _UNSIGNED LONG
_FullScreen
'good music here
Play "MB O0 L4 cdccdcecdccdccdccdcecdccababcddcddcdde O2 L2 e e e e e"
'well not really
For d = 0 To 360
_Limit 20
Cls
circleBF 400, 250, (d * 1.1) / 2, _RGB32(250, 250, 0)
circleBF 400, 250, ((d * 1) / 2) - 2, _RGB32(0, 0, 0)
bumpypoly 400, 250, d / 2, 72, 180 + d, 1 + Int(d / 120), _RGB32(0, 250, 10)
bumpypentagram 400, 250, d / 2, 72, 180 + d, 1 + Int(d / 90), _RGB32(250, 2, 5)
_Display
Next d
_AutoDisplay
For n = 1 To 900
_Limit 400
sx = Int(Rnd * 800)
sy = Int(Rnd * 500)
klr = _RGB32(240 + Int(Rnd * 16), Int(Rnd * 10), Int(Rnd * 10))
rd = Int(Rnd * 12)
circleBF sx, sy, 8 + rd, klr
circleBF sx + Int(Rnd * (rd / 2)), sy + Int(Rnd * (rd / 2)), 4 + rd, klr
circleBF sx + Int(Rnd * (rd / 2)), sy + Int(Rnd * (rd / 2)), 2 + rd, klr
Next
Line (0, 0)-(800, 500), klr, BF
klr2 = _RGB32(250, 250, 0)
For t = 1 To 360
_Limit 180
pp = 1 + Int(Rnd * 3)
For reps = 1 To pp
sx = Int(Rnd * 800)
sy = Int(Rnd * 500)
rd = 3 + Int(Rnd * 24)
pentagram sx, sy, rd, 72, Int(Rnd * 360), .5 + Rnd * 2.5, klr2
Next reps
bumpypentagram 400, 250, 180, 72, 360, 1 + Int(t / 90), _RGB32(75 + t / 2, 75 + t / 2, 5)
Next t
For n = 0 To 255
_Limit 180
Line (0, 0)-(800, 500), _RGB32(0, 0, 0, n), BF
bumpypentagram 400, 250, 180, 72, 360, 5, _RGB32(255, 255, 5)
Next n
For n = 0 To 255
_Limit 180
bumpypentagram 400, 250, 180, 72, 360, 5, _RGB32(255, 255, 5)
Line (0, 0)-(800, 500), _RGB32(0, 0, 0, n), BF
Sub pentagram (cx, cy, rr, shapedeg, turn, thk, klr As _Unsigned Long)
Dim p(6, 2)
x = rr * Sin(0.01745329 * turn)
y = rr * Cos(0.01745329 * turn)
'Line (cx + x, cy + y)-(cx + x, cy + y), klr
lx = cx + x: ly = cy + y
n = 0
For deg = turn To turn + 360 Step shapedeg
x2 = rr * Sin(0.01745329 * deg)
y2 = rr * Cos(0.01745329 * deg)
' tv = (Rnd * 6 + Rnd * 6 + 3) / 10
' bumpyline lx, ly, cx + x2, cy + y2, thk * tv, klr
lx = cx + x2: ly = cy + y2
n = n + 1
p(n, 1) = cx + x2
p(n, 2) = cy + y2
Next
Line (p(1, 1), p(1, 2))-(p(3, 1), p(3, 2)), klr
Line (p(3, 1), p(3, 2))-(p(5, 1), p(5, 2)), klr
Line (p(5, 1), p(5, 2))-(p(2, 1), p(2, 2)), klr
Line (p(2, 1), p(2, 2))-(p(4, 1), p(4, 2)), klr
Line (p(4, 1), p(4, 2))-(p(6, 1), p(6, 2)), klr
End Sub
Sub bumpypoly (cx, cy, rr, shapedeg, turn, thk, klr As _Unsigned Long)
x = rr * Sin(0.01745329 * turn)
y = rr * Cos(0.01745329 * turn)
'Line (cx + x, cy + y)-(cx + x, cy + y), klr
lx = cx + x: ly = cy + y
For deg = turn To turn + 360 Step shapedeg
x2 = rr * Sin(0.01745329 * deg)
y2 = rr * Cos(0.01745329 * deg)
tv = (Rnd * 6 + Rnd * 6 + 3) / 10
bumpyline lx, ly, cx + x2, cy + y2, thk * tv, klr
lx = cx + x2: ly = cy + y2
Next
End Sub
Sub bumpylineLow (x0, y0, x1, y1, r, klr As _Unsigned Long)
dx = x1 - x0
dy = y1 - y0
yi = 1
If dy < 0 Then
yi = -1
dy = -dy
End If
'D = (2 * dy) - dx
d = (dy + dy) - dx
y = y0
For x = x0 To x1
tv = (Rnd * 12 + Rnd * 6 + 3) / 10
circleBF x, y, r * tv, klr
If d > 0 Then
y = y + yi
' D = D + (2 * (dy - dx))
d = d + ((dy - dx) + (dy - dx))
Else
' D = D + 2 * dy
d = d + dy + dy
End If
Next x
End Sub
Sub bumpylineHigh (x0, y0, x1, y1, r, klr As _Unsigned Long)
dx = x1 - x0
dy = y1 - y0
xi = 1
If dx < 0 Then
xi = -1
dx = -dx
End If
' D = (2 * dx) - dy
D = (dx + dx) - dy
x = x0
For y = y0 To y1
tv = (Rnd * 12 + Rnd * 6 + 3) / 10
circleBF x, y, r * tv, klr
If D > 0 Then
x = x + xi
' D = D + (2 * (dx - dy))
D = D + ((dx - dy) + (dx - dy))
Else
' D = D + 2 * dx
D = D + dx + dx
End If
Next y
End Sub
Sub bumpyline (x0, y0, x1, y1, r, klr As _Unsigned Long)
If Abs(y1 - y0) < Abs(x1 - x0) Then
If x0 > x1 Then
bumpylineLow x1, y1, x0, y0, r, klr
Else
bumpylineLow x0, y0, x1, y1, r, klr
End If
Else
If y0 > y1 Then
bumpylineHigh x1, y1, x0, y0, r, klr
Else
bumpylineHigh x0, y0, x1, y1, r, klr
End If
End If
End Sub
Sub circleBF (cx As Long, cy As Long, r As Long, klr As _Unsigned Long)
rsqrd = r * r
y = -r
While y <= r
x = Sqr(rsqrd - y * y)
Line (cx - x, cy + y)-(cx + x, cy + y), klr, BF
y = y + 1
Wend
End Sub
Is there a command that can identify two keys pressed together, like up-curor+left-cursor? and if so, how can I ensure that enough time is allowed for any slight discrepancy in the time they were pressed?
Android Nim is a version of the mathematical strategy game Nim programmed by Leo Christopherson for the TRS-80 computer in 1978. I programmed this version for the QB64 environment during the Covid-19 pandemic. Android Nim features real-time animation of the androids on a TRS-80.
The object of the game is to remove the last android from three rows of androids. The game's premise is simple, but its animation is impressive given the limitations of the TRS-80's display. Throughout the game androids are animated to face different directions, as if bored or engaging in conversation with one another.
The game starts with three rows of androids which contain 7, 5, and 3 androids respectively. An animated android asks the player if they would like to go first. The player chooses a row and types in how many droids to remove. An animated droid at the head of the row then nods its head and raises a gun and the other androids turn to look at the selected row. The specified number of androids are then zapped with a laser beam. It is then the computer's turn—with similar effect—and play continues until the last android is removed.
If the human wins, the computer is an amusingly poor sport and displays astonishment; if it wins, the computer displays a huge "I WIN!".
With this QB64 version I wanted to revive the screen and graphics of the TRS-80 computers.
Only the sound was not programmed.
Hopefully you like this version of Android Nim.
Soon there will be a new version of Android Nim, with sound and use of the mouse.
Below is the code, more than 1300 lines long. I hope the codepage and ASCII characters are copied correctly. If not, the source is also attached.
More of the original game at http://www.trs-80.org/android-nim
Code: (Select All)
$RESIZE:SMOOTH
DEFINT A-Z
DIM SHARED LucGev$, Belgium$, Version$, AndroidNim$, CURRENT_WORD$
'DIM SHARED TRUE, FALSE AS INTEGER
DIM SHARED AN_ANTENNE_00$, AN_ANTENNE_01$, AN_ANTENNE_L1$, AN_ANTENNE_L2$, AN_ANTENNE_R1$, AN_ANTENNE_R2$
DIM SHARED AN_HOOFD_01$, AN_HOOFD_02$, AN_HOOFD_03$, AN_HOOFD_04$, AN_HOOFD_05$, AN_HOOFD_06$
DIM SHARED AN_HOOFD_07$, AN_HOOFD_08$, AN_HOOFD_09$, AN_HOOFD_10$, AN_HOOFD_11$, AN_HOOFD_12$
DIM SHARED AN_HOOFD_13$, AN_HOOFD_14$, AN_HOOFD_15$, AN_HOOFD_16$, AN_HOOFD_17$, AN_HOOFD_18$
DIM SHARED AN_BODY_01$, AN_BODY_02$, AN_BODY_03$, AN_BODY_04$, AN_BODY_05$, AN_BODY_06$
DIM SHARED AN_BODY_07$, AN_BODY_08$, AN_BODY_09$, AN_BODY_10$, AN_BODY_11$, AN_BODY_12$
DIM SHARED AN_BODY_13$, AN_BODY_14$, AN_BODY_15$, AN_BODY_16$, AN_BODY_17$, AN_BODY_18$
DIM SHARED AN_BODY_19$, AN_BODY_20$, AN_BODY_21$, AN_BODY_22$, AN_BODY_23$, AN_BODY_24$
DIM SHARED AN_BODY_25$, AN_BODY_26$, AN_BODY_27$, AN_BODY_28$, AN_BODY_29$, AN_BODY_30$
DIM SHARED AN_BODY_31$, AN_BODY_32$, AN_BODY_33$, AN_BODY_34$
DIM SHARED AN_BENEN_01$, AN_BENEN_02$
DIM SHARED AIR(3) AS INTEGER 'Aantal in rij in getal
DIM SHARED BIR(3) AS STRING 'Aantal in rij binaire voorstelling
DIM SHARED KOL(3) AS STRING * 1 'E of O in de kolom.
DIM SHARED ALOC_KOL(3, 7) AS INTEGER 'locatie van de androids
DIM SHARED ALOC_RIJ(3) AS INTEGER 'de 3 rijen waar de androids starten
DIM SHARED SR, NR 'SelectROW, NR of Androids to shoot
DIM SHARED Wie 'Wie is aan de beurt; indien negatief dan is dit de winnaar. 1=MENS, 2=PC
DIM SHARED I_ColorScheme$(0 TO 10)
DIM SHARED H_ColorScheme AS INTEGER
DIM SHARED CHOSEN_WORDS(80)
DIM SHARED WORD$(80)
TYPE InitType
FullScreen AS INTEGER ' True of False
ColorScheme AS STRING ' TRS-80 Green|2|0|7
ForeColor AS INTEGER ' 2
BackColor AS INTEGER ' 0
AltForeColor AS INTEGER ' 7
AltShooter AS INTEGER '0
END TYPE
DIM SHARED INIT AS InitType
'Constants
CONST TRUE = -1
CONST FALSE = NOT TRUE
WORD_DATA:
DATA "DISGUSTING","STUPID","RIDICULOUS","IDIOTIC","GROTESQUE","ABSURD","NONSENSICAL","FARCICIAL","PREPOSTEROUS","SILLY","SENSELESS","IRRATIONAL","FANTASTIC"
DATA "ODD","RUDE","BRUTISH","BARBARIC","PLEBEIAN","UNCIVIL","DISCOURTEOUS","VULGAR","COARSE","GROSS","MONSTROUS","HORRID","SHOCKING","CHEAP"
DATA "INCONSIQUENTIAL","BULBOUS","DASTERDLY","MORONIC","IMMATURE","IMPOSSIBLE","ILLOGICAL","ELEPHANTINE","IRRESPONSIBLE","HUMANISTIC","DUMB-DUMB","RECKLESS"
DATA "NEGLIGENT","UNFEASIBLE","UNBEARABLE","INTOLERABLE","INSUFFERABLE","AWKWARD","OFFENSIVE","NAUGHTY","IMPROPER","UNCOUTH","ILL-MANNERED","LOUTISH","BOORISH"
DATA "BRASH","OUTLANDISH","TASTELESS","UNBEARABLE","INSUPPORTABLE","UNENDURABLE","UNSPEAKABLE","NEGLECTFUL","CARELESS","INATTENTIVE","SLIPSHOD","LAX","FORGETFUL"
DATA "UNINTELLIGENT","DIM-WITTED","BRAINLESS","OBTUSE","FOOLISH","IMPRUDENT","INJUDICIOUS","LAUGHABLE","TRADGIC","DISASTROUS","CATASTROPHIC","HEARTBREAKING","DREADFUL","APPALLING","WRETCHED"
VOLGENDE_ZET:
DO
COLOR INIT.ForeColor, INIT.BackColor: LOCATE 49, 60
IF Wie = 1 THEN
PRINT " * It's your turn *";
'clear input buffer
_KEYCLEAR
VRAAG_RIJ_KOL_2
ELSE
PRINT " * It's my turn *";
ANIMATE_SHOOTERS
ANIMATE_ANDROIDS
Bereken_Zet
END IF
IF SpelGedaan = 0 THEN
Wie = Wie * -1 'speler Wie heeft gewonnen
ELSEIF SpelGedaan <> 15 AND Wie <> -255 THEN 'bij 15 opgegeven, spel is herstart
Wie = Wie XOR 3
END IF
LOOP UNTIL Wie < 0
IF Wie = -1 THEN 'mens gewonnen
HUMAN_WIN
ELSEIF Wie = -2 THEN 'android nim gewonnen
I_WIN
END IF
IF Wie = -255 THEN 'spel gedaan
WIS_VELD
LOCATE 25, 30: PRINT "Thank you for playing Android Nim."
DO
x$ = INKEY$
ANIMATE_SHOOTERS
LOOP UNTIL x$ <> ""
WIDTH 80, 25: COLOR 7, 0: CLS: SYSTEM 0
ELSE 'opnieuw spelen
WIS_VELD
INIT_CONFIG
INIT_ANDROIDS
Plaats_Alle_Androids
GOTO VOLGENDE_ZET
END IF
'Convert_To_BIN
'WIDTH 80, 25: COLOR 7, 0: CLS: END
SYSTEM 1
SUB STARTSCHERM
'Init name and the rest
LucGev$ = "Luc Gevaert": Belgium$ = "Belgium": Version$ = "1.02": AndroidNim$ = "Android Nim"
x$ = LucGev$ + Belgium$ + AndroidNim$: som = 0 'som moet 2780 zijn om correct te zijn.
'check for zappers in the code.
FOR A = 1 TO LEN(x$)
som = som + ASC(MID$(x$, A, 1))
NEXT
IF som <> 2780 THEN
'please, no!
PRINT: PRINT "Please do not change the code. Thanks in advance.": PRINT "Press ANY key..."
x$ = INPUT$(1): SYSTEM 1
END IF
'screen in 80x50 fullscreen.
_TITLE AndroidNim$
SCREEN 0, 1, 0, 0: IF INIT.FullScreen = 1 THEN _FULLSCREEN _SQUAREPIXELS , _SMOOTH ELSE _FULLSCREEN _OFF
_BLINK OFF
_SCREENMOVE _MIDDLE
STARTSCHERM2:
COLOR INIT.ForeColor, INIT.BackColor: CLS
'teken startscherm
PRINT "ÛßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßÛ";
PRINT "Û Û";
PRINT "Û Û";
PRINT "Û Û Û Û";
PRINT "Û Û Û Û";
PRINT "Û ÛÛÛÛÛÛ ÜÛÛÛÛÛÜ ÜÛÛÛÛÛÜ ÛÛÛÛÛÛÜ ÛÛÛÛÛÛÜ ÜÛÛÛÛÛÜ ÞÛÛÝ ÛÛÛÛÛÛÜ Û";
PRINT "Û ÛÛ ÛÛ ÛÛ ÛÛÜÜÜÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ Û";
PRINT "Û ÛÛÛ ÛÛÛ ÛÛßßßÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛÛÛÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ Û";
PRINT "Û ÛÛÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛÛÛÛÛß ÛÛ ßÛÛ ßÛÛÛÛÛß ÞÛÛÝ ÛÛÛÛÛÛß Û";
PRINT "Û ÛÛÛÛÛÛÛÛ Û";
PRINT "Û ÛÛ ÛÛÛÛ ÛÛ Û";
PRINT "Û ÛÛ ÛÛÛÛ ÛÛ ÜÛÛÛÛÛÜ ÞÛÛÝ ÜÛÛÛÛÛÛÜ Û";
PRINT "Û ÛÛ ÛÛÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ Û";
PRINT "Û ÛÛÛ ÛÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ Û";
PRINT "Û Û Û ÛÛ ÛÛ ÞÛÛÝ ÛÛ ÛÛ ÛÛ Û";
PRINT "Û Û Û Û";
PRINT "Û ÛÛÛÛ ÛÛÛÛ Û";
PRINT "Û ";: COLOR INIT.AltForeColor: PRINT AndroidNim$; " - Version "; Version$; " - By "; LucGev$; SPACE$(10);: COLOR INIT.ForeColor: PRINT "Û";
PRINT "Û ";: COLOR INIT.AltForeColor: PRINT " Original by Leo Christopherson, 1979-1986";: COLOR INIT.ForeColor: PRINT " Û";
PRINT "Û Û";
PRINT "Û Û";
PRINT "Û Û";
PRINT "Û Û";
PRINT "ßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßß";
LOCATE 25, 1: PRINT "Press ";: COLOR INIT.BackColor, INIT.ForeColor: PRINT " ÄÄÙ ";: COLOR INIT.ForeColor, INIT.BackColor: PRINT " to start, ";
COLOR INIT.BackColor, INIT.ForeColor: PRINT " H ";: COLOR INIT.ForeColor, INIT.BackColor: PRINT " for Help, ";: COLOR INIT.BackColor, INIT.ForeColor
PRINT " I ";: COLOR INIT.ForeColor, INIT.BackColor: PRINT " for Info, ";
COLOR INIT.BackColor, INIT.ForeColor: PRINT " S ";: COLOR INIT.ForeColor, INIT.BackColor: PRINT " for Setup, ";: COLOR INIT.BackColor, INIT.ForeColor: PRINT " ESC ";
COLOR INIT.ForeColor, INIT.BackColor: PRINT " to exit";:
WHILE INKEY$ <> "": WEND 'Clear keyboard buffer
x$ = ""
STARTSCHERM1:
x$ = LCASE$(INKEY$)
IF x$ = CHR$(27) THEN 'end program
SCREEN 0, 1, 0, 0: _FULLSCREEN _OFF: COLOR 7, 0: CLS
SYSTEM 0
END IF
IF x$ = "s" THEN
INIT_SETUP
GOTO STARTSCHERM2
END IF
IF x$ = "i" THEN
START_INFO
GOTO STARTSCHERM2
END IF
IF x$ = "h" THEN
START_HELP
GOTO STARTSCHERM2
END IF
IF x$ <> CHR$(13) THEN GOTO STARTSCHERM1
ff = FREEFILE
IF _FILEEXISTS(FN$) THEN
OPEN FN$ FOR INPUT AS ff
IF NOT EOF(ff) THEN INPUT #ff, INIT.FullScreen
IF NOT EOF(ff) THEN INPUT #ff, INIT.ColorScheme
IF NOT EOF(ff) THEN INPUT #ff, INIT.ForeColor
IF NOT EOF(ff) THEN INPUT #ff, INIT.BackColor
IF NOT EOF(ff) THEN INPUT #ff, INIT.AltForeColor
IF NOT EOF(ff) THEN INPUT #ff, INIT.AltShooter
ELSE
OPEN FN$ FOR OUTPUT AS ff
PRINT #ff, INIT.FullScreen
PRINT #ff, INIT.ColorScheme
PRINT #ff, INIT.ForeColor
PRINT #ff, INIT.BackColor
PRINT #ff, INIT.AltForeColor
PRINT #ff, INIT.AltShooter
END IF
CLOSE ff
RESTORE WORD_DATA
FOR X = 1 TO 80
READ WORD$(X)
CHOSEN_WORDS(X) = 0
NEXT X
'bepaal de rij en kolommen van de androids
'elke android is 15 hoog + 2 spaties (=17), Startlocatie eerste android op rij 5
FOR a = 1 TO 3
ALOC_RIJ(a) = 17 * (a - 1) + 2
NEXT
'elke android is 6 breed + 4 spaties (=10), startlocatie rij 1 is 25
FOR a = 1 TO 7
ALOC_KOL(1, a) = 9 * (a - 1) + 17 '9 breed ipv 10
NEXT
FOR a = 1 TO 7
IF a < 6 THEN ALOC_KOL(2, a) = 10 * (a - 1) + 25 ELSE ALOC_KOL(2, a) = 0
NEXT
FOR a = 1 TO 7
IF a < 4 THEN ALOC_KOL(3, a) = 10 * (a - 1) + 33 ELSE ALOC_KOL(3, a) = 0
NEXT
'ALOC_KOL(rij,0) = locatie van de Chef.
ALOC_KOL(1, 0) = 5: ALOC_KOL(2, 0) = ALOC_KOL(1, 0) + 3: ALOC_KOL(3, 0) = ALOC_KOL(1, 0) + 1
'zet de Androids voor de eerste maal op 't scherm.
'Plaats_Alle_Androids
END SUB
SUB Convert_To_BIN
FOR A = 1 TO 3
number = AIR(A)
Binary$ = ""
DO
remain = ABS(number MOD 2) ' remainder is used to create binary number
number = number \ 2 ' move up one exponent of 2 with integer division
Bin$ = LTRIM$(STR$(remain)) ' make remainder a string number
Binary$ = Bin$ + Binary$ ' add remainder to binary number
LOOP UNTIL number = 0
BIR(A) = RIGHT$("00" + Binary$, 3)
NEXT
FOR k = 1 TO 3
number = 0
FOR r = 1 TO 3
number = number + VAL(MID$(BIR(r), k, 1))
NEXT
IF number AND NOT -2 THEN KOL(k) = "O" ELSE KOL(k) = "E"
NEXT
END SUB
FUNCTION SpelGedaan
SpelGedaan = AIR(1) + AIR(2) + AIR(3)
END FUNCTION
SUB Bereken_Zet
sw = 0
FOR r = 1 TO 3 '3 rijen androids
NR = 0: SR = 0 'nr of androids to shoot, select row
O_AIR = AIR(r) 'Bewaar vorige # androids in rij
FOR A = O_AIR - 1 TO 0 STEP -1
AIR(r) = A: sw = 1
Convert_To_BIN
IF KOL(1) + KOL(2) + KOL(3) = "EEE" THEN 'een gunstige situatie
NR = O_AIR - A: SR = r: AIR(r) = O_AIR - NR
'LOCATE 42, 60: PRINT "EEE => NR="; NR; " SR="; SR;
'_DELAY 4
EXIT FOR
END IF
NEXT
IF NR + SR = 0 THEN
AIR(r) = O_AIR
ELSE
EXIT FOR
END IF
NEXT
'''''IF NR + SR <> 0 THEN EXIT SUB
IF NR + SR <> 0 THEN GOTO BEREKEN_ZET_1
'niets gevonden. ofwel zijn er geen androids meer en is er een winnaar ofwel moet android nim zelf beslissen
'android nim beslist zelf. haal 1 weg van de beschikbare rij
IF SpelGedaan = 0 THEN EXIT SUB
RANDOMIZE TIMER
DO
SR = INT(RND * 3) + 1
LOOP UNTIL AIR(SR) <> 0
'SR = willekeurige rij waar androids staan
NR = INT(RND * AIR(SR)) + 1 'nr = willekeurig aantal androids
'LOCATE 41, 60: PRINT "GEEN EEE => NR="; NR; " SR="; SR;
'_DELAY 4
BEREKEN_ZET_1:
LOCATE ALOC_RIJ(SR) + 3, 1: COLOR INIT.BackColor, INIT.ForeColor: PRINT " ";
LOCATE ALOC_RIJ(SR) + 4, 1: PRINT STR$(SR); " ";
LOCATE ALOC_RIJ(SR) + 5, 1: PRINT " ";: COLOR INIT.ForeColor, INIT.BackColor
_DELAY 1
LOCATE ALOC_RIJ(SR) + 7, 1: COLOR INIT.BackColor, INIT.ForeColor: PRINT " ";
LOCATE ALOC_RIJ(SR) + 8, 1: PRINT STR$(NR); " ";
LOCATE ALOC_RIJ(SR) + 9, 1: PRINT " ";: COLOR INIT.ForeColor, INIT.BackColor
_DELAY 1
WIS_ANDROIDS
'IF sw = 0 THEN AIR(SR) = NR
Convert_To_BIN
END SUB
SUB VRAAG_RIJ_KOL_2
VRAAG_R_K_2:
'Vraag rij
DO
x$ = INKEY$
ANIMATE_SHOOTERS
ANIMATE_ANDROIDS
LOOP UNTIL x$ <> ""
IF x$ = "r" OR x$ = "R" THEN
WIS_VELD
INIT_CONFIG
INIT_ANDROIDS
Plaats_Alle_Androids
EXIT SUB
END IF
IF x$ = CHR$(27) THEN Wie = -255: EXIT SUB
SR = VAL(x$)
IF SR < 1 OR SR > 3 THEN GOTO VRAAG_R_K_2
IF AIR(SR) = 0 THEN
Knik_Nee
GOTO VRAAG_R_K_2
END IF
LOCATE ALOC_RIJ(SR) + 3, 1: COLOR INIT.BackColor, INIT.ForeColor: PRINT " ";
LOCATE ALOC_RIJ(SR) + 4, 1: PRINT STR$(SR); " ";
LOCATE ALOC_RIJ(SR) + 5, 1: PRINT " ";: COLOR INIT.ForeColor, INIT.BackColor
'Vraag aantal
VRAAG_R_K_3:
DO
x$ = INKEY$
ANIMATE_SHOOTERS
ANIMATE_ANDROIDS
LOOP UNTIL x$ <> ""
IF x$ = "r" OR x$ = "R" THEN
WIS_VELD
INIT_CONFIG
INIT_ANDROIDS
Plaats_Alle_Androids 'tijdelijk
EXIT SUB
END IF
IF x$ = CHR$(27) THEN Wie = -255: EXIT SUB
IF x$ = " " THEN
LOCATE ALOC_RIJ(SR) + 3, 1: COLOR INIT.ForeColor, INIT.BackColor: PRINT " ";
LOCATE ALOC_RIJ(SR) + 4, 1: PRINT " ";
LOCATE ALOC_RIJ(SR) + 5, 1: PRINT " ";
GOTO VRAAG_R_K_2
END IF
NR = VAL(x$)
IF NR < 1 OR NR > AIR(SR) THEN
Knik_Nee
GOTO VRAAG_R_K_2
END IF
LOCATE ALOC_RIJ(SR) + 7, 1: COLOR INIT.BackColor, INIT.ForeColor: PRINT " ";
LOCATE ALOC_RIJ(SR) + 8, 1: PRINT STR$(NR); " ";
LOCATE ALOC_RIJ(SR) + 9, 1: PRINT " ";: COLOR INIT.ForeColor, INIT.BackColor
WIS_ANDROIDS
'AIR(SR) = AIR(SR) - NR
Convert_To_BIN
END SUB
SUB Plaats_Alle_Androids
COLOR INIT.ForeColor, INIT.BackColor
CLS 'wis scherm
'Plaats de 3 chefs
IF INIT.AltShooter = 1 THEN COLOR INIT.AltForeColor, INIT.BackColor
FOR a = 1 TO 3
k = ALOC_KOL(a, 0)
LOCATE ALOC_RIJ(a), k: PRINT AN_ANTENNE_01$;
LOCATE ALOC_RIJ(a) + 1, k: PRINT AN_ANTENNE_01$;
LOCATE ALOC_RIJ(a) + 2, k: PRINT AN_HOOFD_01$;
LOCATE ALOC_RIJ(a) + 3, k: PRINT AN_HOOFD_02$;
LOCATE ALOC_RIJ(a) + 4, k: PRINT AN_HOOFD_03$;
LOCATE ALOC_RIJ(a) + 5, k: PRINT AN_HOOFD_04$;
LOCATE ALOC_RIJ(a) + 6, k: PRINT AN_BODY_01$;
LOCATE ALOC_RIJ(a) + 7, k: PRINT AN_BODY_06$;
LOCATE ALOC_RIJ(a) + 8, k: PRINT AN_BODY_03$;
LOCATE ALOC_RIJ(a) + 9, k: PRINT AN_BODY_04$;
LOCATE ALOC_RIJ(a) + 10, k: PRINT AN_BODY_05$;
LOCATE ALOC_RIJ(a) + 11, k: PRINT AN_BENEN_01$;
LOCATE ALOC_RIJ(a) + 12, k: PRINT AN_BENEN_01$;
LOCATE ALOC_RIJ(a) + 13, k: PRINT AN_BENEN_02$;
NEXT
COLOR INIT.ForeColor, INIT.BackColor
Wie = 0
LOCATE 25, 30: PRINT "First move by You (1) or Me (2) ?"
DO
x$ = INKEY$
ANIMATE_SHOOTERS
LOOP UNTIL x$ = "1" OR x$ = "2"
Wie = VAL(x$): LOCATE 25, 30: PRINT SPACE$(33);: LOCATE 25, 30
IF Wie = 1 THEN
PRINT "Very well, you may start !";
ELSE
PRINT "OK,I'll start !";
END IF
_DELAY 1.6
LOCATE 25, 30: PRINT SPACE$(33);
COLOR INIT.ForeColor, INIT.BackColor
FOR r = 1 TO 3
FOR k = 1 TO AIR(r)
l = ALOC_KOL(r, k)
LOCATE ALOC_RIJ(r), l: PRINT AN_ANTENNE_01$;
LOCATE ALOC_RIJ(r) + 1, l: PRINT AN_ANTENNE_01$;
LOCATE ALOC_RIJ(r) + 2, l: PRINT AN_HOOFD_01$;
LOCATE ALOC_RIJ(r) + 3, l: PRINT AN_HOOFD_02$;
LOCATE ALOC_RIJ(r) + 4, l: PRINT AN_HOOFD_03$;
LOCATE ALOC_RIJ(r) + 5, l: PRINT AN_HOOFD_04$;
LOCATE ALOC_RIJ(r) + 6, l: PRINT AN_BODY_01$;
LOCATE ALOC_RIJ(r) + 7, l: PRINT AN_BODY_02$;
LOCATE ALOC_RIJ(r) + 8, l: PRINT AN_BODY_03$;
LOCATE ALOC_RIJ(r) + 9, l: PRINT AN_BODY_04$;
LOCATE ALOC_RIJ(r) + 10, l: PRINT AN_BODY_05$;
LOCATE ALOC_RIJ(r) + 11, l: PRINT AN_BENEN_01$;
LOCATE ALOC_RIJ(r) + 12, l: PRINT AN_BENEN_01$;
LOCATE ALOC_RIJ(r) + 13, l: PRINT AN_BENEN_02$;
NEXT
NEXT
INIT_SETUP1:
IF INIT.FullScreen = 1 THEN _FULLSCREEN ELSE _FULLSCREEN _OFF 'Gaan we in Window of Full Screen?
COLOR INIT.ForeColor, INIT.BackColor: CLS
PRINT "ÛßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßÛ";
PRINT "Û Û";
PRINT "Û Û";
PRINT "Û Û Û ";: COLOR INIT.AltForeColor: PRINT AndroidNim$; " Setup";: PRINT SPACE$(38);: COLOR INIT.ForeColor: PRINT "Û";
PRINT "Û Û Û ";: COLOR INIT.AltForeColor: PRINT STRING$(48, "Ä");: COLOR INIT.ForeColor: PRINT " Û";
PRINT "Û ÛÛÛÛÛÛ Û";
PRINT "Û ÛÛ ÛÛ ÛÛ Fullscreen? Yes No Û";
PRINT "Û ÛÛÛ ÛÛÛ Û";
PRINT "Û ÛÛÛÛ Color Scheme: X Û";
PRINT "Û ÛÛÛÛÛÛÛÛ Û";
PRINT "Û ÛÛ ÛÛÛÛ ÛÛ Shooters: Normal Second Color Û";
PRINT "Û ÛÛ ÛÛÛÛ ÛÛ Û";
PRINT "Û ÛÛ ÛÛÛÛ ÛÛ ";: COLOR INIT.AltForeColor: PRINT STRING$(48, "Ä");: COLOR INIT.ForeColor: PRINT " Û";
PRINT "Û ÛÛÛ ÛÛÛ Û";
PRINT "Û Û Û Û";
PRINT "Û Û Û Û";
PRINT "Û ÛÛÛÛ ÛÛÛÛ Û";
PRINT "Û Û";
PRINT "Û Û";
PRINT "Û Û";
PRINT "Û Û";
PRINT "Û Û";
PRINT "ßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßß";
LOCATE 24, 1: PRINT " Use ";: COLOR INIT.BackColor, INIT.ForeColor: PRINT " ";: COLOR INIT.ForeColor, INIT.BackColor: PRINT " and ";
COLOR INIT.BackColor, INIT.ForeColor: PRINT " ";: COLOR INIT.ForeColor, INIT.BackColor: PRINT " to select - ";: COLOR INIT.BackColor, INIT.ForeColor
PRINT " SPACE ";: COLOR INIT.ForeColor, INIT.BackColor: PRINT " to change setting";
LOCATE 25, 1: PRINT " ";: COLOR INIT.BackColor, INIT.ForeColor: PRINT " ÄÄÙ ";: COLOR INIT.ForeColor, INIT.BackColor: PRINT " Return and use changes - ";
COLOR INIT.BackColor, INIT.ForeColor: PRINT " S ";: COLOR INIT.ForeColor, INIT.BackColor: PRINT " Save changes to disk - ";
COLOR INIT.BackColor, INIT.ForeColor: PRINT " Esc ";: COLOR INIT.ForeColor, INIT.BackColor: PRINT " Aborts";
LOCATE rijp, K - 20: COLOR INIT.AltForeColor, INIT.BackColor: PRINT "ÍÍ";
'*** Vul scherm aan met de waarden
IF INIT.FullScreen = 1 THEN
LOCATE rij, K: COLOR INIT.BackColor, INIT.ForeColor: PRINT " Yes ";: COLOR INIT.ForeColor, INIT.BackColor: PRINT " No ";
ELSE
LOCATE rij, K: COLOR INIT.ForeColor, INIT.BackColor: PRINT " Yes ";: COLOR INIT.BackColor, INIT.ForeColor: PRINT " No ";
END IF
a = INSTR(INIT.ColorScheme, "|")
IF a > 1 AND LEN(INIT.ColorScheme) > 7 THEN
x$ = LEFT$(INIT.ColorScheme, a - 1): IF LEN(x$) > 33 THEN x$ = LEFT$(x$, 33)
LOCATE rij + 2, K: COLOR INIT.BackColor, INIT.ForeColor: PRINT " "; x$; " ";
ELSE
LOCATE rij + 2, K: COLOR INIT.ForeColor, INIT.BackColor: PRINT " *Error* ";
END IF
IF INIT.AltShooter = 0 THEN
LOCATE rij + 4, K: COLOR INIT.BackColor, INIT.ForeColor: PRINT " Normal ";: COLOR INIT.ForeColor, INIT.BackColor: PRINT " Second Color ";
ELSE
LOCATE rij + 4, K: COLOR INIT.ForeColor, INIT.BackColor: PRINT " Normal ";: COLOR INIT.BackColor, INIT.ForeColor: PRINT " Second Color ";
END IF
init_setup2:
DO: x$ = INKEY$: LOOP UNTIL x$ <> ""
'ESC = terugplaatsen van de waarden en uit init gaan
IF x$ = CHR$(27) THEN
INIT.FullScreen = O_FS
INIT.ColorScheme = O_CS$
INIT.ForeColor = O_FC
INIT.BackColor = O_BC
INIT.AltForeColor = O_AC
INIT.AltShooter = O_AS
EXIT SUB
END IF
'ENTER = gewoon terug gaan
IF x$ = CHR$(13) THEN EXIT SUB
'Save
IF x$ = "S" OR x$ = "s" THEN
FN$ = "AndroidNim.CFG"
ff = FREEFILE
OPEN FN$ FOR OUTPUT AS ff
PRINT #ff, INIT.FullScreen
PRINT #ff, INIT.ColorScheme
PRINT #ff, INIT.ForeColor
PRINT #ff, INIT.BackColor
PRINT #ff, INIT.AltForeColor
PRINT #ff, INIT.AltShooter
CLOSE ff
EXIT SUB
END IF
LOCATE rijp, K - 20: COLOR INIT.AltForeColor, INIT.BackColor: PRINT " ";
IF x$ = CHR$(0) + CHR$(80) THEN 'pijn beneden
rijp = rijp + 2: IF rijp = 13 THEN rijp = rij
END IF
IF x$ = CHR$(0) + CHR$(72) THEN 'pijl boven
rijp = rijp - 2: IF rijp = rij - 2 THEN rijp = 11
END IF
LOCATE rijp, K - 20: COLOR INIT.AltForeColor, INIT.BackColor: PRINT "ÍÍ";
IF x$ = " " THEN 'spatiebalk
SELECT CASE rijp
CASE 7 'fullscreen
IF INIT.FullScreen = 0 THEN INIT.FullScreen = 1 ELSE INIT.FullScreen = 0
CASE 9 'color scheme
H_ColorScheme = H_ColorScheme + 1: IF H_ColorScheme = 11 THEN H_ColorScheme = 1
INIT.ColorScheme = I_ColorScheme$(H_ColorScheme)
a = INSTR(INIT.ColorScheme, "|") + 1
INIT.ForeColor = VAL(MID$(INIT.ColorScheme, a, 2))
INIT.BackColor = VAL(MID$(INIT.ColorScheme, a + 3, 2))
INIT.AltForeColor = VAL(MID$(INIT.ColorScheme, a + 6, 2))
CASE 11 'Shooters
IF INIT.AltShooter = 0 THEN INIT.AltShooter = 1 ELSE INIT.AltShooter = 0
END SELECT
GOTO INIT_SETUP1
END IF
GOTO init_setup2
END SUB
SUB START_INFO
CLS
PRINT "ÛßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßÛ";
PRINT "Û Android Nim was originally programmed by Leo Christopherson Û";
PRINT "Û on the TRS-80 model 1, 3 and 4. This version of Android Nim Û";
PRINT "Û Û Û was reprogrammed in the Windows environment by Luc Gevaert. Û";
PRINT "Û Û Û This program is programmed completely in text mode. Û";
PRINT "Û ÛÛÛÛÛÛ Û";
PRINT "Û ÛÛ ÛÛ ÛÛ Android Nim was Leo Christopherson's first game for the Û";
PRINT "Û ÛÛÛ ÛÛÛ TRS-80. It was featured on the cover of 80-Northwest Journal Û";
PRINT "Û ÛÛÛÛ (later 80-U.S. Journal) in November 1978 and was released by Û";
PRINT "Û ÛÛÛÛÛÛÛÛ 80-NW Publishing (later 80-U.S. Software). The cost was $8.00 Û";
PRINT "Û ÛÛ ÛÛÛÛ ÛÛ for cassette and $13.00 for disk, with a $2.00 discount for Û";
PRINT "Û ÛÛ ÛÛÛÛ ÛÛ 80-Northwest Journal subscribers. This great game helped to Û";
PRINT "Û ÛÛ ÛÛÛÛ ÛÛ popularize the magazine, and 80-U.S. Journal used an android Û";
PRINT "Û ÛÛÛ ÛÛÛ for its mascot until 1981. Û";
PRINT "Û Û Û Soon after the original release, Leo Christopherson enhanced Û";
PRINT "Û Û Û Android Nim with sound and more animation, developing the Û";
PRINT "Û ÛÛÛÛ ÛÛÛÛ techniques known as 'string-packing' and 'line-packing' in Û";
PRINT "Û the process. The enhanced version of Android Nim cost $14.95. Û";
PRINT "Û Like all of Leo Christopherson's TRS-80 games, Android Nim Û";
PRINT "Û was written in combination of BASIC and machine language. Û";
PRINT "Û Û";
PRINT "Û Û";
PRINT "Û Û";
PRINT "ßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßß";
LOCATE 22, 18: COLOR INIT.AltForeColor: PRINT AndroidNim$; ", version "; Version$; " by "; LucGev$; ", "; Belgium$;
LOCATE 25, 1: COLOR INIT.ForeColor: PRINT "Press ANY key to return...";
DO UNTIL INKEY$ <> "": LOOP
END SUB
SUB START_HELP
CLS
PRINT "ÛßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßÛ";
PRINT "Û Û";
PRINT "Û ÜÛÛÛÛÛÜ ÜÛÛÛÛÛÜ ÛÛÛÛÛÛÜ ÛÛÛÛÛÛÜ ÜÛÛÛÛÛÜ ÛÛÛÛ ÛÛÛÛÛÛÜ Û";
PRINT "Û Û Û ÛÛÜÜÜÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ Û";
PRINT "Û Û Û ÛÛßßßÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛÛÛÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ Û";
PRINT "Û ÛÛÛÛÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛÛÛÛÛß ÛÛ ßÛÛ ßÛÛÛÛÛß ÛÛÛÛ ÛÛÛÛÛÛß Û";
PRINT "Û ÛÛ ÛÛ ÛÛ Û";
PRINT "Û ÛÛÛ ÛÛÛ ÜÛÛÛÛÛÜ ÛÛÛÛ ÜÛÛÛÛÛÛÜ Û";
PRINT "Û ÛÛÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ Û";
PRINT "Û ÛÛÛÛÛÛÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ Û";
PRINT "Û ÛÛ ÛÛÛÛ ÛÛ ÛÛ ÛÛ ÛÛÛÛ ÛÛ ÛÛ ÛÛ Û";
PRINT "Û ÛÛ ÛÛÛÛ ÛÛ Û";
PRINT "Û ÛÛ ÛÛÛÛ ÛÛ At the bottom right you see whose turn it is. Then press Û";
PRINT "Û ÛÛÛ ÛÛÛ the number '";: COLOR INIT.AltForeColor: PRINT "1";:: COLOR INIT.ForeColor: PRINT "', '";
COLOR INIT.AltForeColor: PRINT "2";: COLOR INIT.ForeColor: PRINT "' or '";: COLOR INIT.AltForeColor: PRINT "3";: COLOR INIT.ForeColor: PRINT "', of the row you wish to remove Û";
PRINT "Û Û Û Androids from. Û";
PRINT "Û Û Û If you change your mind, press the '";: COLOR INIT.AltForeColor:: PRINT "Spacebar";: COLOR INIT.ForeColor: PRINT "', it erases. Û";
PRINT "Û ÛÛÛÛ ÛÛÛÛ If you wish to give up, press the '";: COLOR INIT.AltForeColor: PRINT "R";: COLOR INIT.ForeColor: PRINT "' key. Û";
PRINT "Û After you choose the row, press the number of Androids Û";
PRINT "Û you wish to remove. Û";
PRINT "Û ";: COLOR INIT.AltForeColor: PRINT "Rules:";: COLOR INIT.ForeColor: PRINT " you may remove as many Androids as you wish from Û";
PRINT "Û any row when it's your turn. To win, you must remove Û";
PRINT "Û the last Android. Û";
PRINT "Û Û";
PRINT "ßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßß";
LOCATE 25, 1: PRINT "Press ANY key to return...";
DO UNTIL INKEY$ <> "": LOOP
SUB WIS_VELD
COLOR INIT.ForeColor, INIT.BackColor
FOR a = 2 TO 49
LOCATE a, 14
PRINT SPACE$(65);
NEXT
END SUB
SUB I_WIN
_DELAY 1
WIS_VELD
LOCATE 22, 30: PRINT "ÞÛÛÝ ÛÛ ÛÛ ÛÛ ÞÛÛÝ ÜÛÛÛÛÛÜ";
LOCATE 23, 30: PRINT " ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ";
LOCATE 24, 30: PRINT " ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ ÛÛ";
LOCATE 25, 30: PRINT "ÞÛÛÝ ßÛÛÛÛÛÛß ÞÛÛÝ ÛÛ ÛÛ";
LOCATE 28, 29: PRINT "Another game? Press ";
COLOR INIT.BackColor, INIT.ForeColor: PRINT " Y ";: COLOR INIT.ForeColor, INIT.BackColor: PRINT " or ";
COLOR INIT.BackColor, INIT.ForeColor: PRINT " N ";: COLOR INIT.ForeColor, INIT.BackColor
DO
x$ = LCASE$(INKEY$)
ANIMATE_SHOOTERS
LOOP UNTIL x$ = "y" OR x$ = "n"
IF x$ = "n" THEN Wie = -255 ELSE Wie = 0
END SUB
SUB HUMAN_WIN
_DELAY 1
WIS_VELD
LOCATE 22, 30: PRINT "Through Some Amazingly Graceful"
LOCATE 24, 30: PRINT "but"
LOCATE 26, 30: PRINT "Personal Miscalculation,"
LOCATE 28, 36: PRINT "YOU WIN !?"
COLOR INIT.AltForeColor, INIT.BackColor
FOR x = 1 TO 10
CHOOSE_WORD:
W = INT(RND * 80) + 1
IF CHOSEN_WORDS(W) = 1 THEN GOTO CHOOSE_WORD
CHOSEN_WORDS(W) = 1
CURRENT_WORD$ = WORD$(W)
LOCATE 24, 34: PRINT SPACE$(20);
LOCATE 24, 34: PRINT CURRENT_WORD$;
_DELAY (RND * 0.7) + 1
ANIMATE_SHOOTERS
NEXT
LOCATE 30, 30: PRINT "Another game? Press ";
COLOR INIT.BackColor, INIT.ForeColor: PRINT " Y ";: COLOR INIT.ForeColor, INIT.BackColor: PRINT " or ";
COLOR INIT.BackColor, INIT.ForeColor: PRINT " N ";: COLOR INIT.ForeColor, INIT.BackColor
DO
x$ = LCASE$(INKEY$)
ANIMATE_SHOOTERS
LOOP UNTIL x$ = "y" OR x$ = "n"
IF x$ = "n" THEN Wie = -255 ELSE Wie = 0
DeathTeatDungeon is a simple rogue-like example. It's based off the code I used in Wandering in the Cave but makes use of a graphic tileset.
It's currently set-up to play a simple escape scenario. Eventually monsters and treasures will be added to the game, the graphics are there currently just not all the rest of the code.
This is in two codeblocks, the main program you can name however you like the tileset and tileloading function should be saved in a file called "DTDtiles.bi" if you want to use the code as is.
thanks again to DAV for his BASIMAGE program whichmade this program possible as is.
DeathTestDungeon Main Program
Code: (Select All)
'DeathTestDungeon v0.3b
'By James D. Jarvis
' a simple rogue-like example
' in progress
' has simple exit challenge built in for now , no guarantee the starting positon will be safe or the game will be playable just yet
'
'curenntly this is all rough and in-development you'll see the dungeon get drawn as you start and it will stay on screen
'as long as you wish, press the spacebar to start playing
' use the numberpad or WASD to navigate <esc> to quit
'$dynamic
Screen _NewImage(800, 500, 32)
_Title "DeathTestDungeon v0.3"
_Define K As _UNSIGNED LONG
Dim Shared dmap As _Unsigned Long
Dim Shared ms As _Unsigned Long
Dim Shared Kblack, Kwhite, Kdgrey, Klgrey, kredm, kwater, kslime, klava, krubble, kcrystal, kexit, kfungus
Dim Shared kfloor2, kfloor3, kfloor4, cornerrubblechance
Dim Shared tiles&
Dim Shared rect_count As Integer
Type rect_type
xx As Integer
yy As Integer
ww As Integer
hh As Integer
lk As _Unsigned Long
fk As _Unsigned Long
notes As String
End Type
Dim Shared tilespot(0 To 528, 2) As Integer
Dim Shared rect(0) As rect_type
Dim Shared min_rectd
Dim Shared fillcell, openwallchance, pillarchance, puddleno, slimechance, lavachance
Dim Shared phealth, pstamina, pwounds, ptemp, ppx, ppy, lastx, lasty
Randomize Timer
Kblack = _RGB32(0, 0, 0) 'this is visible black as 0,0,0 will be "nothing is here" eventually
Kwhite = _RGB32(250, 250, 250) 'this is cooled paper white
Kdgrey = _RGB32(40, 40, 40)
Klgrey = _RGB32(150, 150, 150)
kfloor2 = _RGB32(151, 151, 151): kfloor3 = _RGB32(152, 152, 152): kfloor4 = _RGB32(153, 153, 153)
kred = _RGB32(250, 0, 0)
kwater = _RGB32(10, 30, 240): kslime = _RGB32(20, 240, 100): klava = _RGB32(200, 5, 5)
krubble = _RGB32(80, 80, 80): kcrystal = _RGB32(250, 250, 0): kexit = _RGB32(255, 0, 255)
kfungus = _RGB32(200, 50, 150)
dmap = _NewImage(800, 500, 32)
ms = _NewImage(800, 500, 32)
tiles& = Loadtileset1& 'loads the tileset in the file DTDtiles.bi
Const tilemaxx = 48
Const tilemaxy = 11
t = 0
For y = 0 To tilemaxy - 1
For x = 0 To tilemaxx - 1
tilespot(t, 1) = x * 16
tilespot(t, 2) = y * 16
t = t + 1
Next x
Next y
maxtiles = t - 1
fh = _FontHeight
fw = _FontWidth
Do
'Cls
For r = 1 To rect_count
bisectrect r
Next r
For r = 1 To rect_count
drawrect r
Next r
_Limit 5
kk$ = InKey$
n = n + Int(1 + Rnd * 8)
Loop Until kk$ <> "" Or n > 40
kk$ = Chr$(27)
Loop Until kk$ = Chr$(27)
For r = 1 To rect_count
If Int(1 + Rnd * 100) < fillcell Then rect(r).fk = Kdgrey
drawrect r
Next r
For r = 1 To rect_count 'if there's an open space across a wall open a space in the wall
If rect(r).fk <> Kdgrey Then
mx = rect(r).xx + Int(rect(r).ww / 2)
my = rect(r).yy + Int(rect(r).hh / 2)
If Point(mx, my + Int(rect(r).hh / 2) + 2) = Klgrey Then
Line (mx, my)-(mx, my + Int(rect(r).hh / 2) + 2), Klgrey
End If
If Point(mx, my - Int(rect(r).hh / 2) - 2) = Klgrey Then
Line (mx, my)-(mx, my - Int(rect(r).hh / 2) - 2), Klgrey
End If
If Point(mx - Int(rect(r).ww / 2) - 2, my) = Klgrey Then
Line (mx - Int(rect(r).ww / 2) - 2, my)-(mx, my), Klgrey
End If
If Point(mx + Int(rect(r).ww / 2) + 2, my) = Klgrey Then
Line (mx + Int(rect(r).ww / 2) + 2, my)-(mx, my), Klgrey
End If
End If
Next r
For y = 11 To rht - 1
For x = 11 To rwid - 2
If Point(x, y) = Klgrey And Point(x + 1, y) = Kdgrey And Point(x + 2, y) = Klgrey Then
PSet (x + 1, y), kred
End If
If Point(x, y) = Klgrey And Point(x + 1, y) = kred And Point(x + 2, y) = Kdgrey And Point(x + 3, y) = Klgrey Then
PSet (x + 2, y), kred
End If
If Point(x, y) = kdrgey And Point(x + 1, y) = Klgrey And Point(x + 2, y) = Kdgrey And Point(x + 3, y) = Kdgrey And Point(x + 4, y) = Klgrey And Point(x + 5, y) = Kdgrey Then
PSet (x + 2, y), Klgrey
PSet (x + 3, y), Klgrey
End If
Next x
Next y
For x = 11 To rwid - 2
For y = 11 To rht - 2
If Point(x, y) = Klgrey And Point(x, y + 1) = Kdgrey And Point(x, y + 2) = Klgrey Then
PSet (x, y + 1), kred
End If
If Point(x, y) = Klgrey And Point(x, y + 1) = kred And Point(x, y + 2) = Kdgrey And Point(x, y + 3) = Klgrey Then
PSet (x, y + 2), kred
End If
If Point(x, y) = kdrgey And Point(x, y + 1) = Klgrey And Point(x, y + 2) = Kdgrey And Point(x, y + 3) = Kdgrey And Point(x, y + 4) = Klgrey And Point(x, y + 5) = Kdgrey Then
PSet (x, y + 2), Klgrey
PSet (x, y + 3), Klgrey
End If
Next
Next
aa$ = Input$(1)
For y = 10 To rht
For x = 10 To rwid
If Point(x, y) = kred Then PSet (x, y), Klgrey
Next
Next
Color Kblack, Kwhite
'check to open walls
For r = 1 To rect_count
If rect(r).fk <> Kdgrey And Int(1 + Rnd * 100) <= openwallchance Then
Select Case Int(1 + Rnd * 4)
Case 1
rect(r).xx = rect(r).xx - 2
rect(r).ww = rect(r).ww + 2
Case 2
rect(r).xx = rect(r).xx + 2
rect(r).ww = rect(r).ww + 2
Case 3
rect(r).yy = rect(r).yy - 2
rect(r).hh = rect(r).hh + 2
Case 4
rect(r).yy = rect(r).yy + 2
rect(r).hh = rect(r).hh + 2
End Select
Line (rect(r).xx, rect(r).yy)-(rect(r).xx + rect(r).ww, rect(r).yy + rect(r).hh), Klgrey, BF
End If
Next r
'straysspaces
sp = Int(Rnd * 12)
For ss = 1 To sp
sx = Int(10 + Rnd * rwid - 30)
sy = Int(10 + Rnd * rht - 30)
sw = 10 + Int(Rnd * 20)
sh = 10 + Int(Rnd * 20)
Line (sx, sy)-(sx + sw, sy + sh), Klgrey, BF
Next
'add wormtunnels
nwt = Int(Rnd * (12 + fillcell))
For ww = 1 To nwt
wsx = Int(20 + Rnd * rwid - 50)
wsy = Int(20 + Rnd * rht - 50)
wtx = Int(20 + Rnd * rwid - 50)
wty = Int(20 + Rnd * rht - 50)
If wsx < wtx Then xtrend = 1
If wsx > wtx Then xtrend = -1
If wsy < wty Then ytrend = 1
If wsy > wty Then ytrend = -1
sx = wsx
sy = wsy
rl = 0
Do
nx = sx + Int(xtrend + Rnd * 2 - Rnd * 2)
ny = sy + Int(ytrend + Rnd * 2 - Rnd * 2)
If nx < 11 Then
nx = 11
xtrend = xtrend * -1
End If
If ny < 11 Then
ny = 11
ytrend = ytrend * -1
End If
If nx > rwid Then
nx = rwid
xtrend = xtrend * -1
End If
If ny > rht Then
ny = rht
ytrend = ytrend * -1
End If
dx = Abs(nx - wtx)
dy = Abs(ny - wty)
Line (sx, sy)-(nx, ny), Klgrey
sx = nx
sy = ny
rl = rl + 1
Loop Until dx < 5 And dy < 5 Or rl > rwid + 40
Line (sx, sy)-(wtx, wty), Klgrey
Next ww
For r = 1 To rect_count 'add pillars
pillarspread = 2 + Int(Rnd * 7)
If rect(r).fk <> Kdgrey And Int(1 + Rnd * 100) <= pillarchance Then
For y = rect(r).yy + pillarspread To rect(r).yy + rect(r).hh - pillarspread Step pillarspread
For x = rect(r).xx + pillarspread To rect(r).xx + rect(r).ww - pillarspread Step pillarspread
PSet (x, y), Kdgrey
Next
Next
End If
Next
For pr = 1 To rect_count
If rect(pr).fk <> Kdgrey And Int(1 + Rnd * 100) <= cornerrubblechance Then
addcornerrubble pr
End If
If rect(pr).fk <> Kdgrey And Int(1 + Rnd * 100) <= puddleno Then
addwater pr, Int(rect(pr).xx + 1 + Rnd * (rect(pr).ww - 2)), Int(rect(pr).yy + 1 + Rnd * (rect(pr).hh - 2)), Int(1 + Rnd * 3)
End If
If rect(pr).fk <> Kdgrey And Int(1 + Rnd * 100) <= slimechance Then
addslime pr, Int(rect(pr).xx + 1 + Rnd * (rect(pr).ww - 2)), Int(rect(pr).yy + 1 + Rnd * (rect(pr).hh - 2)), Int(1 + Rnd * 3)
End If
If rect(pr).fk <> Kdgrey And Int(1 + Rnd * 100) <= lavachance Then
addlava pr, Int(rect(pr).xx + 1 + Rnd * (rect(pr).ww - 2)), Int(rect(pr).yy + 1 + Rnd * (rect(pr).hh - 2)), Int(1 + Rnd * 3)
End If
If rect(pr).fk <> Kdgrey And Int(1 + Rnd * 100) <= funguschance Then
addfungus pr, Int(rect(pr).xx + 1 + Rnd * (rect(pr).ww - 2)), Int(rect(pr).yy + 1 + Rnd * (rect(pr).hh - 2)), Int(1 + Rnd * 3)
End If
Next pr
'dress floor to make it more interesting
For y = 1 To rht
For x = 1 To rwid
If Point(x, y) = Klgrey Then
Select Case Int(1 + Rnd * 100)
Case 1, 2
PSet (x, y), kfloor2
Case 3
PSet (x, y), kfloor3
Case 4
PSet (x, y), kfloor4
End Select
If Point(x, y) = Kdgrey Then 'convert some wall near lava inot rubble
If Point(x - 1, y) = klava And Int(1 + Rnd * 100) < 30 Then PSet (x, y), krubble
If Point(x + 1, y) = klava And Int(1 + Rnd * 100) < 30 Then PSet (x, y), krubble
If Point(x, y + 1) = klava And Int(1 + Rnd * 100) < 30 Then PSet (x, y), krubble
If Point(x, y - 1) = klava And Int(1 + Rnd * 100) < 30 Then PSet (x, y), krubble
If Point(x - 2, y) = klava And Int(1 + Rnd * 100) < 10 Then PSet (x, y), krubble
If Point(x + 2, y) = klava And Int(1 + Rnd * 100) < 10 Then PSet (x, y), krubble
If Point(x, y + 2) = klava And Int(1 + Rnd * 100) < 10 Then PSet (x, y), krubble
If Point(x, y - 2) = klava And Int(1 + Rnd * 100) < 10 Then PSet (x, y), krubble
End If
End If
Next
Next
For e = 0 To 9 'clean edge
Line (e, e)-(_Width - e, e), Kdgrey: Line (e, e)-(e, _Height - e), Kdgrey: Line (_Width - e, e)-(_Width - e, _Height - e), Kdgrey
Next e
Screen ms
_Source dmap
pick = 0
Do
pick = pick + 1
ppx = rect(pick).xx + Int(rect(pick).ww / 2): ppy = rect(pick).yy + Int(rect(pick).hh / 2)
kk = Point(ppx, ppy)
Loop Until kk <> Kdgrey
Do
If rec_count > 12 Then
exitspot = Int(6 + Rnd * (rect_count - 7))
Else
exitspot = Int(1 + Rnd * rect_count)
End If
exitX = rect(exitspot).xx + Int(rect(exitspot).ww / 2)
exitY = rect(exitspot).yy + Int(rect(exitspot).hh / 2)
startX = Abs(exitX - ppx)
startY = Abs(exitY - ppy)
start_dx = Sqr(startX * startX + startY * startY)
Loop Until Point(exitX, exitY) <> Kdgrey And exitspot <> pick
_Dest dmap
PSet (exitX, exitY), kexit
_Dest ms
_PrintMode _KeepBackground
View Print 25 To 30
Cls
Do
'draw location
rsqrd = lightradius * lightradius
y = -lightradius
While y <= lightradius
x = Int(Sqr(rsqrd - y * y))
For x2 = ppx - x To ppx + x
vx = x2 - ppx + 12
kk = Point(x2, ppy + y)
Line (vx * 16, (y + 12) * 16)-(vx * 16 + 15, (y + 12) * 16 + 15), kk, BF
If kk = Kdgrey Then
coltileat walltile, _RGB32(100, 100, 100), vx * 16, (y + 12) * 16
End If
If kk = kfloor2 Then
coltileat 2, _RGB32(160, 160, 160), vx * 16, (y + 12) * 16
End If
If kk = kfloor3 Then
coltileat 3, _RGB32(165, 165, 170), vx * 16, (y + 12) * 16
End If
If kk = kfloor4 Then
coltileat 4, _RGB32(175, 165, 165), vx * 16, (y + 12) * 16
End If
If kk = kexit Then
coltileat 24, _RGB32(250, 40, 255), vx * 16, (y + 12) * 16
End If
If kk = kfungus Then
Color _RGB32(250, 100, 200)
' _PrintString (vx * 16, (y + 12) * 16), Chr$(234)
coltileat 57, _RGB32(250, 100, 200), vx * 16, (y + 12) * 16
Color _RGB32(255, 255, 255)
End If
If kk = kcrystal Then
'_PrintString (vx * 16, (y + 12) * 16), Chr$(127)
coltileat 433, _RGB32(10, 0, 10), vx * 16, (y + 12) * 16
End If
If kk = krubble Then
Color _RGB32(150, 150, 150)
'_PrintString (vx * 16, (y + 12) * 16), Chr$(177)
coltileat 61, _RGB32(220, 200, 180), vx * 16, (y + 12) * 16
Color _RGB32(255, 255, 255)
End If
If kk = kslime Then
Color _RGB32(250, 250, 150)
sb = Int(Rnd * 4)
'If sb = 1 Then _PrintString (vx * 16, (y + 12) * 16), Chr$(247)
If sb = 1 Then coltileat 61, _RGB32(250, 250, 150), vx * 16, (y + 12) * 16
' If sb = 2 Then _PrintString (vx * 16, (y + 12) * 16), Chr$(126)
If sb = 2 Then coltileat 61, _RGB32(150, 250, 150), vx * 16, (y + 12) * 16
Color _RGB32(255, 255, 255)
End If
If kk = klava Then
Color _RGB32(250, 250, 150)
lb = Int(Rnd * 7)
'If lb = 1 Then _PrintString (vx * 16, (y + 12) * 16), Chr$(249)
If lb = 1 Then coltileat 61, _RGB32(250, 250, 150), vx * 16, (y + 12) * 16
'If lb = 2 Then _PrintString (vx * 16, (y + 12) * 16), Chr$(9)
If lb = 2 Then coltileat 468, _RGB32(250, 250, 150), vx * 16, (y + 12) * 16
'If lb = 3 Then _PrintString (vx * 16, (y + 12) * 16), Chr$(176)
If lb = 3 Then coltileat 461, _RGB32(250, 250, 150), vx * 16, (y + 12) * 16
'If lb = 4 Then _PrintString (vx * 16, (y + 12) * 16), Chr$(248)
If lb = 4 Then coltileat 61, _RGB32(250, 0, 0), vx * 16, (y + 12) * 16
'If lb = 5 Then _PrintString (vx * 16, (y + 12) * 16), Chr$(46)
If lb = 5 Then coltileat 468, _RGB32(250, 100, 0), vx * 16, (y + 12) * 16
Color _RGB32(255, 255, 255)
End If
If kk = kwater Then
Color _RGB32(40, 120, 250)
wb = Int(Rnd * 6)
'If wb = 1 Then _PrintString (vx * 16, (y + 12) * 16), Chr$(45)
If wb = 1 Then coltileat 136, _RGB32(40, 120, 250), vx * 16, (y + 12) * 16
If wb = 2 Then coltileat 136, _RGB32(40, 120, 250), vx * 16, (y + 12) * 16
If wb = 3 Then _PrintString (vx * 16 + 4, (y + 12) * 16), Chr$(240)
Color _RGB32(255, 255, 255)
End If
Next
y = y + 1
Wend
Line (598, 18)-(795, 124), Kdgrey, BF
'_PrintString ((12) * 8, (12) * 16), "@"
If ptemp > 199 Then coltileat 470, _RGB32(40, 0, 0), (12) * 16, (12) * 16
coltileat 304, _RGB32(250, 250, 250), (12) * 16, (12) * 16
o$ = "Stamina " + Str$(pstamina)
_PrintString (600, 20), o$
o$ = "Health " + Str$(phealth)
_PrintString (600, 40), o$
o$ = "Wounds " + Str$(pwounds)
_PrintString (600, 60), o$
o$ = "Temperature " + Str$(ptemp)
_PrintString (600, 80), o$
edd = Int(Sqr((ppx - exitX) * (ppx - exitX) + (ppy - exitY) * (ppy - exitY)))
o$ = "Distance to Exit " + Str$(edd)
_PrintString (600, 100), o$
Print "Turn", turn
Do
_Limit 60
kk$ = InKey$
Loop Until kk$ <> ""
turn = turn + 1
lastx = ppx
lasty = ppy
Select Case kk$
Case "w", "8"
If pstamina > 0 And Point(ppx, ppy - 1) <> Kdgrey Then ppy = ppy - 1
Case "s", "2"
If pstamina > 0 And Point(ppx, ppy + 1) <> Kdgrey Then ppy = ppy + 1
Case "a", "4"
If pstamina > 0 And Point(ppx - 1, ppy) <> Kdgrey Then ppx = ppx - 1
Case "d", "6"
If pstamina > 0 And Point(ppx + 1, ppy) <> Kdgrey Then ppx = ppx + 1
Case "7"
If pstamina > 0 And Point(ppx - 1, ppy - 1) <> Kdgrey Then
ppy = ppy - 1
ppx = ppx - 1
End If
Case "9"
If pstamina > 0 And Point(ppx + 1, ppy - 1) <> Kdgrey Then
ppy = ppy - 1
ppx = ppx + 1
End If
Case "1"
If pstamina > 0 And Point(ppx - 1, ppy + 1) <> Kdgrey Then
ppy = ppy + 1
ppx = ppx - 1
End If
Case "3"
If pstamina > 0 And Point(ppx + 1, ppy + 1) <> Kdgrey Then
ppy = ppy + 1
ppx = ppx + 1
End If
Case "5", "."
If Int(1 + Rnd * 50) < phealth And pstamina < 100 Then pstamina = pstamina + Int(1.5 + Rnd * (phealth / 25))
End Select
If Point(ppx, ppy) = krubble Then pwounds = pwounds + checkrubble(ppx, ppy)
If Point(ppx, ppy) = kcrystal Then pwounds = pwounds + checkcrystal(ppx, ppy)
If Int(1 + Rnd * 80 + pwounds) > phealth Then pstamina = pstamina - 1
If Point(ppx, ppy) = kslime Then
Print "The slime is nauseating...";
If Int(Rnd * 120) > phealth Then phealth = phealth - Int(Rnd * 4)
If Int(Rnd * 120) > phealth Then
Select Case Int(1 + Rnd * 6)
Case 1, 2, 3
Print " it's making you itch."
Case 4, 5, 6
Print " it's feel's like it is burning you."
wounds = wounds + Abs(Int(Rnd * 2 - Rnd * 2))
End Select
End If
End If
If Point(ppx, ppy) = kwater Then ptemp = ptemp - Int(Abs(Rnd * 2 - Rnd * 2))
If Point(ppx, ppy) = klava Then
ptemp = ptemp + 100
dmg = 10 + Int(Rnd * 20)
pwounds = pwounds + dmg
Print "YOU ARE STANDING IN LAVA !!!"
Print "....suffering "; dmg; " points of damage !"
End If
If ptemp < 0 Then
Print "You are dangerously COLD .... brrrrr"
pstamina = pstamina - Int(Rnd * 2)
If Int(1 + Rnd * (50 + Abs(ptemp))) > pstamina Then
pwounds = pwounds + Int(1 + Rnd * 2)
phealth = phealth - Int(Rnd * 2)
End If
End If
tcheck = ptemp + Rnd * 10
If tcheck > 108 Then
pstamina = pstamina - 1
Print "You are dangerously warm!"
If Int(1 + Rnd * ptemp) > pstamina Then
pwounds = pwounds + 1
phealth = phealth - Int(Rnd * 2)
End If
End If
'If Point(ppx, ppy) = (kfloor2 Or kfloor3 or kfloor4 or klgrey) Then
If ptemp < 98 Then ptemp = ptemp + 1
If ptemp > 98 Then ptemp = Int((ptemp + 98) / 2)
' End If
If pstamina < 20 Then
Print "You are ";
If pstamina < 1 Then
Print "exhausted."
Else
Print "fatigued."
End If
End If
If wounds > phealth Then
Print "You are in intense pain !"
pstamina = pstamina = Int(Rnd * 2)
End If
If Point(ppx, ppy) = kexit Then
Print
Print "YOU HAVE FOUND THE EXIT"
Print
Print "it took you "; turn; " turns after starting "; start_dx; " spaces away from the exit."
Print
kk$ = Chr$(27)
End If
If phealth < 1 Or pwounds > 99 Then
Print "YOU HAVE PERISHED DUE TO YOUR POOR CONDITION."
Print
Print "(press any key to continue)"
any$ = Input$(1)
kk$ = Chr$(27)
End If
Loop Until kk$ = Chr$(27)
Print "GAME OVER"
Print "play again?"
Print "Y or N?"
Do
ask$ = Input$(1)
ask$ = UCase$(ask$)
Loop Until ask$ = "Y" Or ask$ = "N"
If ask$ = "Y" Then
Screen cmap
GoTo restartdungeon
End If
System
'SUBS======================================================================
'$INCLUDE: 'DTDtiles.bi'
'==========================================================================
Sub bisectrect (r)
If r > 0 Or r < rect_count + 1 Then
Select Case Int(1 + Rnd * 6)
Case 1, 2, 3 'vertical split
tries = 0
Do
tries = tries + 1
vpercent = (Int(1 + Rnd * 4) + Int(1 + Rnd * 4)) * .1
Loop Until vpercent * rect(r).ww >= min_rectd And vpercent * rect(r).hh >= min_rectd Or tries > 7
If tries < 8 Then
oldWW = Int(rect(r).ww * vpercent)
newX = rect(r).xx + oldWW
newWW = rect(r).ww - oldWW
If oldWW >= min_rectd And newWW >= min_rectd Then
rect(r).ww = oldWW
newrect newX, rect(r).yy, newWW, rect(r).hh, rect(r).lk, rect(r).fk
End If
End If
Case 4, 5, 6 'horizontal split
tries = 0
Do
tries = tries + 1
vpercent = (Int(1 + Rnd * 4) + Int(1 + Rnd * 4)) * .1
Loop Until vpercent * rect(r).ww >= min_rectd And vpercent * rect(r).hh >= min_rectd Or tries > 7
If tries < 8 Then
oldHH = Int(rect(r).hh * vpercent)
newYY = (rect(r).yy + oldHH)
newHH = rect(r).hh - oldHH
If oldHH >= min_rectd And newHH >= min_rectd Then
rect(r).hh = oldHH
newrect rect(r).xx, newYY, rect(r).ww, newHH, rect(r).lk, rect(r).fk
End If
End If
End Select
End If
End Sub
Sub wrect (rx, ry, ww, hh, line_klr As _Unsigned Long, fill_klr As _Unsigned Long)
If fill_klr > 0 Then Line (rx, ry)-(rx + ww - 1, ry + hh - 1), fill_klr, BF
If line_klr > 0 Then Line (rx, ry)-(rx + ww - 1, ry + hh - 1), line_klr, B
End Sub
Sub drawrect (r)
wrect rect(r).xx, rect(r).yy, rect(r).ww, rect(r).hh, rect(r).lk, rect(r).fk
End Sub
Sub newrect (XX, YY, WW, HH, klk, kfl)
rect_count = rect_count + 1
ReDim _Preserve rect(rect_count) As rect_type
rect(rect_count).xx = XX
rect(rect_count).yy = YY
rect(rect_count).ww = WW
rect(rect_count).hh = HH
rect(rect_count).lk = klk
rect(rect_count).fk = kfl
rect(rect_count).notes = "newrect"
End Sub
Sub addwater (rno, pcx, pcy, scale)
prr = Int(6 + Rnd * (12 * scale))
preps = (3 + Int(Rnd * prr))
For wr = 1 To preps
pcxx = pcx + Int(Rnd * (prr / 2)) - Int(Rnd * (prr / 2))
pcyy = pcy + Int(Rnd * (prr / 2)) - Int(Rnd * (prr / 2))
rsqrd = prr * prr
y = -prr
While y <= prr
x = Int(Sqr(rsqrd - y * y))
For x2 = pcxx - x To pcxx + x
If x2 >= rect(rno).xx And x2 <= rect(rno).xx + rect(rno).ww Then
If pcyy + y >= rect(rno).yy And pcyy + y <= rect(rno).yy + rect(rno).hh Then
kk = Point(x2, pcyy + y)
If kk = Klgrey Then
PSet (x2, pcyy + y), kwater
End If
End If
End If
Next
y = y + 1
Wend
prr = Int((prr + Int(6 + Rnd * (12 * scale))) / 2)
Next
End Sub
Sub addslime (rno, pcx, pcy, scale)
prr = Int(5 + Rnd * (10 * scale))
preps = (3 + Int(Rnd * prr))
For wr = 1 To preps
pcxx = pcx + Int(Rnd * (prr / 2)) - Int(Rnd * (prr / 2))
pcyy = pcy + Int(Rnd * (prr / 2)) - Int(Rnd * (prr / 2))
rsqrd = prr * prr
y = -prr
While y <= prr
x = Int(Sqr(rsqrd - y * y))
For x2 = pcxx - x To pcxx + x
If x2 >= rect(rno).xx And x2 <= rect(rno).xx + rect(rno).ww Then
If pcyy + y >= rect(rno).yy And pcyy + y <= rect(rno).yy + rect(rno).hh Then
kk = Point(x2, pcyy + y)
If kk = Klgrey Or kk = kwater Then
PSet (x2, pcyy + y), kslime
End If
End If
End If
Next
y = y + 1
Wend
prr = Int((prr + Int(6 + Rnd * (12 * scale))) / 2)
Next
End Sub
Sub addlava (rno, pcx, pcy, scale)
prr = Int(5 + Rnd * (10 * scale))
preps = (3 + Int(Rnd * prr))
For wr = 1 To preps
pcxx = pcx + Int(Rnd * (prr / 2)) - Int(Rnd * (prr / 2))
pcyy = pcy + Int(Rnd * (prr / 2)) - Int(Rnd * (prr / 2))
rsqrd = prr * prr
y = -prr
While y <= prr
x = Int(Sqr(rsqrd - y * y))
For x2 = pcxx - x To pcxx + x
If x2 >= rect(rno).xx And x2 <= rect(rno).xx + rect(rno).ww Then
If pcyy + y >= rect(rno).yy And pcyy + y <= rect(rno).yy + rect(rno).hh Then
kk = Point(x2, pcyy + y)
If kk = Klgrey Or kk = kwater Or kk = kslime Then
If kk = kwater Then
If Abs(y) < prr / 2 Then
PSet (x2, pcyy + y), klava
Else
Select Case Int(1 + Rnd * 12)
Case 1, 2, 3, 4, 5
PSet (x2, pcyy + y), klava
Case 6, 7, 8
PSet (x2, pcyy + y), krubble
Case 9, 10
PSet (x2, pcyy + y), Klgrey
Case 11
PSet (x2, pcyy + y), Kdgrey
Case 12
PSet (x2, pcyy + y), kcrystal
End Select
End If
Else
PSet (x2, pcyy + y), klava
End If
End If
End If
End If
Next
y = y + 1
Wend
prr = Int((prr + Int(6 + Rnd * (12 * scale))) / 2)
Next
End Sub
Sub addfungus (rno, pcx, pcy, scale)
prr = Int(2 + Rnd * (2 * scale))
preps = (3 + Int(Rnd * prr))
For wr = 1 To preps
pcxx = pcx + Int(Rnd * (prr / 2)) - Int(Rnd * (prr / 2))
pcyy = pcy + Int(Rnd * (prr / 2)) - Int(Rnd * (prr / 2))
rsqrd = prr * prr
y = -prr
While y <= prr
x = Int(Sqr(rsqrd - y * y))
For x2 = pcxx - x To pcxx + x
If x2 >= rect(rno).xx And x2 <= rect(rno).xx + rect(rno).ww Then
If pcyy + y >= rect(rno).yy And pcyy + y <= rect(rno).yy + rect(rno).hh Then
kk = Point(x2, pcyy + y)
If kk = Klgrey Or kk = kwater Then
If Int(1 + Rnd * 100) <= 30 Then PSet (x2, pcyy + y), kfungus
End If
End If
End If
Next
y = y + 1
Wend
prr = Int((prr + Int(6 + Rnd * (12 * scale))) / 2)
Next
End Sub
Function checkrubble (xx, yy)
stumblecheck = Int(1 + Rnd * 120)
dmg = 0
If stumblecheck > health Then
Print "whooops.... you stumbled on the rubble...";
Select Case Int(1 + Rnd * 20)
Case 1
If Point(ppx - 1, ppy - 1) <> Kdgrey Then
ppx = ppx - 1: ppy = ppy - 1
End If
Case 2
If Point(ppx, ppy - 1) <> Kdgrey Then
ppy = ppy - 1
End If
Case 3
If Point(ppx + 1, ppy + 1) <> Kdgrey Then
ppx = ppx + 1: ppy = ppy + 1
End If
Case 4
If Point(ppx - 1, ppy) <> Kdgrey Then
ppx = ppx - 1
End If
Case 6
If Point(ppx + 1, ppy) <> Kdgrey Then
ppx = ppx + 1
End If
Case 7
If Point(ppx - 1, ppy + 1) <> Kdgrey Then
ppx = ppx - 1: ppy = ppy + 1
End If
Case 8
If Point(ppx, ppy + 1) <> Kdgrey Then
ppy = ppy + 1
End If
Case 9
If Point(ppx + 1, ppy + 1) <> Kdgrey Then
ppy = ppy + 1: ppx = ppx + 1
End If
Case 10, 11, 12, 13, 14
Print " knocking the wind out of you... ";
pstamina = Int(pstamina / 4)
Case 15, 16, 17, 18, 19, 20
ppx = lastx: ppy = lasty
Print "you tumble back...";
End Select
dmg = Abs(Int((Rnd * 3) - (Rnd * 3)))
If dmg > 0 Then
Print "you suffer "; dmg; " points of damage!"
Else
Print "."
End If
End If
checkrubble = dmg
End Function
Sub addcornerrubble (rno)
numcorn = Int(1 + Rnd * 4)
For crr = 1 To numcorn
Select Case Int(Rnd * 5)
Case 1
crx = rect(rno).xx + 1
cry = rect(rno).yy + 1
Case 2
crx = rect(rno).xx + 1
cry = rect(rno).yy + rect(rno).hh - 2
Case 3
crx = rect(rno).xx + rect(rno).ww - 2
cry = rect(rno).yy + 1
Case 4
crx = rect(rno).xx + rect(rno).ww - 2
cry = rect(rno).yy + rect(rno).hh - 2
End Select
prr = Int((rect(rno).hh + rect(rno).ww) / 12)
rsqrd = prr * prr
y = -prr
While y <= prr
x = Int(Sqr(rsqrd - y * y))
For x2 = crx - x To crx + x
If x2 >= rect(rno).xx And x2 <= rect(rno).xx + rect(rno).ww Then
If cry + y >= rect(rno).yy And cry + y <= rect(rno).yy + rect(rno).hh Then
kk = Point(x2, cry + y)
If kk = Klgrey And Int(1 + Rnd * 100) < (cornerrubblechance * 2.5) Then
PSet (x2, cry + y), krubble
End If
End If
End If
Next
y = y + 1
Wend
Next crr
End Sub
Function checkcrystal (xx, yy)
climbcheck = Int(1 + Rnd * 100)
If climbcheck > phealth Then
Print "You just can't gain any purchase to climb the crystal."
Else
stumblecheck = Int(1 + Rnd * 120)
dmg = 0
If stumblecheck > health Then
Print ".... you fell from the crytsal...";
Select Case Int(1 + Rnd * 9)
Case 1
If Point(ppx - 1, ppy - 1) <> Kdgrey Then
ppx = ppx - 1: ppy = ppy - 1
End If
Case 2
If Point(ppx, ppy - 1) <> Kdgrey Then
ppy = ppy - 1
End If
Case 3
If Point(ppx + 1, ppy + 1) <> Kdgrey Then
ppx = ppx + 1: ppy = ppy + 1
End If
Case 4
If Point(ppx - 1, ppy) <> Kdgrey Then
ppx = ppx - 1
End If
Case 5
ppx = lastx: ppy = lasty
Case 6
If Point(ppx + 1, ppy) <> Kdgrey Then
ppx = ppx + 1
End If
Case 7
If Point(ppx - 1, ppy + 1) <> Kdgrey Then
ppx = ppx - 1: ppy = ppy + 1
End If
Case 8
If Point(ppx, ppy + 1) <> Kdgrey Then
ppy = ppy + 1
End If
Case 9
If Point(ppx + 1, ppy + 1) <> Kdgrey Then
ppy = ppy + 1: ppx = ppx + 1
End If
End Select
dmg = Abs(Int((Rnd * 4) - (Rnd * 4)))
If dmg > 0 Then
Print "you suffer "; dmg; " points of damage!"
Else
Print "."
End If
End If
End If
checkcrystal = dmg
End Function
Sub coltileat (tn, ktc, xx, yy)
Dim kc As _Unsigned Long
_Source tiles&
_Dest ms
tx = tilespot(tn, 1): ty = tilespot(tn, 2)
For px = 0 To 16
For py = 0 To 15
kc = Point(tx + px, ty + py)
If kc <> Kblack Then
PSet (xx + px, yy + py), ktc
End If
Next py
Next px
_Source dmap
End Sub
Function getwalltile
wt = Int(1 + Rnd * 8)
Select Case wt
Case 1, 2, 3
wt = 8
Case 4, 5
wt = 15
Case 6
wt = 14
Case 7
wt = 11
Case 8
wt = 12
End Select
getwalltile = wt
End Function
Here's the tile set and loading function "DTDtiles.bi"
I've been using Spiral Linux, this one that came about a few weeks ago, which is based on Debian but is a lot like Ubuntu. I chose Cinnamon desktop environment, which is a first for me, similar to MATE but it might be the same for a different "skin" such as GNOME or KDE. Many others based on Debian or Ubuntu should be alike. The "default" profile of the terminal is dark print on light background. If the user doesn't change it to "dark mode", some messages QB64PE compiler gives out might not be readable unless "-m" switch is used to suppress all coloring. What if the user doesn't like "dark mode" for the terminal?
I use "-x" switch a lot because I consider the QB64 "mainwin" bothersome only for compilation and there might be a need to pick up the compiler's error messages into a text file. I think there is an "error log" for this, the same one as for the C++ compilation errors.
Finally there's at least one person that forgets to use "-e", or desires to enable verbose for reasons they have to be asked for.
I suppose things could be run from "-s" switch but it's yet another thing to remember when running the compiler.
Therefore I propose an environment variable, or an INI file loaded only by the compiler, that reads switches to use already if not specified at the command line. Something like "options.bin" but only for the compiler mode of QB64PE executable.
One more thing: the "-m" switch is not listed in the "man" page "qb64pe.1".
