1 ! Copyright (C) 2006, 2007 Alex Chapman
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel sequences arrays tetris.piece math ;
6 TUPLE: board width height rows ;
8 : make-rows ( width height -- rows )
9 [ drop f <array> ] with map ;
11 : <board> ( width height -- board )
12 2dup make-rows board construct-boa ;
14 #! A block is simply an array of form { x y } where { 0 0 } is the top-left of
15 #! the tetris board, and { 9 19 } is the bottom right on a 10x20 board.
17 : board@block ( board block -- n row )
18 [ second swap board-rows nth ] keep first swap ;
20 : board-set-block ( board block colour -- ) -rot board@block set-nth ;
22 : board-block ( board block -- colour ) board@block nth ;
24 : block-free? ( board block -- ? ) board-block not ;
26 : block-in-bounds? ( board block -- ? )
27 [ first swap board-width bounds-check? ] 2keep
28 second swap board-height bounds-check? and ;
30 : location-valid? ( board block -- ? )
31 2dup block-in-bounds? [ block-free? ] [ 2drop f ] if ;
33 : piece-valid? ( board piece -- ? )
34 piece-blocks [ location-valid? ] with all? ;
36 : row-not-full? ( row -- ? ) f swap member? ;
38 : add-row ( board -- )
39 dup board-rows over board-width f <array>
40 prefix swap set-board-rows ;
42 : top-up-rows ( board -- )
43 dup board-height over board-rows length = [
46 dup add-row top-up-rows
49 : remove-full-rows ( board -- )
50 dup board-rows [ row-not-full? ] subset swap set-board-rows ;
52 : check-rows ( board -- n )
53 #! remove full rows, then add blank ones at the top, returning the number
54 #! of rows removed (and added)
55 dup remove-full-rows dup board-height over board-rows length - >r top-up-rows r> ;