TETRIS GAMES PROGRAMMED IN VFP

*| Here is Alexey Pajitnov's Tetris programmed in VFP.
*| A sort of "Hello, World!" program, which should exist for every programming language.
*| No scores, no levels -- a pure Tetris.
*| Some 550 lines of code, may be too much; though it's squeezable.

PUBLIC ff
ff = CreateObject('frm')
ff.visible = .T.
RETURN


#DEFINE tetris          4
#DEFINE c0            128 && color constant
#DEFINE c1            196 && color constant
#DEFINE sqee_width     20
#DEFINE sqee_height    20
#DEFINE bucketWidth    12
#DEFINE bucketHeight   24
#DEFINE dropInterval  200 && millisecond
#DEFINE keyLeft        19
#DEFINE keyRight        4
#DEFINE keyDrop        32
#DEFINE keyRotate       5

DEFINE CLASS sqee As Shape
Owner  = 0 && (0)empty, (1)debris, all others - Figure.Mode
Width  = sqee_width
Height = sqee_height
BorderColor = RGB (240,240,255)
BackColor = RGB(255,255,255)
ENDDEFINE

DEFINE CLASS figure As Custom
DIMEN arrX [tetris]
DIMEN arrY [tetris]
dY = 1
dX = 1
mode = 0
main = .F.
BackColor = 0
turned_counter      = 0
turned_counter_dy   = 0
turned_counter_dx   = 0
turned_clockwise    = 0
turned_clockwise_dy = 0
turned_clockwise_dx = 0

PROCEDURE  init
THIS.BackColor = THIS.get_color()
THIS.after_init
ENDPROC

PROCEDURE  assign_neighbours (tl, tly, tlx,  tr, try, trx)
THIS.turned_counter      = tl
THIS.turned_counter_dy   = tly
THIS.turned_counter_dx   = tlx
THIS.turned_clockwise    = tr
THIS.turned_clockwise_dy = try
THIS.turned_clockwise_dx = trx
ENDPROC

PROCEDURE  init_arr (y1,x1, y2,x2, y3,x3, y4,x4)
THIS.arrX [1] = x1
THIS.arrX [2] = x2
THIS.arrX [3] = x3
THIS.arrX [4] = x4
THIS.arrY [1] = y1
THIS.arrY [2] = y2
THIS.arrY [3] = y3
THIS.arrY [4] = y4
ENDPROC

PROCEDURE  reset_figure
STORE 1 TO THIS.dY, THIS.dX
ENDPROC

FUNCTION  get_color ()
DO CASE
CASE INLIST (THIS.mode, 1,11)
RETURN RGB (c1,c0,c0)
CASE THIS.mode = 2
RETURN RGB (c1,c1,c0)
CASE INLIST (THIS.mode, 3,31,32,33)
RETURN RGB (c1,c0,c1)
CASE INLIST (THIS.mode, 4,41)
RETURN RGB (c0,c1,c1)
CASE INLIST (THIS.mode, 5,51)
RETURN RGB (c0,c1,c0)
CASE INLIST (THIS.mode, 6,61,62,63)
RETURN RGB (c0,c0,c1)
CASE INLIST (THIS.mode, 7,71,72,73)
RETURN RGB (c0,c0,c0)
OTHER
RETURN RGB (c1,c1,c1)
ENDCASE
ENDFUNC

PROCEDURE  set_state (numColor, numOwner)
LOCAL ii
FOR ii=1 TO tetris
WITH ThisForm.d.arr [ THIS.dY+THIS.arrY[ii], THIS.dX+THIS.arrX[ii] ]
.BackColor = numColor
.Owner = numOwner
ENDWITH
ENDFOR
ENDPROC

PROCEDURE  set_visible
THIS.set_state (THIS.BackColor, THIS.mode)
ENDPROC

PROCEDURE  set_free
THIS.set_state (THIS.Parent.BackColor, 0)
ENDPROC

PROCEDURE  set_debris
THIS.set_state (THIS.BackColor, -1)
ENDPROC

PROCEDURE  set_owner (numOwner)
LOCAL ii
FOR ii=1 TO tetris
WITH ThisForm.d.arr [ THIS.dY+THIS.arrY[ii], THIS.dX+THIS.arrX[ii] ]
.Owner = numOwner
ENDWITH
ENDFOR
ENDPROC

PROCEDURE  conflict (dY,dX, allowedMode)
LOCAL ii
FOR ii=1 TO tetris
IF Not (BETW(dY+THIS.dY+THIS.arrY[ii], 1, bucketHeight);
   And  BETW(dX+THIS.dX+THIS.arrX[ii], 1, bucketWidth))
RETURN .T.
ENDIF

WITH ThisForm.d.arr [ dY+THIS.dY+THIS.arrY[ii], dX+THIS.dX+THIS.arrX[ii] ]
IF Not (.Owner=0 Or .Owner=THIS.mode Or .Owner=allowedMode)
RETURN .T.
ENDIF
ENDWITH
ENDFOR
RETURN .F.
ENDPROC

FUNCTION  move_ (dY,dX)
IF THIS.Conflict (dY,dX,0)
RETURN .F.
ELSE
THIS.set_free
THIS.dY = THIS.dY + dY
THIS.dX = THIS.dX + dX
THIS.set_visible
RETURN .T.
ENDIF
ENDPROC

PROCEDURE  move_down
RETURN THIS.move_ (1,0)
ENDPROC

PROCEDURE  move_left
RETURN THIS.move_ (0,-1)
ENDPROC

PROCEDURE  move_right
RETURN THIS.move_ (0,1)
ENDPROC
ENDDEFINE

DEFINE CLASS f1 As figure && vertical stick
mode = 1
main = .T.
PROCEDURE  after_init
THIS.init_arr (0,0,  1,0,  2,0,  3,0)
THIS.assign_neighbours (11,2,-1,  11,2,-2)
ENDPROC
ENDDEFINE

DEFINE CLASS f11 As figure && horizontal stick
mode = 11
main = .F.
PROCEDURE  after_init
THIS.init_arr (0,0,  0,1,  0,2,  0,3)
THIS.assign_neighbours (1,-2,1,  1,-2,2)
ENDPROC
ENDDEFINE

DEFINE CLASS f2 As figure && square
mode = 2
main = .T.
PROCEDURE  after_init
THIS.init_arr (0,0,  0,1,  1,0,  1,1)
THIS.assign_neighbours (2,0,0,  2,0,0)
ENDPROC
ENDDEFINE

DEFINE CLASS f3 As figure && t-bone
mode = 3
main = .T.
PROCEDURE  after_init
THIS.init_arr (0,0,  0,1,  0,2,  1,1)
THIS.assign_neighbours (32,0,0,  31,0,0)
ENDPROC
ENDDEFINE

DEFINE CLASS f31 As figure && t-bone rotated
mode = 31
main = .F.
PROCEDURE  after_init
THIS.init_arr (0,0,  1,0,  2,0,  1,1)
THIS.assign_neighbours (3,0,0,  33,0,0)
ENDPROC
ENDDEFINE

DEFINE CLASS f32 As figure && t-bone rotated
mode = 32
main = .F.
PROCEDURE  after_init
THIS.init_arr (0,1,  1,1,  2,1,  1,0)
THIS.assign_neighbours (33,0,0,  3,0,0)
ENDPROC
ENDDEFINE

DEFINE CLASS f33 As figure && t-bone rotated
mode = 33
main = .F.
PROCEDURE  after_init
THIS.init_arr (1,0,  1,1,  1,2,  0,1)
THIS.assign_neighbours (31,0,0,  32,0,0)
ENDPROC
ENDDEFINE

DEFINE CLASS f4 As figure && zed1
mode = 4
main = .T.
PROCEDURE  after_init
THIS.init_arr (0,0,  0,1,  1,1,  1,2)
THIS.assign_neighbours (41,0,0,  41,0,0)
ENDPROC
ENDDEFINE

DEFINE CLASS f41 As figure && zed1 rotated
mode = 41
main = .F.
PROCEDURE  after_init
THIS.init_arr (2,0,  1,0,  1,1,  0,1)
THIS.assign_neighbours (4,0,0,  4,0,0)
ENDPROC
ENDDEFINE

DEFINE CLASS f5 As figure && zed2
mode = 5
main = .T.
PROCEDURE  after_init
THIS.init_arr (1,0,  1,1,  0,1,  0,2)
THIS.assign_neighbours (51,0,0,  51,0,0)
ENDPROC
ENDDEFINE

DEFINE CLASS f51 As figure && zed2 rotated
mode = 51
main = .F.
PROCEDURE  after_init
THIS.init_arr (0,0,  1,0,  1,1,  2,1)
THIS.assign_neighbours (5,0,0,  5,0,0)
ENDPROC
ENDDEFINE

DEFINE CLASS f6 As figure && scrap1
mode = 6
main = .T.
PROCEDURE  after_init
THIS.init_arr (0,0,  1,0,  2,0,  0,1)
THIS.assign_neighbours (62,0,0,  61,0,0)
ENDPROC
ENDDEFINE

DEFINE CLASS f61 As figure && scrap1 rotated
mode = 61
main = .F.
PROCEDURE  after_init
THIS.init_arr (1,0,  1,1,  1,2,  0,0)
THIS.assign_neighbours (6,0,0,  63,0,0)
ENDPROC
ENDDEFINE

DEFINE CLASS f62 As figure && scrap1 rotated
mode = 62
main = .F.
PROCEDURE  after_init
THIS.init_arr (0,0,  0,1,  0,2,  1,2)
THIS.assign_neighbours (63,0,0,  6,0,0)
ENDPROC
ENDDEFINE

DEFINE CLASS f63 As figure && scrap1 rotated
mode = 63
main = .F.
PROCEDURE  after_init
THIS.init_arr (0,1,  1,1,  2,1,  2,0)
THIS.assign_neighbours (61,0,0,  62,0,0)
ENDPROC
ENDDEFINE

DEFINE CLASS f7 As figure && scrap2
mode = 7
main = .T.
PROCEDURE  after_init
THIS.init_arr (0,0,  0,1,  1,1,  2,1)
THIS.assign_neighbours (72,0,0,  71,0,0)
ENDPROC
ENDDEFINE

DEFINE CLASS f71 As figure && scrap2 rotated
mode = 71
main = .F.
PROCEDURE  after_init
THIS.init_arr (0,0,  0,1,  0,2,  1,0)
THIS.assign_neighbours (7,0,0,  73,0,0)
ENDPROC
ENDDEFINE

DEFINE CLASS f72 As figure && scrap2 rotated
mode = 72
main = .F.
PROCEDURE  after_init
THIS.init_arr (1,0,  1,1,  1,2,  0,2)
THIS.assign_neighbours (73,0,0,  7,0,0)
ENDPROC
ENDDEFINE

DEFINE CLASS f73 As figure && scrap2 rotated
mode = 73
main = .F.
PROCEDURE  after_init
THIS.init_arr (0,0,  1,0,  2,0,  2,1)
THIS.assign_neighbours (71,0,0,  72,0,0)
ENDPROC
ENDDEFINE

DEFINE CLASS bucket As Container
max_mode = 7
current_mode = 0
BackColor = RGB(255,255,255)

DIMEN ff [100]
ADD OBJECT ff[ 1] As f1
ADD OBJECT ff[11] As f11
ADD OBJECT ff[ 2] As f2
ADD OBJECT ff[ 3] As f3
ADD OBJECT ff[31] As f31
ADD OBJECT ff[32] As f32
ADD OBJECT ff[33] As f33
ADD OBJECT ff[ 4] As f4
ADD OBJECT ff[41] As f41
ADD OBJECT ff[ 5] As f5
ADD OBJECT ff[51] As f51
ADD OBJECT ff[ 6] As f6
ADD OBJECT ff[61] As f61
ADD OBJECT ff[62] As f62
ADD OBJECT ff[63] As f63
ADD OBJECT ff[ 7] As f7
ADD OBJECT ff[71] As f71
ADD OBJECT ff[72] As f72
ADD OBJECT ff[73] As f73

arr_size = bucketWidth * bucketHeight
DIMEN arr [bucketHeight, bucketWidth]

PROCEDURE  Init
THIS.AddSquees
THIS.Width  = sqee_width * bucketWidth
THIS.Height = sqee_height * bucketHeight
ENDPROC

PROCEDURE  AddSquees
LOCAL lnY, lnX, lcName
FOR lnY=1 TO bucketHeight
FOR lnX=1 TO bucketWidth
lcName = STRTRAN('arr'+STR(lnY,2) + '_' + STR(lnX,2), ' ','0')
THIS.AddObject (lcName, 'sqee')
THIS.arr [lnY,lnX] = EVAL('THIS.'+lcName)
WITH THIS.arr [lnY,lnX]
.left    = (lnX-1) * sqee_width
.top     = (lnY-1) * sqee_height
.Owner   = 0
.visible = .T.
ENDWITH
ENDFOR
ENDFOR
ENDPROC

PROCEDURE  RemoveSquees
LOCAL lnY, lnX, lcName
FOR lnY=1 TO bucketHeight
FOR lnX=1 TO bucketWidth
lcName = STRTRAN('arr'+STR(lnY,2) + '_' + STR(lnX,2), ' ','0')
THIS.RemoveObject (lcName)
ENDFOR
ENDFOR
ENDPROC

FUNCTION  init_figure
THIS.current_mode = INT (RAND() * THIS.max_mode) + 1
IF NOT BETW(THIS.current_mode, 1,THIS.max_mode)
THIS.current_mode = 1
ENDIF
WITH THIS.ff [THIS.current_mode]
.reset_figure
IF .conflict (0,0,0)
RETURN .F.
ENDIF
.set_visible
ENDWITH
RETURN .T.
ENDFUNC

FUNCTION  debris_line (num)  && if there is at least one line of debris
LOCAL ii
FOR ii=1 TO bucketWidth
IF THIS.arr [num, ii].Owner <> -1
RETURN .F.
ENDIF
ENDFOR
RETURN .T.
ENDFUNC

FUNCTION find_debris_line
LOCAL jj
FOR jj=bucketHeight TO 1 STEP -1
IF THIS.debris_line (jj)
RETURN jj
ENDIF
ENDFOR
RETURN 0
ENDFUNC

PROCEDURE  shake_debris
LOCAL num, jj, ii, savedColor
num = THIS.find_debris_line()
IF num = 0
RETURN
ENDIF

* release line
FOR ii=1 TO bucketWidth
THIS.arr[num, ii].Owner = 0
THIS.arr[num, ii].BackColor = THIS.BackColor
ENDFOR

* drop all other lines
FOR jj=num-1 TO 1 STEP -1
FOR ii=1 TO bucketWidth
IF THIS.arr[jj,ii].Owner = -1
savedColor = THIS.arr [jj, ii].BackColor
THIS.arr [jj, ii].BackColor = THIS.BackColor
THIS.arr [jj, ii].Owner = 0
THIS.arr [jj+1, ii].BackColor = savedColor
THIS.arr [jj+1, ii].Owner = -1
ENDIF
ENDFOR
ENDFOR
ENDPROC

PROCEDURE  rotate_figure (newMode, dY,dX)
LOCAL obj
WITH THIS.ff [THIS.current_mode]
obj = THIS.ff [.turned_clockwise]
obj.dY = .dY + .turned_clockwise_dY
obj.dX = .dX + .turned_clockwise_dX
ENDWITH

IF Not obj.Conflict (0,0,THIS.current_mode)
THIS.ff [THIS.current_mode].set_free
THIS.current_mode = obj.mode
THIS.ff [THIS.current_mode].set_visible
RETURN .T.
ELSE
RETURN .F.
ENDIF
ENDPROC

PROCEDURE  rotate
WITH THIS.ff [THIS.current_mode]
DO WHILE .T.
IF THIS.rotate_figure (.turned_clockwise, .turned_clockwise_dY, .turned_clockwise_dX)
EXIT
ELSE
IF Not .move_right()
EXIT
ENDIF
ENDIF
ENDDO
ENDWITH
ENDPROC

PROCEDURE  rotate_counter_clockwise
WITH THIS.ff [THIS.current_mode]
THIS.rotate (.turned_counter, .turned_counter_dY, .turned_counter_dX)
ENDWITH
ENDPROC
ENDDEFINE

DEFINE CLASS frm As Form
Caption     = 'Tetris'
MaxButton   = .F.
BorderStyle = 2
KeyPreview  = .T.
ADD OBJECT d As bucket
ADD OBJECT t As Timer

PROCEDURE  Init
WITH THIS.d
STORE 0 TO .top, .left
THIS.Width  = .Width
THIS.Height = .Height
ENDWITH
THIS.d.init_figure
THIS.t.Interval = dropInterval && setting speed
ENDPROC

PROCEDURE  Destroy
THIS.d.RemoveSquees
ENDPROC

PROCEDURE  KeyPress
LPARAMETERS nKeyCode, nShiftAltCtrl
DO CASE
CASE nKeyCode=27
THIS.release
CASE nKeyCode=keyLeft
THIS.d.ff [THIS.d.current_mode].move_left
CASE nKeyCode=keyRight
THIS.d.ff [THIS.d.current_mode].move_right
CASE nKeyCode=keyDrop
DO WHILE THIS.d.ff [THIS.d.current_mode].move_down()
ENDDO
CASE nKeyCode=keyRotate
THIS.d.rotate
ENDCASE
ENDPROC

PROCEDURE  t.Timer
LOCAL obj
WITH ThisForm.d
obj = .ff [.current_mode]
IF Not obj.move_down()
obj.set_debris
IF .init_figure()
obj = .ff [.current_mode]
ELSE
ThisForm.release  && here you lost
ENDIF
ENDIF
.shake_debris
ENDWITH
ENDPROC
ENDDEFINE