\ tt.pfe Tetris for terminals, redone in ANSI-Forth. \ Written 05Apr94 by Dirk Uwe Zoller, \ e-mail duz@roxi.rz.fht-mannheim.de. \ Look&feel stolen from Mike Taylor's "TETRIS FOR TERMINALS" \ \ Please copy and share this program, modify it for your system \ and improve it as you like. But don't remove this notice. \ \ Thank you. \ - Changed for Win32Forth \ Sonntag, März 14 2004 by Dirk Busch (dbu) \ - Changed to display the next piece \ Samstag, März 20 2004 by Dirk Busch (dbu) only forth also definitions true value create-turnkey? \ set to false when you don't want a turnkey app [defined] forget-tt [if] forget-tt [then] marker forget-tt [defined] extensions [if] extensions also [then] vocabulary tetris tetris also definitions decimal \ Variables, constants bl bl 2constant empty \ an empty position variable wiping \ if true: wipe brick, else draw brick 2 constant col0 \ position of the pit 0 constant row0 10 constant wide \ size of pit in brick positions 20 constant deep 0x20004 value left-key \ customize if you don't like them 0x20006 value rot-key \ currently this values are for the 0x20005 value right-key \ arrow key's in Win32Forth 0x20007 value drop-key char P value pause-key 12 value refresh-key char Q value quit-key variable score variable pieces variable levels variable delay variable brow \ where the brick is variable bcol \ stupid random number generator variable seed : randomize time&date + + + + + seed ! ; 1 cells 4 = [IF] 0x10450405 Constant generator : rnd ( -- n ) seed @ generator um* drop 1+ dup seed ! ; : random ( n -- 0..n-1 ) rnd um* nip ; [ELSE] : random \ max --- n ; return random number < max seed @ 13 * [ hex ] 07FFF [ decimal ] and dup seed ! swap mod ; [THEN] \ Access pairs of characters in memory: : 2c@ dup 1+ c@ swap c@ ; : 2c! dup >r c! r> 1+ c! ; : d<> d= 0= ; \ Drawing primitives: : 2emit emit emit ; : position \ row col --- ; cursor to the position in the pit 2* col0 + swap row0 + at-xy ; : stone \ c1 c2 --- ; draw or undraw these two characters wiping @ if 2drop 2 spaces else 2emit then ; \ Define the pit where bricks fall into: : def-pit create wide deep * 2* allot does> rot wide * rot + 2* + ; def-pit pit : empty-pit deep 0 do wide 0 do empty j i pit 2c! loop loop ; \ Displaying: : draw-bottom \ --- ; redraw the bottom of the pit deep -1 position [char] + dup stone wide 0 do [char] = dup stone loop [char] + dup stone ; : draw-frame \ --- ; draw the border of the pit deep 0 do i -1 position [char] | dup stone i wide position [char] | dup stone loop draw-bottom ; : bottom-msg \ addr cnt --- ; output a message in the bottom of the pit deep over 2/ wide swap - 2/ position type ; : draw-line \ line --- dup 0 position wide 0 do dup i pit 2c@ 2emit loop drop ; : draw-pit \ --- ; draw the contents of the pit deep 0 do i draw-line loop ; : show-key \ char --- ; visualization of that character dup bl < if [char] @ or [char] ^ emit emit space else [char] ` emit emit [char] ' emit then ; : show-help \ --- ; display some explanations 30 1 at-xy ." ***** T E T R I S *****" 30 2 at-xy ." =======================" 30 4 at-xy ." Use keys:" 32 5 at-xy ." 'arrow left' Move left" 32 6 at-xy ." 'arrow right' Move right" 32 7 at-xy ." 'arrow up' Rotate" 32 8 at-xy ." 'arrow down' Drop" 32 9 at-xy pause-key show-key ." Pause" 32 10 at-xy refresh-key show-key ." Refresh" 32 11 at-xy quit-key show-key ." Quit" 30 16 at-xy ." Score: Next piece:" 30 17 at-xy ." Pieces:" 30 18 at-xy ." Levels:" 0 22 at-xy ." ==== This program was written 1994 in pure dpANS Forth by Dirk Uwe Zoller ====" 0 23 at-xy ." ==================== Win32Forth port 2004 by Dirk Busch ======================" ; : update-score \ --- ; display current score 38 16 at-xy score @ 3 .r 38 17 at-xy pieces @ 3 .r 38 18 at-xy levels @ 3 .r ; : refresh \ --- ; redraw everything on screen page draw-frame draw-pit show-help update-score ; \ Define shapes of bricks: : def-brick create 4 0 do ' execute 0 do dup i chars + c@ c, loop drop refill drop loop does> rot 4 * rot + 2* + ; def-brick brick1 s" " s" ###### " s" ## " s" " def-brick brick2 s" " s" <><><><>" s" " s" " def-brick brick3 s" " s" {}{}{}" s" {} " s" " def-brick brick4 s" " s" ()()() " s" () " s" " def-brick brick5 s" " s" [][] " s" [][] " s" " def-brick brick6 s" " s" @@@@ " s" @@@@ " s" " def-brick brick7 s" " s" %%%% " s" %%%% " s" " \ this brick is actually in use: def-brick brick s" " s" " s" " s" " \ this brick will come next: def-brick next-brick s" " s" " s" " s" " def-brick scratch s" " s" " s" " s" " create bricks ' brick1 , ' brick2 , ' brick3 , ' brick4 , ' brick5 , ' brick6 , ' brick7 , create brick-val 1 c, 2 c, 3 c, 3 c, 4 c, 5 c, 5 c, variable brick-value : is-next-brick \ brick --- ; activate a shape of brick >body ['] next-brick >body 32 cmove ; : get-next-brick \ --- ; select the next brick by random 1 pieces +! 7 random bricks over cells + @ is-next-brick brick-val swap chars + c@ brick-value ! ; : is-brick \ brick --- ; activate a shape of brick >body ['] brick >body 32 cmove ; : new-brick \ --- ; select brick, count it ['] next-brick is-brick brick-value @ score +! get-next-brick ; : rotleft 4 0 do 4 0 do j i brick 2c@ 3 i - j scratch 2c! loop loop ['] scratch is-brick ; : rotright 4 0 do 4 0 do j i brick 2c@ i 3 j - scratch 2c! loop loop ['] scratch is-brick ; : draw-brick \ row col 4 0 do 4 0 do j i brick 2c@ empty d<> if over j + over i + position j i brick 2c@ stone then loop loop 2drop ; : show-brick wiping off draw-brick ; : hide-brick wiping on draw-brick ; : draw-next-brick \ row col --- 4 0 do 4 0 do j i next-brick 2c@ empty d<> if over j + over i + position j i next-brick 2c@ stone then loop loop 2drop ; : show-next-brick wiping off draw-next-brick ; : hide-next-brick wiping on draw-next-brick ; : put-brick \ row col --- ; put the brick into the pit 4 0 do 4 0 do j i brick 2c@ empty d<> if over j + over i + pit j i brick 2c@ rot 2c! then loop loop 2drop ; : remove-brick \ row col --- ; remove the brick from that position 4 0 do 4 0 do j i brick 2c@ empty d<> if over j + over i + pit empty rot 2c! then loop loop 2drop ; : test-brick \ row col --- flag ; could the brick be there? 4 0 do 4 0 do j i brick 2c@ empty d<> if over j + over i + over dup 0< swap deep >= or over dup 0< swap wide >= or 2swap pit 2c@ empty d<> or or if unloop unloop 2drop false exit then then loop loop 2drop true ; : move-brick \ rows cols --- flag ; try to move the brick brow @ bcol @ remove-brick swap brow @ + swap bcol @ + 2dup test-brick if brow @ bcol @ hide-brick 2dup bcol ! brow ! 2dup show-brick put-brick true else 2drop brow @ bcol @ put-brick false then ; : rotate-brick \ flag --- flag ; left/right, success brow @ bcol @ remove-brick dup if rotright else rotleft then brow @ bcol @ test-brick over if rotleft else rotright then if brow @ bcol @ hide-brick if rotright else rotleft then brow @ bcol @ put-brick brow @ bcol @ show-brick true else drop false then ; : insert-brick \ row col --- flag ; introduce a new brick 2dup test-brick if 2dup bcol ! brow ! 2dup put-brick draw-brick true else false then ; : drop-brick \ --- ; move brick down fast begin 1 0 move-brick 0= until ; : move-line \ from to --- over 0 pit over 0 pit wide 2* cmove draw-line dup 0 pit wide 2* blank draw-line ; : line-full \ line-no --- flag true wide 0 do over i pit 2c@ empty d= if drop false leave then loop nip ; : remove-lines \ --- deep deep begin swap begin 1- dup 0< if 2drop exit then dup line-full while 1 levels +! 10 score +! repeat swap 1- 2dup <> if 2dup move-line then again ; : to-upper \ char --- char ; convert to upper case dup [char] a >= over [char] z <= and if bl - then ; : interaction \ --- flag case key to-upper left-key of 0 -1 move-brick drop endof right-key of 0 1 move-brick drop endof rot-key of 0 rotate-brick drop endof drop-key of drop-brick endof pause-key of S" paused " bottom-msg key drop draw-bottom endof refresh-key of refresh endof quit-key of false exit endof endcase true ; : initialize \ --- ; prepare for playing randomize empty-pit refresh 0 score ! 0 pieces ! 0 levels ! 100 delay ! get-next-brick ; : adjust-delay \ --- ; make it faster with increasing score levels @ dup 50 < if 100 over - else dup 100 < if 62 over 4 / - else dup 500 < if 31 over 16 / - else 0 then then then delay ! drop ; : play-game \ --- ; play one tetris game begin 15 30 hide-next-brick new-brick 15 30 show-next-brick -1 3 insert-brick while begin 4 0 do 35 13 at-xy delay @ ms key? if interaction 0= if unloop exit then then loop 1 0 move-brick 0= until remove-lines update-score adjust-delay repeat ; forth definitions : tt \ --- ; play the tetris game initialize s" Press any key " bottom-msg key drop draw-bottom begin play-game s" Again? " bottom-msg key to-upper [char] Y = while initialize repeat create-turnkey? if bye \ quit our turnkey application else 0 23 at-xy cr then ; \ create a turnkey application create-turnkey? [IF] : set-console-title ( -- ) Z" Tetris" CONHNDL call SetWindowText drop ; : tetris-hello ( -- ) \ startup stuff \ default initialization (needed for all turnkey apps) init-console if initialization-chain do-chain then exception@ if bye then \ our own initialization MENU-OFF \ close menubar set-console-title \ set window title INIT-SCREEN \ show console get-commandline \ copy commandline to SOURCE default-application ; \ and run our app \ override init-console with the default \ to make shure that we have no statusbar in the turnkey app. \ ' x_init-console is init-console (this is done in the kernel now) \ override default-hello with our own one ' tetris-hello is default-hello \ and create the turnkey app. &appdir OFF \ create the exe-file in the current folder ' tt turnkey tetris 5 pause-seconds bye [else] TT only forth also definitions [then]