-! Copyright (C) 2006, 2007 Alex Chapman
+! Copyright (C) 2006, 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences math math.functions tetris.board
-tetris.piece tetris.tetromino lists combinators system ;
+USING: accessors combinators kernel lists math math.functions sequences system tetris.board tetris.piece tetris.tetromino ;
IN: tetris.game
-TUPLE: tetris pieces last-update update-interval rows score game-state paused? running? ;
+TUPLE: tetris
+ { board board }
+ { pieces }
+ { last-update integer initial: 0 }
+ { rows integer initial: 0 }
+ { score integer initial: 0 }
+ { paused? initial: f }
+ { running? initial: t } ;
-: default-width 10 ; inline
-: default-height 20 ; inline
+CONSTANT: default-width 10
+CONSTANT: default-height 20
: <tetris> ( width height -- tetris )
- <board> tetris construct-delegate
- dup board-width <piece-llist> over set-tetris-pieces
- 0 over set-tetris-last-update
- 0 over set-tetris-rows
- 0 over set-tetris-score
- f over set-tetris-paused?
- t over set-tetris-running? ;
-
+ dupd <board> swap <piece-llist>
+ tetris new swap >>pieces swap >>board ;
+
: <default-tetris> ( -- tetris ) default-width default-height <tetris> ;
: <new-tetris> ( old -- new )
- [ board-width ] keep board-height <tetris> ;
-
-: tetris-board ( tetris -- board ) delegate ;
+ board>> [ width>> ] [ height>> ] bi <tetris> ;
-: tetris-current-piece ( tetris -- piece ) tetris-pieces car ;
+: current-piece ( tetris -- piece ) pieces>> car ;
-: tetris-next-piece ( tetris -- piece ) tetris-pieces cdr car ;
+: next-piece ( tetris -- piece ) pieces>> cdr car ;
: toggle-pause ( tetris -- )
- dup tetris-paused? not swap set-tetris-paused? ;
+ [ not ] change-paused? drop ;
-: tetris-level ( tetris -- level )
- tetris-rows 1+ 10 / ceiling ;
+: level>> ( tetris -- level )
+ rows>> 1 + 10 / ceiling ;
-: tetris-update-interval ( tetris -- interval )
- tetris-level 1- 60 * 1000 swap - ;
+: update-interval ( tetris -- interval )
+ level>> 1 - 60 * 1000 swap - ;
: add-block ( tetris block -- )
- over tetris-current-piece tetromino-colour board-set-block ;
+ over board>> spin current-piece tetromino>> colour>> set-block ;
: game-over? ( tetris -- ? )
- dup tetris-next-piece piece-valid? not ;
+ [ board>> ] [ next-piece ] bi piece-valid? not ;
-: new-current-piece ( tetris -- )
+: new-current-piece ( tetris -- tetris )
dup game-over? [
- f swap set-tetris-running?
+ f >>running?
] [
- dup tetris-pieces cdr swap set-tetris-pieces
+ [ cdr ] change-pieces
] if ;
: rows-score ( level n -- score )
{ 2 [ 100 ] }
{ 3 [ 300 ] }
{ 4 [ 1200 ] }
- } case swap 1+ * ;
+ } case swap 1 + * ;
+
+: add-score ( tetris n-rows -- tetris )
+ over level>> swap rows-score swap [ + ] change-score ;
-: add-score ( tetris score -- )
- over tetris-score + swap set-tetris-score ;
+: add-rows ( tetris rows -- tetris )
+ swap [ + ] change-rows ;
: score-rows ( tetris n -- )
- 2dup >r dup tetris-level r> rows-score add-score
- over tetris-rows + swap set-tetris-rows ;
+ [ add-score ] keep add-rows drop ;
: lock-piece ( tetris -- )
- [ dup tetris-current-piece piece-blocks [ add-block ] with each ] keep
- dup new-current-piece dup check-rows score-rows ;
+ [ dup current-piece piece-blocks [ add-block ] with each ] keep
+ new-current-piece dup board>> check-rows score-rows ;
: can-rotate? ( tetris -- ? )
- dup tetris-current-piece clone dup 1 rotate-piece piece-valid? ;
+ [ board>> ] [ current-piece clone 1 rotate-piece ] bi piece-valid? ;
: (rotate) ( inc tetris -- )
- dup can-rotate? [ tetris-current-piece swap rotate-piece ] [ 2drop ] if ;
+ dup can-rotate? [ current-piece swap rotate-piece drop ] [ 2drop ] if ;
: rotate-left ( tetris -- ) -1 swap (rotate) ;
: rotate-right ( tetris -- ) 1 swap (rotate) ;
: can-move? ( tetris move -- ? )
- >r dup tetris-current-piece clone dup r> move-piece piece-valid? ;
+ [ drop board>> ] [ [ current-piece clone ] dip move-piece ] 2bi piece-valid? ;
: tetris-move ( tetris move -- ? )
#! moves the piece if possible, returns whether the piece was moved
2dup can-move? [
- >r tetris-current-piece r> move-piece t
+ [ current-piece ] dip move-piece drop t
] [
2drop f
] if ;
dup { 0 1 } tetris-move [ move-drop ] [ lock-piece ] if ;
: update ( tetris -- )
- millis over tetris-last-update -
- over tetris-update-interval > [
+ millis over last-update>> -
+ over update-interval > [
dup move-down
- millis swap set-tetris-last-update
- ] [ drop ] if ;
+ millis >>last-update
+ ] when drop ;
-: maybe-update ( tetris -- )
- dup tetris-paused? over tetris-running? not or [ drop ] [ update ] if ;
+: ?update ( tetris -- )
+ dup [ paused?>> ] [ running?>> not ] bi or [ drop ] [ update ] if ;