' This program exported from BASIC Anywhere Machine (Version [5.2.3].[2023.12.16.16.28]) on 2024.02.18 at 18:59 (Coordinated Universal Time)
' https://qb64phoenix.com/forum/showthread.php?tid=270&pid=23173#pid23173
_TITLE "VFG"
' Vince's Favorite Game
' A QBJS program by Vince, ported to BAM by Charlie Veniot
' 🟠🟠🟠🟠 DECLARATIONS
CONST KEY_UP = 38, KEY_LEFT = 37, KEY_RIGHT = 39, KEY_SPACE = 32, KEY_SHIFT = 16, KEY_P = 80, KEY_ENTER = 13
DIM piece( 17, 2, 4 ), piece_color( 17 )
GOSUB 🧩200_BuildPieces
DIM size = 15, sw = 12, sh = 25
DIM xx, yy '🔖 big x and y
DIM board( sw - 1, sh - 1 )
DECLARE FUNCTION place( pn, px, py, rot )
DECLARE FUNCTION valid( pn, px, py, rot )
DECLARE SUB rotate( x, y, pn, rot )
DEFDV title$ = "lines=" + LTRIM$( STR$( lines ) ) + ",speed=" + LTRIM$( STR$( speed ) )
DIM t, kt AS DOUBLE
redraw = 1
speed = 3
lines = 0
pause = FALSE
putpiece = FALSE
startx = ( sw - 4 ) / 2
pn = INT( RND * 18 )
px = startx
py = -2
rot = 0
' 🟠🟠🟠🟠 MAIN PROGRAM
SCREEN _NEWIMAGE( sw * size, sh * size + 34, 32 )
_INITAUDIO
t = TIMER : kt = TIMER
🏁🏁🏁LoopStart:
GOSUB ⏱100_TimerEval
IF putpiece THEN
IF valid( pn, px, py, rot ) THEN
n = place( pn, px, py, rot )
IF n THEN lines = lines + n
END IF
pn = INT( RND * 18 )
px = startx
py = -2
rot = 0
putpiece = FALSE
redraw = 1
IF NOT valid(pn, px, py, rot) THEN
FOR y = 0 TO sh - 1 : FOR x = 0 TO sw - 1
board(x, y) = 0
NEXT x : NEXT y
lines = 0
SOUND 200, 3
PRINT "Ouch !"
PRINT "Press the Enter key"
PRINT "(or click/touch the"
PRINT "screen) to start a"
PRINT "new game."
WHILE _MOUSEBUTTON : WEND
WHILE KEYSTATE() <> KEY_ENTER AND NOT _MOUSEBUTTON : WEND
WHILE _MOUSEBUTTON : WEND
END IF
END IF
IF redraw THEN GOSUB 🖥400_DoRedraw
IF TIMER - kt > 0.1275 THEN kt = TIMER : GOSUB 🔁300_HandleKeyPress
redraw = 1
GOTO 🏁🏁🏁LoopStart
' 🟠🟠🟠🟠 GOSUB ROUTINES
⏱100_TimerEval:
IF (TIMER - t) > (1/speed) AND NOT pause THEN
IF valid(pn, px, py + 1, rot) THEN py = py + 1 ELSE putpiece = TRUE
t = TIMER
redraw = 1
END IF
RETURN
🧩200_BuildPieces:
FOR p0% = 0 TO 17 : FOR p2% = 0 TO 4 : FOR p1% = 0 TO 2
READ d%
piece( p0%, p1%, p2% ) = d%
NEXT p2% : NEXT p1% : NEXT p0%
FOR p0% = 0 TO 17
READ r%, g%, b%
piece_color( p0% ) = _rgb( r%, g%, b% )
NEXT p0%
RETURN
🔁300_HandleKeyPress:
IF KEYSTATE( KEY_UP ) _
OR ( _MOUSEBUTTON AND BETWEEN( _MOUSEX, 2, 37 ) AND BETWEEN( _MOUSEY, YMAX - 32, YMAX ) ) THEN
IF valid( pn, px, py, ( rot + 1 ) MOD 4 ) THEN rot = ( rot + 1 ) MOD 4 : SOUND 50, 0.5
pause = FALSE
ELSEIF KEYSTATE( KEY_LEFT ) _
OR ( _MOUSEBUTTON AND BETWEEN( _MOUSEX, 96, 131 ) AND BETWEEN( _MOUSEY, YMAX - 32, YMAX ) ) THEN
IF valid( pn, px - 1, py, rot ) THEN px = px - 1
pause = FALSE
ELSEIF KEYSTATE( KEY_RIGHT ) _
OR ( _MOUSEBUTTON AND BETWEEN( _MOUSEX, 136, 171 ) AND BETWEEN( _MOUSEY, YMAX - 32, YMAX ) ) THEN
IF valid( pn, px + 1, py, rot ) THEN px = px + 1
pause = FALSE
ELSEIF KEYSTATE( KEY_SPACE ) _
OR ( _MOUSEBUTTON AND BETWEEN( _MOUSEX, 42, 77 ) AND BETWEEN( _MOUSEY, YMAX - 32, YMAX ) ) THEN
FOR y2 = py TO sh - 1
py = y2 - 1
IF NOT valid( pn, px, y2, rot ) THEN y2 = sh '🔖 exit for
NEXT
putpiece = TRUE
pause = FALSE
ELSEIF KEYSTATE( KEY_P ) _
OR ( _MOUSEBUTTON AND BETWEEN( _MOUSEX, 0, XMAX ) AND BETWEEN( _MOUSEY, 0, ( sh * size ) ) ) THEN
pause = TRUE
END IF
RETURN
🖥400_DoRedraw:
LINE ( 0, 0 ) - ( sw * size, sh * size ), _RGB( 0, 0, 0 ), BF
FOR y = 0 TO sh - 1 : FOR x = 0 TO sw - 1
IF board(x, y) <> 0 THEN
LINE ( x * size, y * size ) - STEP ( size - 2, size - 2 ), piece_color( board( x, y ) -1 ), BF
LINE ( x * size, y * size ) - STEP ( size - 2, size - 2 ), _RGB( 255,255,255 ), B
ELSE
line ( x * size, y * size ) - STEP ( size - 2, size - 2 ), _RGB( 100,100,100 ), b
END IF
NEXT x : NEXT y
FOR y = 0 TO 4 : FOR x = 0 TO 2
rotate ( x, y, pn, rot )
IF piece( pn, x, y ) THEN _
LINE ( ( px + xx ) * size, ( py + yy ) * size ) - STEP ( size - 2, size - 2 ), piece_color( pn ), BF : _
LINE ( ( px + xx ) * size, ( py + yy ) * size ) - STEP ( size - 2, size - 2 ), _RGB( 255, 255, 255 ), B
NEXT x : NEXT y
LOCATE INT(YMAX/16) , 3 : PRINT "U S L R";
xl% = 2 : LINE ( xl%, YMAX - 32 ) - (xl% + 35,YMAX), _RGB(255,255,255), B
xl% = 42: LINE ( xl%, YMAX - 32 ) - (xl% + 35,YMAX), _RGB(255,255,255), B
xl% = 96: LINE ( xl%, YMAX - 32 ) - (xl% + 35,YMAX), _RGB(255,255,255), B
xl% = 136: LINE ( xl%, YMAX - 32 ) - (xl% + 35,YMAX), _RGB(255,255,255), B
LOCATE 1, 1 : PRINT "lines=" + LTRIM$( STR$( lines ) ) + ",speed=" + LTRIM$( STR$( speed ) ) ' title$
_DISPLAY
redraw = 0
RETURN
' 🟠🟠🟠🟠 SUB AND FUNCTIONS
SUB rotate( x, y, pn, rot )
LET rot_new = IFF( pn = 0, rot mod 2 , rot )
SELECT CASE rot_new
CASE 0
xx = x : yy = y
CASE 1
IF pn = 0 OR pn = 14 OR pn = 15 THEN
xx = y - 1 : yy = 3 - x
ELSE
xx = y - 2 : yy = 4 - x
END IF
CASE 2
xx = 2 - x
yy = IFF( pn = 14 OR pn = 15, 4, 6 ) - y
CASE 3
IF pn = 14 OR pn = 15 THEN
xx = 3 - y : yy = x + 1
ELSE
xx = 4 - y : yy = x + 2
END IF
END SELECT
END SUB
FUNCTION valid( pn, px, py, rot )
FOR y = 0 TO 4
FOR x = 0 TO 2
rotate ( x, y, pn, rot )
IF py + yy >= 0 THEN
IF piece( pn, x, y ) THEN
IF ( px + xx >= sw ) OR ( px + xx < 0 ) _
OR ( py + yy >= sh ) OR board( px + xx, py + yy ) THEN
valid = FALSE
EXIT FUNCTION
END IF
END IF
END IF
NEXT x
NEXT y
valid = TRUE
END FUNCTION
FUNCTION place( pn, px, py, rot )
lines2 = 0
FOR y = 0 TO 4 : FOR x = 0 TO 2
CALL rotate( x, y, pn, rot )
IF py + yy >= 0 AND piece( pn, x, y ) THEN board( px + xx, py + yy ) = pn + 1
NEXT x : NEXT y
FOR y = py - 5 TO py + 5 '🔖 clear lines
IF y >= 0 AND y < sh THEN
clr = 1
FOR x = 0 TO sw - 1
IF board( x, y ) = 0 THEN
clr = 0 : x = sw '🔖 exit for
END IF
NEXT x
IF clr THEN
lines2 = lines2 + 1
FOR y2 = y TO 1 STEP - 1 : FOR x = 0 TO sw - 1
board( x, y2 ) = board( x, y2 - 1 )
NEXT x : NEXT y2
END IF
END IF
NEXT y
place = lines2
END FUNCTION
' 🟠🟠🟠🟠 DATA
PieceShapes:
DATA 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 1, 0
DATA 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 1, 1, 0
DATA 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 1, 0, 1, 1, 0, 0, 1, 0
DATA 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 1, 1, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 1, 1, 0, 1, 0, 0
DATA 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 1, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 1, 1, 0, 1, 0, 0, 1, 0
DATA 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 1, 1, 1
DATA 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 1, 1, 0, 1, 0
DATA 0, 0, 0, 0, 1, 0, 1, 1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1, 0
DATA 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 1, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 1, 0, 0, 1, 1
PieceColors:
DATA 255,0,0, 255,145,0
DATA 255,200,211, 0,255,220
DATA 0,230,255, 0,170,10
DATA 0,250,20, 128,230,0
DATA 80,150,0, 0,200,0
DATA 50,160,170, 50,110,175
DATA 50,50,175, 110,50,175
DATA 210,0,255, 110,0,130
DATA 255,0,140, 170,0,100