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

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