extra/tetris/game/game.factor

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