Annotation of gforth/tt.fs, revision 1.1

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
        !            14: \ s" forget-tt" drop 1- find nip [if] forget-tt [then] marker forget-tt
        !            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
        !           315:                dup [char] a >= over [char] z <= and if  bl -  then ;
        !           316: 
        !           317: : interaction  \ --- flag
        !           318:                case  key to-upper
        !           319:                    left-key    of  0 -1 move-brick drop  endof
        !           320:                    right-key   of  0  1 move-brick drop  endof
        !           321:                    rot-key     of  0 rotate-brick drop  endof
        !           322:                    drop-key    of  drop-brick  endof
        !           323:                    pause-key   of  S"  paused " bottom-msg  key drop
        !           324:                                    draw-bottom  endof
        !           325:                    refresh-key of  refresh  endof
        !           326:                    quit-key    of  false exit  endof
        !           327:                endcase  true ;
        !           328: 
        !           329: : initialize   \ --- ; prepare for playing
        !           330:                randomize empty-pit refresh
        !           331:                0 score !  0 pieces !  0 levels !  100 delay ! ;
        !           332: 
        !           333: : adjust-delay \ --- ; make it faster with increasing score
        !           334:                levels @
        !           335:                dup  50 < if  100 over -  else
        !           336:                dup 100 < if   62 over 4 / -  else
        !           337:                dup 500 < if   31 over 16 / -  else  0  then then then
        !           338:                delay !  drop ;
        !           339: 
        !           340: : play-game    \ --- ; play one tetris game
        !           341:                begin
        !           342:                    new-brick
        !           343:                    -1 3 insert-brick
        !           344:                while
        !           345:                    begin  4 0
        !           346:                        do  35 13 at-xy
        !           347:                            delay @ ms key?
        !           348:                            if  interaction 0=
        !           349:                                if  unloop exit  then
        !           350:                            then
        !           351:                        loop
        !           352:                        1 0 move-brick  0=
        !           353:                    until
        !           354:                    remove-lines
        !           355:                    update-score
        !           356:                    adjust-delay
        !           357:                repeat ;
        !           358: 
        !           359: forth definitions
        !           360: 
        !           361: : tt           \ --- ; play the tetris game
        !           362:                initialize
        !           363:                s"  Press any key " bottom-msg key drop draw-bottom
        !           364:                begin
        !           365:                    play-game
        !           366:                    s"  Again? " bottom-msg key to-upper [char] Y =
        !           367:                while  initialize  repeat
        !           368:                0 23 at-xy cr ;
        !           369: 
        !           370: only forth also definitions

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