Annotation of gforth/arch/misc/tt.fs, revision 1.5

1.1       pazsan      1: \
                      2: \ tt.pfe       Tetris for terminals, redone in ANSI-Forth.
                      3: \              Written 05Apr94 by Dirk Uwe Zoller,
                      4: \                      e-mail duz@roxi.rz.fht-mannheim.de.
                      5: \              Look&feel stolen from Mike Taylor's "TETRIS FOR TERMINALS"
                      6: \ 
                      7: \              Please copy and share this program, modify it for your system
                      8: \              and improve it as you like. But don't remove this notice.
                      9: \ 
                     10: \              Thank you.
                     11: \
                     12: 
                     13: decimal
                     14: 
1.2       pazsan     15: variable loops/ms
                     16: 0 loops/ms !
                     17: 
                     18: : ms  0 ?DO  loops/ms @ 0 ?DO LOOP LOOP ;
1.1       pazsan     19: : blank  bl fill ;
                     20: 
1.5     ! pazsan     21: : pn    ( n -- )  0 <# # # #> type ;
1.1       pazsan     22: : ;pn   [char] ; emit pn ;
                     23: : ESC[  27 emit [char] [ emit ;
                     24: : at-xy 1+ swap 1+ swap ESC[ pn ;pn [char] H emit ;
                     25: : page  ESC[ ." 2J" 0 0 at-xy ;
                     26: : d= rot = >r = r> and ;
                     27: 
                     28: \ Variables, constants
                     29: 
                     30: bl bl 2constant empty          \ an empty position
                     31: variable wiping                        \ if true: wipe brick, else draw brick
                     32:  2 constant col0               \ position of the pit
                     33:  0 constant row0
                     34: 
                     35: 10 constant wide               \ size of pit in brick positions
                     36: 20 constant deep
                     37: 
                     38: 'J     value left-key          \ customize if you don't like them
                     39: 'K     value rot-key
                     40: 'L     value right-key
                     41: bl     value drop-key
                     42: 'P     value pause-key
                     43: 12     value refresh-key
                     44: 'Q     value quit-key
                     45: 
                     46: : wide* dup 2* 2* + 2* ;
                     47: 
                     48: variable score
                     49: variable pieces
                     50: variable levels
                     51: variable delay
                     52: 
                     53: variable brow                  \ where the brick is
                     54: variable bcol
                     55: 
                     56: 
                     57: \ stupid random number generator
                     58: 
                     59: variable seed
                     60: 
                     61: : randomize    1234 seed ! ( time&date + + + + + seed ! ) ;
                     62: 
                     63: 1 cells 4 = [IF]
                     64: $10450405 Constant generator
                     65: 
                     66: : rnd  ( -- n )  seed @ generator um* drop 1+ dup seed ! ;
                     67: 
                     68: : random ( n -- 0..n-1 )  rnd um* nip ;
                     69: [ELSE]
                     70: : random       \ max --- n ; return random number < max
                     71:                seed @ 13 * 1+ [ hex ] 07FFF [ decimal ] and
                     72:                dup seed !  swap mod ;
                     73: [THEN]
                     74: 
                     75: \ Access pairs of characters in memory:
                     76: 
                     77: : 2c@          dup 1+ c@ swap c@ ;
                     78: : 2c!          dup >r c! r> 1+ c! ;
                     79: 
                     80: : d<>          d= 0= ;
                     81: 
                     82: 
                     83: \ Drawing primitives:
                     84: 
                     85: : 2emit                emit emit ;
                     86: 
                     87: : position     \ row col --- ; cursor to the position in the pit
                     88:                2* col0 + swap row0 + at-xy ;
                     89: 
                     90: : stone                \ c1 c2 --- ; draw or undraw these two characters
                     91:                wiping @ if  2drop 2 spaces  else  2emit  then ;
                     92: 
                     93: 
                     94: \ Define the pit where bricks fall into:
                     95: 
                     96: Create pit     wide deep * 2* allot
                     97: DOES>  rot wide* rot + 2* + ;
                     98: 
                     99: : empty-pit    deep 0 do wide 0 do  empty j i pit 2c!
                    100:                loop loop ;
                    101: 
                    102: 
                    103: \ Displaying:
                    104: 
                    105: : draw-bottom  \ --- ; redraw the bottom of the pit
                    106:                deep -1 position
                    107:                [char] + dup stone
                    108:                wide 0 do  [char] = dup stone  loop
                    109:                [char] + dup stone ;
                    110: 
                    111: : draw-frame   \ --- ; draw the border of the pit
                    112:                deep 0 do
                    113:                    i -1   position [char] | dup stone
                    114:                    i wide position [char] | dup stone
                    115:                loop  draw-bottom ;
                    116: 
                    117: : bottom-msg   \ addr cnt --- ; output a message in the bottom of the pit
                    118:                deep over 2/ wide swap - 2/ position type ;
                    119: 
                    120: : draw-line    \ line ---
                    121:                dup 0 position  wide 0 do  dup i pit 2c@ 2emit  loop  drop ;
                    122: 
                    123: : draw-pit     \ --- ; draw the contents of the pit
                    124:                deep 0 do  i draw-line  loop ;
                    125: 
                    126: : show-key     \ char --- ; visualization of that character
                    127:                dup bl <
                    128:                if  [char] @ or  [char] ^ emit  emit  space
                    129:                else  [char] ` emit  emit  [char] ' emit
                    130:                then ;
                    131: 
                    132: : show-help    \ --- ; display some explanations
                    133:                30  1 at-xy ." ***** T E T R I S *****"
                    134:                30  2 at-xy ." ======================="
                    135:                30  4 at-xy ." Use keys:"
                    136:                32  5 at-xy left-key    show-key ."  Move left"
                    137:                32  6 at-xy rot-key     show-key ."  Rotate"
                    138:                32  7 at-xy right-key   show-key ."  Move right"
                    139:                32  8 at-xy drop-key    show-key ."  Drop"
                    140:                32  9 at-xy pause-key   show-key ."  Pause"
                    141:                32 10 at-xy refresh-key show-key ."  Refresh"
                    142:                32 11 at-xy quit-key    show-key ."  Quit"
                    143:                32 13 at-xy ." -> "
                    144:                30 16 at-xy ." Score:"
                    145:                30 17 at-xy ." Pieces:"
                    146:                30 18 at-xy ." Levels:"
                    147:                 0 22 at-xy ."  ==== This program was written 1994 in pure dpANS Forth by Dirk Uwe Zoller ===="
                    148:                 0 23 at-xy ."  =================== Copy it, port it, play it, enjoy it! =====================" ;
                    149: 
                    150: : update-score \ --- ; display current score
                    151:                38 16 at-xy score @ 3 .r
                    152:                38 17 at-xy pieces @ 3 .r
                    153:                38 18 at-xy levels @ 3 .r ;
                    154: 
                    155: : refresh      \ --- ; redraw everything on screen
                    156:                page draw-frame draw-pit show-help update-score ;
                    157: 
                    158: 
                    159: \ Define shapes of bricks:
                    160: 
                    161: Create brick1  ,"         ######    ##            "
                    162: Create brick2  ,"         <><><><>                "
                    163: Create brick3  ,"           {}{}{}  {}            "
                    164: Create brick4  ,"         ()()()      ()          "
                    165: Create brick5  ,"           [][]    [][]          "
                    166: Create brick6  ,"         @@@@      @@@@          "
                    167: Create brick7  ,"           %%%%  %%%%            "
                    168: 
                    169: \ this brick is actually in use:
                    170: 
                    171: Create brick   ,"                                 "
                    172: DOES>  1+ rot 2* 2* rot + 2* + ;
                    173: Create scratch ,"                                 "
                    174: DOES>  1+ rot 2* 2* rot + 2* + ;
                    175: 
1.4       jwilke    176: create bricks  brick1 1 + a,  brick2 1 + a,  brick3 1 + a,  brick4 1 + a,
                    177:                brick5 1 + a,  brick6 1 + a,  brick7 1 + a,
1.1       pazsan    178: 
                    179: create brick-val 1 c, 2 c, 3 c, 3 c, 4 c, 5 c, 5 c,
                    180: 
                    181: : is-brick     \ brick --- ; activate a shape of brick
                    182:                ['] brick >body 1+ 32 cmove ;
                    183: 
                    184: : new-brick    \ --- ; select a new brick by random, count it
                    185:                1 pieces +!  7 random
                    186:                bricks over cells + @ is-brick
                    187:                brick-val swap chars + c@ score +! ;
                    188: 
                    189: : rotleft      4 0 do 4 0 do
                    190:                    j i brick 2c@  3 i - j scratch 2c!
                    191:                loop loop
                    192:                0 0 scratch is-brick ;
                    193: 
                    194: : rotright     4 0 do 4 0 do
                    195:                    j i brick 2c@  i 3 j - scratch 2c!
                    196:                loop loop
                    197:                0 0 scratch is-brick ;
                    198: 
                    199: : draw-brick   \ row col ---
                    200:                4 0 do 4 0 do
                    201:                    j i brick 2c@  empty d<>
                    202:                    if  over j + over i +  position
                    203:                        j i brick 2c@  stone
                    204:                    then
                    205:                loop loop  2drop ;
                    206: 
                    207: : show-brick   wiping off draw-brick ;
                    208: : hide-brick   wiping on  draw-brick ;
                    209: 
                    210: : put-brick    \ row col --- ; put the brick into the pit
                    211:                4 0 do 4 0 do
                    212:                    j i brick 2c@  empty d<>
                    213:                    if  over j +  over i +  pit
                    214:                        j i brick 2c@  rot 2c!
                    215:                    then
                    216:                loop loop  2drop ;
                    217: 
                    218: : remove-brick \ row col --- ; remove the brick from that position
                    219:                4 0 do 4 0 do
                    220:                    j i brick 2c@  empty d<>
                    221:                    if  over j + over i + pit empty rot 2c!  then
                    222:                loop loop  2drop ;
                    223: 
                    224: : test-brick   \ row col --- flag ; could the brick be there?
                    225:                4 0 do 4 0 do
                    226:                    j i brick 2c@ empty d<>
                    227:                    if  over j +  over i +
                    228:                        over dup 0< swap deep >= or
                    229:                        over dup 0< swap wide >= or
                    230:                        2swap pit 2c@  empty d<>
                    231:                        or or if  unloop unloop 2drop false  exit  then
                    232:                    then
                    233:                loop loop  2drop true ;
                    234: 
                    235: : move-brick   \ rows cols --- flag ; try to move the brick
                    236:                brow @ bcol @ remove-brick
                    237:                swap brow @ + swap bcol @ + 2dup test-brick
                    238:                if  brow @ bcol @ hide-brick
                    239:                    2dup bcol ! brow !  2dup show-brick put-brick  true
                    240:                else  2drop brow @ bcol @ put-brick  false
                    241:                then ;
                    242: 
                    243: : rotate-brick \ flag --- flag ; left/right, success
                    244:                brow @ bcol @ remove-brick
                    245:                dup if  rotright  else  rotleft  then
                    246:                brow @ bcol @ test-brick
                    247:                over if  rotleft  else  rotright  then
                    248:                if  brow @ bcol @ hide-brick
                    249:                    if  rotright  else  rotleft  then
                    250:                    brow @ bcol @ put-brick
                    251:                    brow @ bcol @ show-brick  true
                    252:                else  drop false  then ;
                    253: 
                    254: : insert-brick \ row col --- flag ; introduce a new brick
                    255:                2dup test-brick
                    256:                if  2dup bcol ! brow !
                    257:                    2dup put-brick  draw-brick  true
                    258:                else  false  then ;
                    259: 
                    260: : drop-brick   \ --- ; move brick down fast
1.3       pazsan    261:                begin  1 0 move-brick key? drop 0=  until ;
1.1       pazsan    262: 
                    263: : move-line    \ from to ---
                    264:                over 0 pit  over 0 pit  wide 2*  cmove  draw-line
                    265:                dup 0 pit  wide 2*  blank  draw-line ;
                    266: 
                    267: : line-full    \ line-no --- flag
                    268:                true  wide 0
                    269:                do  over i pit 2c@ empty d=
                    270:                    if  drop false  leave  then
                    271:                loop nip ;
                    272: 
                    273: : remove-lines \ ---
                    274:                deep deep
                    275:                begin
                    276:                    swap
                    277:                    begin  1- dup 0< if  2drop exit  then  dup line-full
                    278:                    while  1 levels +!  10 score +!  repeat
                    279:                    swap 1-
                    280:                    2dup <> if  2dup move-line  then
                    281:                again ;
                    282: 
                    283: : to-upper     \ char --- char ; convert to upper case
                    284:                dup [char] a >= over [char] z <= and if  bl -  then ;
                    285: 
                    286: : interaction  \ --- flag
                    287:                case  key to-upper
                    288:                    left-key    of  0 -1 move-brick drop  endof
                    289:                    right-key   of  0  1 move-brick drop  endof
                    290:                    rot-key     of  0 rotate-brick drop  endof
                    291:                    drop-key    of  drop-brick  endof
                    292:                    pause-key   of  S"  paused " bottom-msg  key drop
                    293:                                    draw-bottom  endof
                    294:                    refresh-key of  refresh  endof
                    295:                    quit-key    of  false exit  endof
                    296:                endcase  true ;
                    297: 
                    298: : initialize   \ --- ; prepare for playing
                    299:                randomize empty-pit refresh
                    300:                0 score !  0 pieces !  0 levels !  100 delay ! ;
                    301: 
                    302: : adjust-delay \ --- ; make it faster with increasing score
                    303:                levels @
                    304:                dup  50 < if  100 over -  else
                    305:                dup 100 < if   62 over 4 / -  else
                    306:                dup 500 < if   31 over 16 / -  else  0  then then then
                    307:                delay !  drop ;
                    308: 
                    309: : play-game    \ --- ; play one tetris game
                    310:                begin
                    311:                    new-brick
                    312:                    -1 3 insert-brick
                    313:                while
                    314:                    begin  4 0
                    315:                        do  35 13 at-xy
                    316:                            delay @ ms key?
                    317:                            if  interaction 0=
                    318:                                if  unloop exit  then
                    319:                            then
                    320:                        loop
                    321:                        1 0 move-brick  0=
                    322:                    until
                    323:                    remove-lines
                    324:                    update-score
                    325:                    adjust-delay
                    326:                repeat ;
                    327: 
                    328: : tt           \ --- ; play the tetris game
                    329:                initialize
                    330:                s"  Press any key " bottom-msg key drop draw-bottom
                    331:                begin
                    332:                    play-game
                    333:                    s"  Again? " bottom-msg key to-upper [char] Y =
                    334:                while  initialize  repeat
                    335:                0 23 at-xy cr ;
                    336: 

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>