1 ! Copyright (C) 2006, 2007, 2008 Alex Chapman
2 ! See http://factorcode.org/license.txt for BSD license.
4 USING: accessors combinators kernel lists math math.functions
5 sequences system tetris.board tetris.piece tetris.tetromino ;
12 { last-update integer initial: 0 }
13 { rows integer initial: 0 }
14 { score integer initial: 0 }
15 { paused? initial: f }
16 { running? initial: t } ;
18 CONSTANT: default-width 10
19 CONSTANT: default-height 20
21 : <tetris> ( width height -- tetris )
22 dupd <board> swap <piece-llist>
23 tetris new swap >>pieces swap >>board ;
25 : <default-tetris> ( -- tetris )
26 default-width default-height <tetris> ;
28 : <new-tetris> ( old -- new )
29 board>> [ width>> ] [ height>> ] bi <tetris> ;
31 : current-piece ( tetris -- piece ) pieces>> car ;
33 : next-piece ( tetris -- piece ) pieces>> cdr car ;
35 : toggle-pause ( tetris -- )
36 [ not ] change-paused? drop ;
38 : level ( tetris -- level )
39 rows>> 1 + 10 / ceiling ;
41 : update-interval ( tetris -- interval )
42 level 1 - 60 * 1,000,000,000 swap - ;
44 : add-block ( tetris block -- )
45 over [ board>> ] 2dip current-piece tetromino>> colour>> set-block ;
47 : game-over? ( tetris -- ? )
48 [ board>> ] [ next-piece ] bi piece-valid? not ;
50 : new-current-piece ( tetris -- tetris )
57 : rows-score ( level n -- score )
66 : add-score ( tetris n-rows -- tetris )
67 over level swap rows-score swap [ + ] change-score ;
69 : add-rows ( tetris rows -- tetris )
70 swap [ + ] change-rows ;
72 : score-rows ( tetris n -- )
73 [ add-score ] keep add-rows drop ;
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 ;
79 : can-rotate? ( tetris -- ? )
80 [ board>> ] [ current-piece clone 1 rotate-piece ] bi piece-valid? ;
82 : (rotate) ( inc tetris -- )
83 dup can-rotate? [ current-piece swap rotate-piece drop ] [ 2drop ] if ;
85 : rotate-left ( tetris -- ) -1 swap (rotate) ;
87 : rotate-right ( tetris -- ) 1 swap (rotate) ;
89 : can-move? ( tetris move -- ? )
90 [ drop board>> ] [ [ current-piece clone ] dip move-piece ] 2bi piece-valid? ;
92 : tetris-move ( tetris move -- ? )
93 ! moves the piece if possible, returns whether the piece was moved
95 [ current-piece ] dip move-piece drop t
100 : move-left ( tetris -- ) { -1 0 } tetris-move drop ;
102 : move-right ( tetris -- ) { 1 0 } tetris-move drop ;
104 : move-down ( tetris -- )
105 dup { 0 1 } tetris-move [ drop ] [ lock-piece ] if ;
107 : move-drop ( tetris -- )
108 dup { 0 1 } tetris-move [ move-drop ] [ lock-piece ] if ;
110 : update ( tetris -- )
111 nano-count over last-update>> -
112 over update-interval > [
114 nano-count >>last-update
117 : ?update ( tetris -- )
118 dup [ paused?>> ] [ running?>> not ] bi or [ drop ] [ update ] if ;