1 ! Copyright (C) 2006 Alex Chapman
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel generic sequences math tetris-board tetris-piece tetromino errors lazy-lists ;
6 TUPLE: tetris pieces last-update update-interval rows score game-state paused? running? ;
8 : default-width 10 ; inline
9 : default-height 20 ; inline
11 C: tetris ( width height -- tetris )
12 >r <board> r> [ set-delegate ] keep
13 dup board-width <piece-llist> over set-tetris-pieces
14 0 over set-tetris-last-update
15 0 over set-tetris-rows
16 0 over set-tetris-score
17 f over set-tetris-paused?
18 t over set-tetris-running? ;
20 : <default-tetris> ( -- tetris ) default-width default-height <tetris> ;
22 : <new-tetris> ( old -- new )
23 [ board-width ] keep board-height <tetris> ;
25 : tetris-board ( tetris -- board ) delegate ;
27 : tetris-current-piece ( tetris -- piece ) tetris-pieces car ;
29 : tetris-next-piece ( tetris -- piece ) tetris-pieces cdr car ;
31 : toggle-pause ( tetris -- )
32 dup tetris-paused? not swap set-tetris-paused? ;
34 : tetris-level ( tetris -- level )
35 tetris-rows 1+ 10 / ceiling ;
37 : tetris-update-interval ( tetris -- interval )
38 tetris-level 1- 60 * 1000 swap - ;
40 : add-block ( tetris block -- )
41 over tetris-current-piece tetromino-colour board-set-block ;
43 : game-over? ( tetris -- ? )
44 dup dup tetris-next-piece piece-valid? ;
46 : new-current-piece ( tetris -- )
48 dup tetris-pieces cdr swap set-tetris-pieces
50 f swap set-tetris-running?
53 : rows-score ( level n -- score )
55 { [ dup 0 = ] [ drop 0 ] }
56 { [ dup 1 = ] [ drop 40 ] }
57 { [ dup 2 = ] [ drop 100 ] }
58 { [ dup 3 = ] [ drop 300 ] }
59 { [ dup 4 = ] [ drop 1200 ] }
60 { [ t ] [ "how did you clear that many rows?" throw ] }
63 : add-score ( tetris score -- )
64 over tetris-score + swap set-tetris-score ;
66 : score-rows ( tetris n -- )
67 2dup >r dup tetris-level r> rows-score add-score
68 over tetris-rows + swap set-tetris-rows ;
70 : lock-piece ( tetris -- )
71 [ dup tetris-current-piece piece-blocks [ add-block ] each-with ] keep
72 dup new-current-piece dup check-rows score-rows ;
74 : can-rotate? ( tetris -- ? )
75 dup tetris-current-piece clone dup 1 rotate-piece piece-valid? ;
77 : (rotate) ( inc tetris -- )
78 dup can-rotate? [ tetris-current-piece swap rotate-piece ] [ 2drop ] if ;
80 : rotate ( tetris -- ) 1 swap (rotate) ;
82 : can-move? ( tetris move -- ? )
83 >r dup tetris-current-piece clone dup r> move-piece piece-valid? ;
85 : tetris-move ( tetris move -- ? )
86 #! moves the piece if possible, returns whether the piece was moved
88 >r tetris-current-piece r> move-piece t
93 : move-left ( tetris -- ) { -1 0 } tetris-move drop ;
95 : move-right ( tetris -- ) { 1 0 } tetris-move drop ;
97 : move-down ( tetris -- )
98 dup { 0 1 } tetris-move [ drop ] [ lock-piece ] if ;
100 : move-drop ( tetris -- )
101 dup { 0 1 } tetris-move [ move-drop ] [ lock-piece ] if ;
103 : can-move? ( tetris move -- ? )
104 >r dup tetris-current-piece clone dup r> move-piece piece-valid? ;
106 : update ( tetris -- )
107 millis over tetris-last-update -
108 over tetris-update-interval > [
110 millis swap set-tetris-last-update
113 : maybe-update ( tetris -- )
114 dup tetris-paused? over tetris-running? not or [ drop ] [ update ] if ;