File:  [gforth] / gforth / arch / r8c / tt.fs
Revision 1.7: download - view: text, annotated - select for diffs
Sun Feb 15 22:15:37 2009 UTC (13 years, 9 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Removed copyright comments, because they don't load on r8c

    1: \ tt.pfe
    2: \ see ../../tt.fs
    3: rom
    4: 
    5: bl bl 2constant empt
    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 $1234 seed !
   31: 
   32: : randomize  timer @ 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
   75: 	wide 0 do  empt j i pit 2c!
   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 *****"
  111:   30  2 at-xy ." ======Dirk Zoller======"
  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
  224:       j i brick 2c@  empt d<>
  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
  235:       j i brick 2c@  empt d<>
  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
  243:       j i brick 2c@  empt d<>
  244:       if  over j + over i + pit empt rot 2c!  then
  245:   loop loop  2drop ;
  246: 
  247: : test-brick
  248:   4 0 do 4 0 do
  249:       j i brick 2c@ empt d<>
  250:       if  over j +  over i +
  251:    over dup 0< swap deep >= or
  252:    over dup 0< swap wide >= or
  253:    2swap pit 2c@  empt d<>
  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
  294:   do  over i pit 2c@ empt d=
  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 ;

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