extra/tetris/board/board.factor

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