contrib/tetris/tetris-board.factor

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