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 lists lists.lazy combinators system ;
7 TUPLE: tetris pieces last-update update-interval rows score game-state paused? running? ;
9 : default-width 10 ; inline
10 : default-height 20 ; inline
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? ;
21 : <default-tetris> ( -- tetris ) default-width default-height <tetris> ;
23 : <new-tetris> ( old -- new )
24 [ board-width ] keep board-height <tetris> ;
26 : tetris-board ( tetris -- board ) delegate ;
28 : tetris-current-piece ( tetris -- piece ) tetris-pieces car ;
30 : tetris-next-piece ( tetris -- piece ) tetris-pieces cdr car ;
32 : toggle-pause ( tetris -- )
33 dup tetris-paused? not swap set-tetris-paused? ;
35 : tetris-level ( tetris -- level )
36 tetris-rows 1+ 10 / ceiling ;
38 : tetris-update-interval ( tetris -- interval )
39 tetris-level 1- 60 * 1000 swap - ;
41 : add-block ( tetris block -- )
42 over tetris-current-piece tetromino-colour board-set-block ;
44 : game-over? ( tetris -- ? )
45 dup tetris-next-piece piece-valid? not ;
47 : new-current-piece ( tetris -- )
49 f swap set-tetris-running?
51 dup tetris-pieces cdr swap set-tetris-pieces
54 : rows-score ( level n -- score )
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 ] with each ] 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-left ( tetris -- ) -1 swap (rotate) ;
82 : rotate-right ( tetris -- ) 1 swap (rotate) ;
84 : can-move? ( tetris move -- ? )
85 >r dup tetris-current-piece clone dup r> move-piece piece-valid? ;
87 : tetris-move ( tetris move -- ? )
88 #! moves the piece if possible, returns whether the piece was moved
90 >r tetris-current-piece r> move-piece t
95 : move-left ( tetris -- ) { -1 0 } tetris-move drop ;
97 : move-right ( tetris -- ) { 1 0 } tetris-move drop ;
99 : move-down ( tetris -- )
100 dup { 0 1 } tetris-move [ drop ] [ lock-piece ] if ;
102 : move-drop ( tetris -- )
103 dup { 0 1 } tetris-move [ move-drop ] [ lock-piece ] if ;
105 : update ( tetris -- )
106 millis over tetris-last-update -
107 over tetris-update-interval > [
109 millis swap set-tetris-last-update
112 : maybe-update ( tetris -- )
113 dup tetris-paused? over tetris-running? not or [ drop ] [ update ] if ;