And here is a real application. Text: TheTetrisGame This program is a port of the "tt.pfe" Tetris, written by Dirk Zoller for PFE. It is ANSI compliant in the original, and more or less so in the present version. Tetris has been ported to Holon by Thomas Beierlein and reworked by Wolf Wejgaard. Tetris is included with Holon as a working demonstration program. Text: TheRules Bricks of different shapes appear at random and drift down into a pit. You can move the current brick left or right with the 'left' or 'right' cursor keys, or rotate the brick in 90 degree increments with the 'up' key. The aim is to build complete lines with no gaps. A completed line is removed, providing space for more bricks. Bricks and lines contribute to the score. The 'down' key lets the brick fall straight down, the space bar halts the game until you press space again, and 'Q' ends the current game. 12 constant PitWidth 16 constant PitDepth Defining word for a pit. Creates the data array and defines the action of the pit. The pit delivers the address of the element i,j. : DefinePit create PitWidth PitDepth * allot does> rot PitWidth * rot + + ; ( i j -- adr ) Defines the pit. DefinePit Pit Upper left corner of the pit. 5 constant PitX0 4 constant PitY0 Sets cursor to position row col in the pit. : Position ( row col -- ) 2* PitX0 + swap PitY0 + xy ; Background colour. 0 constant Black Flag Draw? : 2emit ( c -- ) dup emit emit ; Draws or undraws two characters with attribute b (=0, if blank) : Stone ( b -- ) Attribute swap Draw? over and if 8 + Black + is Attribute 178 2emit else drop Black is Attribute 2 spaces then is Attribute ; Fills pit array with zeroes. : EmptyPit 0 0 Pit PitWidth PitDepth * erase ; : Wall 177 2emit ; Draws the bottom of the pit. : DrawBottom PitDepth -1 Position PitWidth 2+ 0 do Wall loop ; Draws the border of the pit. : DrawFrame PitDepth 0 do i -1 Position Wall i PitWidth Position Wall loop DrawBottom ; : DrawLine ( line -- ) dup 0 Position PitWidth 0 do dup i Pit c@ stone loop drop ; Draws the contents of the pit. : DrawPit PitDepth 0 do i DrawLine loop ; : ShowHelp 50 1 xy ." ***** T E T R I S *****" 50 2 xy ." =======================" 50 5 xy ." left : Move left" 50 6 xy ." right: Move right" 50 7 xy ." up : Rotate" 50 8 xy ." down : Drop" 50 9 xy ." space: Pause" 50 11 xy ." 'Q' : Quit" 3 1 xy ." Score:" 16 1 xy ." Pieces:" 31 1 xy ." Levels:" ; 0 integer Score 0 integer Pieces 0 integer Levels 0 integer Delay display current score : UpdateScore 10 1 xy bold Score 3 .r normal 24 1 xy Pieces 3 .r 39 1 xy Levels 3 .r ; Redraw everything on the screen. : Refresh page DrawFrame DrawPit ShowHelp UpdateScore ; Defining word for bricks. : Brick: create 8 0 do c, loop ( 8bytes -- ) does> ; The shape and the colour of the brick are defined by the numbers <> 0. 1 1 1 0 0 1 0 0 Brick: Brick1 2 2 2 2 0 0 0 0 Brick: Brick2 0 3 3 3 0 3 0 0 Brick: Brick3 4 4 4 0 0 0 4 0 Brick: Brick4 0 5 5 0 0 5 5 0 Brick: Brick5 6 6 0 0 0 6 6 0 Brick: Brick6 0 7 7 0 7 7 0 0 Brick: Brick7 Table of brick execution tokens. Note: ',' is a compiling word of the host. create Bricks ' Brick1 , ' Brick2 , ' Brick3 , ' Brick4 , ' Brick5 , ' Brick6 , ' Brick7 , create Scratch 16 allot Stores byte b in element i,j of the scratch array. Sometimes it is helpful to note the stack action in stack diagrams. : scratch! ( b i j -- ) scratch \ -- b i j adr rot \ -- b j adr i 4 * \ -- b j adr n rot \ -- b adr n j + \ -- b adr n2 + \ -- b adr2 c! ; Contains the pattern of the current brick. create Brick 16 allot : brick@ ( i j -- b ) brick rot 4 * rot + + c@ ; The value in "score" for each brick's difficulty. create BrickValue 1 c, 2 c, 3 c, 3 c, 4 c, 5 c, 5 c, Inserts the current brick's shape into "brick". xt is the execution token of a brick word, it is executed and delivers the address of the brick's data. : isBrick ( xt -- ) Brick 16 erase execute ( -- adr ) 8 times dup i + c@ Brick 4 + i + c! loop drop ; Brick position. 0 integer bRow 0 integer bCol Leaves a random number smaller than max. : Random ( max -- u ) time@ + + + swap mod ; Choose a new brick randomly and add to score. : NewBrick 1 add Pieces 7 Random Bricks over cells + @ isBrick BrickValue swap chars + c@ add Score ; Rotates current brick left. : RotateLeft 4 0 do 4 0 do j i brick@ 3 i - j scratch! loop loop Scratch Brick 16 move ; Rotates current brick right. : RotateRight 4 0 do 4 0 do j i brick@ i 3 j - scratch! loop loop Scratch Brick 16 move ; Rotates brick according to flag f. : Rotate ( f -- ) if RotateRight else RotateLeft then ; : DrawBrick 4 0 do 4 0 do j i brick@ 0<> if brow j + bcol i + Position j i brick@ Stone then loop loop ; : ShowBrick set Draw? DrawBrick ; : HideBrick clear Draw? DrawBrick ; Put the brick into the pit. : PutBrick 4 0 do 4 0 do j i brick@ 0<> if brow j + bcol i + Pit j i brick@ swap c! then loop loop ; Could the brick be there? : Brick? ( row col -- f ) 4 0 do 4 0 do j i brick@ 0<> if over j + over i + over dup 0< swap PitDepth >= or over dup 0< swap PitWidth >= or 2swap Pit c@ 0<> or or if unloop unloop 2drop false exit then then loop loop 2drop true ; Removes the brick from that position. : RemoveBrick brow bcol 4 0 do 4 0 do j i brick@ 0<> if over j + over i + Pit 0 swap c! then loop loop 2drop ; Tries to move the brick. : MoveBrick? ( rows cols -- f ) RemoveBrick swap brow + swap bcol + 2dup Brick? if HideBrick is bCol is bRow ShowBrick PutBrick true else 2drop PutBrick false then ; f = left/right. : RotateBrick ( f -- ) brow 0< if drop exit then \ no space yet for rotating RemoveBrick dup Rotate brow bcol Brick? over 0= Rotate if HideBrick Rotate PutBrick ShowBrick else drop then ; Introduces a new brick. : InsertBrick? ( row col -- flag ) 2dup Brick? if is bcol is brow PutBrick DrawBrick true else 2drop false then ; Moves the brick down fast. : DropBrick begin 1 0 MoveBrick? 0= until ; : MoveLine ( from to -- ) over 0 Pit over 0 Pit PitWidth move DrawLine dup 0 Pit PitWidth erase DrawLine ; Leaves true, if line is filled with bricks. : LineFull? ( line# - f ) true PitWidth 0 do over i Pit c@ 0= if drop false leave then loop nip ; : RemoveLines PitDepth dup begin swap begin 1- dup 0< if 2drop exit then dup LineFull? while 1 add Levels 10 add Score repeat swap 1- 2dup <> if 2dup MoveLine then again ; Flag End? Shows the message "adr and waits for a key, leaves key code. : AskMessage ( "adr -- c ) @xy rot SaveScreen 50 20 xy ." --- " "type ." ---" key RestoreScreen -rot xy ; Converts character c1 to uppercase c2. : >Upper ( c1 -- c2) dup [char] a >= over [char] z <= and if $20 - then ; : CharCases ( c -- ) case >Upper 09 of Halt endof \ Tab switches to host in Coroutine 'bl of " paused " AskMessage drop endof [char] Q of set End? endof drop endcase ; : FuncCases ( c -- ) case 75 ( left ) of 0 -1 MoveBrick? drop endof 77 ( right) of 0 1 MoveBrick? drop endof 72 ( up ) of 0 RotateBrick endof 80 ( down ) of DropBrick endof drop endcase ; : Interaction ( -- ) key ?dup if CharCases else FuncCases then ; Prepares for playing. : Initialize 0 is Score 0 is Pieces 0 is Levels 100 is Delay emptyPit Refresh clear End? !sp ; Makes it faster with increasing score. : AdjustDelay Levels dup 50 < if 100 swap - else dup 100 < if 62 swap 4 / - else dup 500 < if 31 swap 16 / - else drop 0 then then then is Delay ; User interaction? : ?Interaction Delay msec key? if Interaction then ; Tests: ... Change the insert method while Tetris runs... (put the backslash in front of the other line and reload the word). : StartBrick? ( -- f ) \ NewBrick -1 8 InsertBrick? \ insert in center NewBrick -1 PitWidth 2/ Random InsertBrick? \ insert randomly ; Play one Tetris game. : PlayGame begin StartBrick? while begin 4 0 do ?Interaction loop End? if exit then 1 0 moveBrick? 0= until RemoveLines UpdateScore AdjustDelay repeat ; This is the final group in the turnkey application. The final runtime word... Plays the game. : TetrisGame Initialize CurOff " Press any key" AskMessage drop begin PlayGame " Again? (Y/N)" AskMessage >Upper [char] Y = while Initialize repeat page 50 20 xy ." --- bye (see you later) --- " ; The Tetrisprogram running as the main task. If you start it from the host, the host waits for the program to end. : Tetris Console TetrisGame ; Makes Tetris the startword of a turnkey version of the tetris program. Press Ctl+F7=Turnkey to save the code as file TURNKEY.EXE. ( TheTetris ) Program: Tetris Use this group during development. Let Tetris run as a task in the target system, and work on the running program. Creates the Tetris task. Task TetrisTask The task program which is started with the task. : TaskProgram Screen TaskKeys TetrisGame ; Starts the Tetris task. : StartTetris make TetrisTask TaskProgram start TetrisTask ; Stops the task. : StopTetris stop TetrisTask ;