1 USING: assocs classes sequences sequences.generalizations math
2 timers sets kernel accessors sequences.extras ranges
3 math.vectors generalizations strings prettyprint gamelib.loop
8 TUPLE: board width height cells ;
12 CONSTANT: DOWN { 0 1 }
13 CONSTANT: RIGHT { 1 0 }
14 CONSTANT: LEFT { -1 0 }
16 ! Make cells, with an empty sequence as the default cell
17 :: make-cells ( width height -- cells )
18 height [ width [ { } clone ] replicate ] replicate ;
20 :: make-board ( width height -- board )
21 width height make-cells :> cells
22 width height cells board boa ;
24 ! Sets all cells to an empty sequence
25 :: reset-board ( board -- board )
26 board width>> board height>> make-board ;
28 :: get-cell ( board location -- cell )
29 location first2 :> ( x y )
30 board cells>> :> cells
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 ;
37 :: get-instance-from-cell ( cell class -- object )
38 cell [ class instance? ] find swap drop ;
40 ! returns all elements of a specified row as a seq
41 :: get-row ( board index -- seq )
42 index board cells>> nth ;
44 ! returns all elements of a specified column as a seq
45 :: get-col ( board index -- seq )
47 board height>> [ index ] replicate
48 board height>> [0..b) zip
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
57 new-cell x y cells nth set-nth
59 [ "New cell is not a sequence! No changes made." . ] if
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
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
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 ;
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
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
91 ! Sets a cell back to the default cell
92 :: delete-cell ( board location -- board )
93 board location { } set-cell ;
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
101 obj-index cell remove-nth :> new-cell
102 board location new-cell set-cell
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
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 ;
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
121 ! Helper word that creates a sequence of n k's
122 :: make-n-k ( n k -- seq )
125 ! Helper word that creates a list of all cell locations in the board
126 :: location-matrix ( board -- loclist )
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
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 ;
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 ;
146 :: duplicate-cell ( board start dest -- board )
147 board dup start get-cell dest swap set-cell ;
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 )
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
157 [ board start dest duplicate-cell
158 start delete-cell drop ] when
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
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 ;
177 :: move-many-objects ( board start dest objects -- board )
178 board objects [ start swap dest swap move-objects ] each ;
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 ;
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 ;
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 ;
196 ! Returns true if cell at location is the default cell
197 :: is-cell-empty? ( board location -- ? )
198 board location get-cell { } = ;
200 :: is-board-empty? ( board -- ? )
201 board cells>> [ [ { } = ] all? ] all? ;
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
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
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
217 : find-cell-pos ( board quot -- seq )
218 find-cell drop ; inline
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
224 : is-empty? ( cell -- ? )
227 : cell-contains? ( cell object -- ? )
230 :: cell-only-contains? ( cell object -- ? )
232 cell object cell-contains? and ;
234 :: cell-contains-instance? ( cell class -- ? )
235 cell [ class instance? ] any? ;
237 :: cell-only-contains-instance? ( cell class -- ? )
239 cell class cell-contains-instance? and ;
241 ! Helper function that formats a position cell pair
242 :: label-cell ( x cell y -- seq )
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
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
256 :: find-all-cells-nopos ( board quot -- assoc )
257 board quot find-all-cells [ second ] map ; inline
259 :: all-equal-value? ( value seq -- ? )
260 seq [ value = ] all? ;