extra/tetris/game/game.factor

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