extra/tetris/game/game.factor

   1 ! Copyright (C) 2006, 2007 Alex Chapman
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel sequences math math.functions tetris.board
   4 tetris.piece tetris.tetromino lazy-lists combinators system ;
   5 IN: tetris.game
   6
   7 TUPLE: tetris pieces last-update update-interval rows score game-state paused? running? ;
   8
   9 : default-width 10 ; inline
  10 : default-height 20 ; inline
  11
  12 : <tetris> ( width height -- tetris )
  13     <board> tetris construct-delegate
  14     dup board-width <piece-llist> over set-tetris-pieces
  15     0 over set-tetris-last-update
  16     0 over set-tetris-rows
  17     0 over set-tetris-score
  18     f over set-tetris-paused?
  19     t over set-tetris-running? ;
  20
  21 : <default-tetris> ( -- tetris ) default-width default-height <tetris> ;
  22
  23 : <new-tetris> ( old -- new )
  24     [ board-width ] keep board-height <tetris> ;
  25
  26 : tetris-board ( tetris -- board ) delegate ;
  27
  28 : tetris-current-piece ( tetris -- piece ) tetris-pieces car ;
  29
  30 : tetris-next-piece ( tetris -- piece ) tetris-pieces cdr car ;
  31
  32 : toggle-pause ( tetris -- )
  33     dup tetris-paused? not swap set-tetris-paused? ;
  34
  35 : tetris-level ( tetris -- level )
  36     tetris-rows 1+ 10 / ceiling ;
  37
  38 : tetris-update-interval ( tetris -- interval )
  39     tetris-level 1- 60 * 1000 swap - ;
  40
  41 : add-block ( tetris block -- )
  42     over tetris-current-piece tetromino-colour board-set-block ;
  43
  44 : game-over? ( tetris -- ? )
  45     dup tetris-next-piece piece-valid? not ;
  46
  47 : new-current-piece ( tetris -- )
  48     dup game-over? [
  49         f swap set-tetris-running?
  50     ] [
  51         dup tetris-pieces cdr swap set-tetris-pieces
  52     ] if ;
  53
  54 : rows-score ( level n -- score )
  55     {
  56         { 0 [ 0 ] }
  57         { 1 [ 40 ] }
  58         { 2 [ 100 ] }
  59         { 3 [ 300 ] }
  60         { 4 [ 1200 ] }
  61     } case swap 1+ * ;
  62
  63 : add-score ( tetris score -- )
  64     over tetris-score + swap set-tetris-score ;
  65
  66 : score-rows ( tetris n -- )
  67     2dup >r dup tetris-level r> rows-score add-score
  68     over tetris-rows + swap set-tetris-rows ;
  69
  70 : lock-piece ( tetris -- )
  71     [ dup tetris-current-piece piece-blocks [ add-block ] curry* each ] keep
  72     dup new-current-piece dup check-rows score-rows ;
  73
  74 : can-rotate? ( tetris -- ? )
  75     dup tetris-current-piece clone dup 1 rotate-piece piece-valid? ;
  76
  77 : (rotate) ( inc tetris -- )
  78     dup can-rotate? [ tetris-current-piece swap rotate-piece ] [ 2drop ] if ;
  79
  80 : rotate-left ( tetris -- ) -1 swap (rotate) ;
  81
  82 : rotate-right ( tetris -- ) 1 swap (rotate) ;
  83
  84 : can-move? ( tetris move -- ? )
  85     >r dup tetris-current-piece clone dup r> move-piece piece-valid? ;
  86
  87 : tetris-move ( tetris move -- ? )
  88     #! moves the piece if possible, returns whether the piece was moved
  89     2dup can-move? [
  90         >r tetris-current-piece r> move-piece t
  91     ] [
  92         2drop f
  93     ] if ;
  94
  95 : move-left ( tetris -- ) { -1 0 } tetris-move drop ;
  96
  97 : move-right ( tetris -- ) { 1 0 } tetris-move drop ;
  98
  99 : move-down ( tetris -- )
 100     dup { 0 1 } tetris-move [ drop ] [ lock-piece ] if ;
 101
 102 : move-drop ( tetris -- )
 103     dup { 0 1 } tetris-move [ move-drop ] [ lock-piece ] if ;
 104
 105 : update ( tetris -- )
 106     millis over tetris-last-update -
 107     over tetris-update-interval > [
 108         dup move-down
 109         millis swap set-tetris-last-update
 110     ] [ drop ] if ;
 111
 112 : maybe-update ( tetris -- )
 113     dup tetris-paused? over tetris-running? not or [ drop ] [ update ] if ;