Return to tt.fs CVS log

Up to [gforth] / gforth / arch / r8c

Annotation of gforth/arch/r8c/tt.fs, revision 1.3

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