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 combinators.short-circuit kernel
   4 math sequences tetris.piece ;
   5 IN: tetris.board
   6
   7 TUPLE: board
   8     { width integer }
   9     { height integer }
  10     { rows array } ;
  11
  12 : make-rows ( width height -- rows )
  13     swap '[ _ f <array> ] replicate ;
  14
  15 : <board> ( width height -- board )
  16     2dup make-rows board boa ;
  17
  18 ! A block is simply an array of form { x y } where { 0 0 } is
  19 ! the top-left of the tetris board, and { 9 19 } is the bottom
  20 ! right on a 10x20 board.
  21
  22 : board@block ( board block -- n row )
  23     [ second swap rows>> nth ] keep first swap ;
  24
  25 : set-block ( board block color -- ) -rot board@block set-nth ;
  26
  27 : block ( board block -- color ) board@block nth ;
  28
  29 : block-free? ( board block -- ? ) block not ;
  30
  31 : block-in-bounds? ( board block -- ? )
  32     [ first swap width>> <iota> bounds-check? ]
  33     [ second swap height>> <iota> bounds-check? ] 2bi and ;
  34
  35 : location-valid? ( board block -- ? )
  36     { [ block-in-bounds? ] [ block-free? ] } 2&& ;
  37
  38 : piece-valid? ( board piece -- ? )
  39     piece-blocks [ location-valid? ] with all? ;
  40
  41 : row-not-full? ( row -- ? ) f swap member? ;
  42
  43 : add-row ( board -- board )
  44     dup rows>> over width>> f <array> prefix >>rows ;
  45
  46 : top-up-rows ( board -- )
  47     dup height>> over rows>> length = [
  48         drop
  49     ] [
  50         add-row top-up-rows
  51     ] if ;
  52
  53 : remove-full-rows ( board -- board )
  54     [ [ row-not-full? ] filter ] change-rows ;
  55
  56 : check-rows ( board -- n )
  57     ! remove full rows, then add blank ones at the top,
  58     ! returning the number of rows removed (and added)
  59     remove-full-rows dup height>> over rows>> length - swap top-up-rows ;