extra/gamelib/board/board.factor

   1 USING: assocs classes sequences sequences.generalizations math
   2 timers sets kernel accessors sequences.extras ranges
   3 math.vectors generalizations strings prettyprint gamelib.loop
   4 ui.gadgets ;
   5
   6 IN: gamelib.board
   7
   8 TUPLE: board width height cells ;
   9
  10
  11 CONSTANT: UP { 0 -1 }
  12 CONSTANT: DOWN { 0 1 }
  13 CONSTANT: RIGHT { 1 0 }
  14 CONSTANT: LEFT { -1 0 }
  15
  16 ! Make cells, with an empty sequence as the default cell
  17 :: make-cells ( width height -- cells )
  18     height [ width [ { } clone ] replicate ] replicate ;
  19
  20 :: make-board ( width height -- board )
  21     width height make-cells :> cells
  22     width height cells board boa ;
  23
  24 ! Sets all cells to an empty sequence
  25 :: reset-board ( board -- board )
  26     board width>> board height>> make-board ;
  27
  28 :: get-cell ( board location -- cell )
  29     location first2 :> ( x y )
  30     board cells>> :> cells
  31     x y cells nth nth ;
  32
  33 ! Gets all cells in locations array and return as a sequence
  34 :: get-cells ( board locations -- seq )
  35     locations [ board swap get-cell ] map ;
  36
  37 :: get-instance-from-cell ( cell class -- object )
  38     cell [ class instance? ] find swap drop ;
  39
  40 ! returns all elements of a specified row as a seq
  41 :: get-row ( board index -- seq )
  42     index board cells>> nth ;
  43
  44 ! returns all elements of a specified column as a seq
  45 :: get-col ( board index -- seq )
  46     board
  47     board height>> [ index ] replicate
  48     board height>> [0..b) zip
  49     get-cells ;
  50
  51 ! For a board, set the cell at the given location to new-cell (should be a sequence)
  52 :: set-cell ( board location new-cell -- board )
  53     location first2 :> ( x y )
  54     board cells>> :> cells
  55     new-cell sequence? new-cell string? not and
  56     [
  57         new-cell x y cells nth set-nth
  58     ]
  59     [ "New cell is not a sequence! No changes made." . ] if
  60     board ;
  61
  62 ! For a board, set all the given locations to a new cell (should be a sequence)
  63 :: set-cells ( board locations new-cell -- board )
  64     locations [ board swap new-cell set-cell drop ] each
  65     board ;
  66
  67 ! Applies a quotation to a specific cell
  68 :: change-cell ( board location quot -- board )
  69     location first2 :> ( x y )
  70     board cells>> :> cells
  71     x y cells nth quot change-nth
  72     board ; inline
  73
  74 ! Adds an object to the cell at the specified location in a board
  75 :: add-to-cell ( board location obj -- board )
  76     board cells>> :> cells
  77     board location get-cell :> old-cell
  78     old-cell { obj } append :> new-cell
  79     board location new-cell set-cell ;
  80
  81 ! Adds an object to all the given locations to new-cell
  82 :: add-to-cells ( board locations obj -- board )
  83     locations [ board swap obj add-to-cell drop ] each
  84     board ;
  85
  86 ! Adds a copy of an object to all the given locations to new-cell
  87 :: add-copy-to-cells ( board locations obj -- board )
  88     locations [ board swap obj clone add-to-cell drop ] each
  89     board ;
  90
  91 ! Sets a cell back to the default cell
  92 :: delete-cell ( board location -- board )
  93     board location { } set-cell ;
  94
  95 ! Delete the first instance of obj in the cell at the specified location in the board (if found)
  96 :: delete-from-cell ( board location obj -- board )
  97     board location get-cell :> cell
  98     cell [ obj = ] find drop :> obj-index
  99     obj-index
 100     [
 101         obj-index cell remove-nth :> new-cell
 102         board location new-cell set-cell
 103     ] [
 104         board
 105     ] if ;
 106
 107 ! Delete the first instance of obj from all cells at the specified locations in the board (if found)
 108 :: delete-from-cells ( board locations obj -- board )
 109     locations [ board swap obj delete-from-cell drop ] each
 110     board ;
 111
 112 ! Like delete-from-cell, but delete all instances of obj (if found)
 113 :: delete-all-from-cell ( board location obj -- board )
 114     board location [ obj swap remove ] change-cell ;
 115
 116 ! Like delete-all-from-cell, but deletes from all specified locations in the board (if found)
 117 :: delete-all-from-cells ( board locations obj -- board )
 118     locations [ board swap obj delete-all-from-cell drop ] each
 119     board ;
 120
 121 ! Helper word that creates a sequence of n k's
 122 :: make-n-k ( n k -- seq )
 123     n [ k ] replicate ;
 124
 125 ! Helper word that creates a list of all cell locations in the board
 126 :: location-matrix ( board -- loclist )
 127     board width>> :> w
 128     board height>> :> h
 129     w [0..b) :> single-row
 130     h [0..b) :> single-col
 131     h [ single-row ] replicate concat :> x-vals
 132     h [ w ] replicate :> w-list
 133     w-list single-col [ make-n-k ] 2map concat :> y-vals
 134     x-vals y-vals zip ;
 135
 136 ! Sets all cells to a given sequence
 137 :: set-all ( board seq -- board )
 138     board location-matrix :> loclist
 139     board loclist seq set-cells ;
 140
 141 ! Deletes all instances of obj from all cells (if found)
 142 :: delete-from-all ( board obj -- board )
 143     board location-matrix :> loclist
 144     board loclist obj delete-all-from-cells ;
 145
 146 :: duplicate-cell ( board start dest -- board )
 147     board dup start get-cell dest swap set-cell ;
 148
 149 ! Moves an entire cell if it can be moved to a new destination, leaving the original cell empty
 150 :: move-entire-cell ( board start dest -- board )
 151     ! bound checking
 152     { start dest } [ first board width>> < ] all?
 153     { start dest } [ second board height>> < ] all? and
 154     start [ 0 >= ] all? and
 155     dest [ 0 >= ] all? and
 156     ! move cell
 157     [ board start dest duplicate-cell
 158     start delete-cell drop ] when
 159     board ;
 160
 161 ! Move an object from a cell, relative to its original cell
 162 :: move-object ( board object-pos move object -- board )
 163     object-pos move v+ :> dest
 164     { object-pos dest } [ first board width>> < ] all?
 165     { object-pos dest } [ second board height>> < ] all? and
 166     object-pos [ 0 >= ] all? and
 167     dest [ 0 >= ] all? and
 168     [ board object-pos object delete-from-cell
 169     dest object add-to-cell drop ] when
 170     board ;
 171
 172 ! Move a specified object in many cells to different locations
 173 :: move-objects ( board start dest object -- board )
 174     board start object delete-from-cells
 175     dest object add-to-cells ;
 176
 177 :: move-many-objects ( board start dest objects -- board )
 178     board objects [ start swap dest swap move-objects ] each ;
 179
 180 ! move a cell with a move relative to its start
 181 :: move-entire-cell-rel ( board start move -- board )
 182     board start start move v+ move-entire-cell ;
 183
 184 ! move cells of a parent (only works when cells are all the same)
 185 :: move-cells ( board start dest -- board )
 186     board start first get-cell :> cell
 187     board start [ delete-cell ] each
 188     dest cell set-cells ;
 189
 190 :: swap-cells ( board loc1 loc2 -- board )
 191     board loc1 get-cell :> cell1
 192     board loc2 get-cell :> cell2
 193     board loc2 cell1 set-cell
 194     loc1 cell2 set-cell ;
 195
 196 ! Returns true if cell at location is the default cell
 197 :: is-cell-empty? ( board location -- ? )
 198     board location get-cell { } = ;
 199
 200 :: is-board-empty? ( board -- ? )
 201     board cells>> [ [ { } = ] all? ] all? ;
 202
 203 ! Return index and row that contains the first cell that satisfies the quot
 204 :: find-row ( board quot -- index row )
 205     board cells>> [ [ quot find drop ] find drop ] find ; inline
 206
 207 ! Return first location and cell that satisfies the quot
 208 :: find-cell ( board quot -- seq cell )
 209     board quot find-row swap :> y
 210     [ quot find drop ] find swap :> x
 211     { x y } swap ; inline
 212
 213 ! Return first cell that satisfies the quot
 214 :: find-cell-nopos ( board quot -- cell )
 215     board cells>> [ quot find swap drop ] map-find drop ; inline
 216
 217 : find-cell-pos ( board quot -- seq )
 218     find-cell drop ; inline
 219
 220 ! Returns a vector containing index row pairs
 221 :: find-all-rows ( board quot -- index row )
 222     board cells>> [ quot find swap drop ] find-all ; inline
 223
 224 : is-empty? ( cell -- ?  )
 225     { } = ;
 226
 227 : cell-contains? ( cell object -- ? )
 228     swap in? ;
 229
 230 :: cell-only-contains? ( cell object -- ? )
 231     cell length 1 =
 232     cell object cell-contains? and ;
 233
 234 :: cell-contains-instance? ( cell class -- ? )
 235     cell [ class instance? ] any? ;
 236
 237 :: cell-only-contains-instance? ( cell class -- ? )
 238     cell length 1 =
 239     cell class cell-contains-instance? and ;
 240
 241 ! Helper function that formats a position cell pair
 242 :: label-cell ( x cell y -- seq )
 243     { { x y } cell } ;
 244
 245 ! Helper function that finds all cells in an given row that satisfy the quot
 246 :: row-to-cells ( seq quot -- cells )
 247     seq first2 :> ( y row )
 248     row quot find-all :> indexed-cells
 249     indexed-cells [ first2 y label-cell ] map ; inline
 250
 251 ! Return a vector of position cell pairs of all cells in the board that satisfy the quot
 252 :: find-all-cells ( board quot -- assoc )
 253     board quot find-all-rows :> row-list ! find-all - returns vector w/ index/elt
 254     row-list [ quot row-to-cells ] map concat ; inline
 255
 256 :: find-all-cells-nopos ( board quot -- assoc )
 257     board quot find-all-cells [ second ] map ; inline
 258
 259 :: all-equal-value? ( value seq -- ? )
 260     seq [ value = ] all? ;