1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346 | ;; ported-from: src/games/valley-blocks-brain.ts @ v1.3.0
;;
;; The valley-blocks placement brain shared by the live client and the gym:
;; candidate enumeration (every rotation × column reachable by a straight
;; top-down hard drop, plus the hold branch), afterstate board metrics, the
;; classic Dellacherie hand-tuned linear policy as the stock brain, and the
;; scripted steering for the snake bonus piece.
;;
;; Everything here is pure over an engine snapshot, and the SAME code computes
;; candidates for gym self-play and live rooms — that is what lets a policy
;; trained offline plug into onPiece unchanged. No tucks or spins in v1:
;; placements a straight drop can't reach are not offered, and the executor's
;; verify-as-you-go fallback covers the rare mismatch at panic heights.
;;
;; The RL trainer's feature basis is `boardMetrics`, and its baseline is
;; `stockPick`/`dellacherieScore` — so every field, every weight and the
;; first-max tie rule are pinned by test/vectors/valley-blocks-brain.json,
;; including 36 full candidate sets (each candidate's afterstate grid by
;; SHA-256) and four 400-placement stock games.
(ns ardegazu.peer.games.valley-blocks-brain
(:require [ardegazu.peer.obj :as obj]
[ardegazu.peer.games.host.valley-blocks-core :as core]
[ardegazu.peer.games.host.valley-blocks-engine :as engine]))
;; Rotation states with distinct silhouettes (mirrors SHAPES symmetry).
(def ^:private DISTINCT-ROTATIONS
(js-obj "I" #js [0 1]
"O" #js [0]
"T" #js [0 1 2 3]
"S" #js [0 1]
"Z" #js [0 1]
"J" #js [0 1 2 3]
"L" #js [0 1 2 3]))
(defn- occ-of [eng]
(let [occ (js/Uint8Array. (* core/TOTAL-ROWS core/COLS))
grid (unchecked-get (unchecked-get eng "board") "grid")]
(dotimes [y core/TOTAL-ROWS]
(let [row (aget grid y)]
(dotimes [x core/COLS]
(when-not (identical? 0 (aget row x))
(aset occ (+ (* y core/COLS) x) 1)))))
occ))
(defn- occ-collides? [occ type rotation px py]
(let [offs (core/cells-for type rotation)
n (.-length offs)]
(loop [i 0]
(if (>= i n)
false
(let [o (aget offs i)
x (+ px (aget o 0))
y (+ py (aget o 1))]
(cond
(or (< x 0) (>= x core/COLS) (>= y core/TOTAL-ROWS)) true
(and (>= y 0) (identical? 1 (aget occ (+ (* y core/COLS) x)))) true
:else (recur (inc i))))))))
(defn- enumerate-for [occ type use-hold]
(let [out #js []
rotations (unchecked-get DISTINCT-ROTATIONS type)]
(.forEach
rotations
(fn [rotation]
(let [offs (core/cells-for type rotation)]
;; min/max dx of the silhouette, seeded exactly as the TS original
;; (minDx = 3, maxDx = 0) so the column range matches
(let [min-dx (volatile! 3)
max-dx (volatile! 0)]
(.forEach offs (fn [o]
(let [dx (aget o 0)]
(when (< dx @min-dx) (vreset! min-dx dx))
(when (> dx @max-dx) (vreset! max-dx dx)))))
(loop [x (- @min-dx)]
(when (<= x (- core/COLS 1 @max-dx))
;; engine spawn parity: y = 1, falling back to 0 when 1 collides
(let [y0 (if-not (occ-collides? occ type rotation x 1)
1
(if (occ-collides? occ type rotation x 0) nil 0))]
(when (some? y0)
(let [y (loop [y y0]
(if (occ-collides? occ type rotation x (inc y)) y (recur (inc y))))
after (js/Uint8Array. occ)
lowest (volatile! 0)]
(.forEach offs
(fn [o]
(let [cy (+ y (aget o 1))]
(when (>= cy 0)
(aset after (+ (* cy core/COLS) x (aget o 0)) 1))
(when (> cy @lowest) (vreset! lowest cy)))))
;; full rows → cleared count + eroded piece cells, then collapse
(let [cleared-rows #js []]
(dotimes [ry core/TOTAL-ROWS]
(let [full (loop [cx 0]
(cond
(>= cx core/COLS) true
(identical? 0 (aget after (+ (* ry core/COLS) cx))) false
:else (recur (inc cx))))]
(when full (.push cleared-rows ry))))
(let [eroded (volatile! 0)]
(when (pos? (.-length cleared-rows))
(.forEach offs
(fn [o]
(when (>= (.indexOf cleared-rows (+ y (aget o 1))) 0)
(vswap! eroded inc))))
(vreset! eroded (* @eroded (.-length cleared-rows)))
(.forEach cleared-rows
(fn [ry]
(.copyWithin after core/COLS 0 (* ry core/COLS))
(.fill after 0 0 core/COLS))))
;; VBCandidate: 7 keys, literal order safe, and the
;; ORDER is part of the contract (a policy may read
;; Object.values) — pinned by the gym view-parity test
(.push out (js-obj "useHold" use-hold
"rotation" rotation
"x" x
"cleared" (.-length cleared-rows)
"landingRow" (- core/TOTAL-ROWS 1 @lowest)
"erodedCells" @eroded
"grid" after))))))
;; `continue` (unreachable column) and the normal step both
;; land here, so x advances exactly once per iteration
(recur (inc x)))))))))
out))
(defn enumerate-placements
"Every placement of the active piece, plus the hold branch when holding is
available and would bring in a different type. Empty only when nothing fits
anywhere (the board is effectively topped out)."
[eng]
(if (or (unchecked-get eng "over") (unchecked-get eng "snake"))
#js []
(let [occ (occ-of eng)
active-type (unchecked-get (unchecked-get eng "active") "type")
out (enumerate-for occ active-type false)]
(when-not (unchecked-get eng "holdUsed")
(let [held (unchecked-get eng "hold")
swapped (if ^boolean (js* "~{} == null" held)
(aget (engine/next-queue eng) 0)
held)]
(when (and ^boolean (js* "!!(~{})" swapped)
(not (identical? swapped active-type)))
(.apply (.-push out) out (enumerate-for occ swapped true)))))
out)))
(defn board-metrics
"Board-shape metrics of an occupancy grid (the feature basis). Eight keys —
past the js-obj literal limit, so built with sequential sets; the RL feature
vector is read positionally by some policies, so the order is load-bearing."
[grid]
(let [heights (.fill (js/Array. core/COLS) 0)
holes (volatile! 0)]
(dotimes [x core/COLS]
(let [top (loop [y 0]
(cond
(>= y core/TOTAL-ROWS) -1
(identical? 1 (aget grid (+ (* y core/COLS) x))) y
:else (recur (inc y))))]
(when (>= top 0)
(aset heights x (- core/TOTAL-ROWS top))
(loop [y (inc top)]
(when (< y core/TOTAL-ROWS)
(when (identical? 0 (aget grid (+ (* y core/COLS) x))) (vswap! holes inc))
(recur (inc y)))))))
(let [aggregate (volatile! 0)
max-h (volatile! 0)
bump (volatile! 0)]
(dotimes [x core/COLS]
(vswap! aggregate + (aget heights x))
(when (> (aget heights x) @max-h) (vreset! max-h (aget heights x)))
(when (> x 0) (vswap! bump + (js/Math.abs (- (aget heights x) (aget heights (dec x)))))))
(let [wells (volatile! 0)]
(dotimes [x core/COLS]
(let [depth (volatile! 0)]
(dotimes [y core/TOTAL-ROWS]
(if (identical? 1 (aget grid (+ (* y core/COLS) x)))
(vreset! depth 0)
(let [left-filled (or (identical? x 0)
(identical? 1 (aget grid (+ (* y core/COLS) x -1))))
right-filled (or (identical? x (dec core/COLS))
(identical? 1 (aget grid (+ (* y core/COLS) x 1))))]
(if (and left-filled right-filled)
(do (vswap! depth inc) (vswap! wells + @depth))
(vreset! depth 0)))))))
(let [row-t (volatile! 0)]
(dotimes [y core/TOTAL-ROWS]
(let [prev (volatile! 1)] ; left wall
(dotimes [x core/COLS]
(let [c (aget grid (+ (* y core/COLS) x))]
(when-not (identical? c @prev) (vswap! row-t inc))
(vreset! prev c)))
(when-not (identical? @prev 1) (vswap! row-t inc)))) ; right wall
(let [col-t (volatile! 0)]
(dotimes [x core/COLS]
(let [prev (volatile! 0)] ; open sky above the hidden rows
(dotimes [y core/TOTAL-ROWS]
(let [c (aget grid (+ (* y core/COLS) x))]
(when-not (identical? c @prev) (vswap! col-t inc))
(vreset! prev c)))
(when-not (identical? @prev 1) (vswap! col-t inc)))) ; floor
(obj/ordered "heights" heights
"aggregateHeight" @aggregate
"maxHeight" @max-h
"holes" @holes
"bumpiness" @bump
"wells" @wells
"rowTransitions" @row-t
"colTransitions" @col-t)))))))
(defn dellacherie-score
"Dellacherie's hand-tuned evaluation — the stock brain and the gate baseline."
[c]
(let [m (board-metrics (unchecked-get c "grid"))]
(+ (- (* -1.0 (unchecked-get c "landingRow"))
(* 1.0 (unchecked-get m "rowTransitions"))
(* 1.0 (unchecked-get m "colTransitions"))
(* 4.0 (unchecked-get m "holes"))
(* 1.0 (unchecked-get m "wells")))
(* 1.0 (unchecked-get c "erodedCells")))))
(defn stock-pick
"Argmax over dellacherieScore, first max on ties. -1 when no candidates."
[candidates]
(let [best (volatile! -1)
best-score (volatile! js/-Infinity)
n (.-length ^js candidates)]
(dotimes [i n]
(let [s (dellacherie-score (aget candidates i))]
(when (> s @best-score)
(vreset! best-score s)
(vreset! best i))))
@best))
(defn plan-of
"A chosen placement being executed input-by-input: #js {:useHold :rotation :x}."
[c]
(js-obj "useHold" (unchecked-get c "useHold")
"rotation" (unchecked-get c "rotation")
"x" (unchecked-get c "x")))
(defn placement-step
"Issue ONE input toward the plan: hold, then the shortest rotation path, then
horizontal steps, then the committing hard drop. Returns \"done\" once the
piece is locked (or the plan hit something and dropped where it was — the
verify-as-you-go fallback for unreachable placements). The live client paces
calls; the gym loops them synchronously — same code, same outcome.
`plan.useHold` is CLEARED IN PLACE on the first call, exactly as the TS
original does: the caller holds one mutable plan across the whole placement."
[eng plan]
(cond
(or (unchecked-get eng "over") (unchecked-get eng "snake")) "done"
(unchecked-get plan "useHold")
(do
(unchecked-set plan "useHold" false)
(if-not (engine/hold-piece eng)
(do (engine/hard-drop eng) "done")
"continue"))
(not (identical? (unchecked-get (unchecked-get eng "active") "rotation")
(unchecked-get plan "rotation")))
(let [diff (mod (+ (mod (- (unchecked-get plan "rotation")
(unchecked-get (unchecked-get eng "active") "rotation"))
4)
4)
4)]
(if-not (engine/engine-rotate eng (not (identical? diff 3)))
(do (engine/hard-drop eng) "done")
"continue"))
(not (identical? (unchecked-get (unchecked-get eng "active") "x") (unchecked-get plan "x")))
(if-not (engine/engine-move eng (if (< (unchecked-get (unchecked-get eng "active") "x")
(unchecked-get plan "x"))
1 -1))
(do (engine/hard-drop eng) "done")
"continue")
:else (do (engine/hard-drop eng) "done")))
(defn execute-placement
"Run a plan to completion synchronously (the gym path)."
[eng c]
(let [plan (plan-of c)
guard (volatile! 0)]
(loop []
(when (and (identical? "continue" (placement-step eng plan))
(< @guard 40))
(vswap! guard inc)
(recur))))
js/undefined)
(defn snake-step
"One scripted steering step for the snake bonus piece: weave downward, else
toward the lower side, and commit when boxed in. Call once per engine tick
while `engine.snake` is set (live), or in a bounded loop (gym). The learned
policy never sees the snake — its points fold into the next decision's score
delta."
[eng]
(let [s (unchecked-get eng "snake")]
(when ^boolean (js* "!!(~{})" s)
(let [grid (unchecked-get (unchecked-get eng "board") "grid")
body (js/Set.)]
(.forEach (.slice (unchecked-get s "segments") 0 -1)
(fn [seg] (.add body (+ (* (aget seg 1) core/COLS) (aget seg 0)))))
(let [free? (fn [x y]
(and (>= x 0) (< x core/COLS) (>= y 0) (< y core/TOTAL-ROWS)
(identical? 0 (aget (aget grid y) x))
(not (.has body (+ (* y core/COLS) x)))))
head (aget (unchecked-get s "segments") 0)
hx (aget head 0)
hy (aget head 1)]
(if (free? hx (inc hy))
(do (engine/soft-step eng) js/undefined) ; steer/step down
(let [left-free (free? (dec hx) hy)
right-free (free? (inc hx) hy)]
(if (and (not left-free) (not right-free))
;; boxed in sideways — commit rather than climb
(do (engine/hard-drop eng) js/undefined)
(let [col-height (fn [x]
(loop [y 0]
(cond
(>= y core/TOTAL-ROWS) 0
(not (identical? 0 (aget (aget grid y) x)))
(- core/TOTAL-ROWS y)
:else (recur (inc y)))))
dir (if (and left-free right-free)
(if (<= (col-height (dec hx)) (col-height (inc hx))) -1 1)
(if left-free -1 1))]
(engine/engine-move eng dir)
;; a refused reversal (steering into the body) leaves the head
;; in place — try the other side once, else commit
(let [snake (unchecked-get eng "snake")]
(when (and ^boolean (js* "!!(~{})" snake)
(identical? (aget (aget (unchecked-get snake "segments") 0) 0) hx)
(identical? (aget (aget (unchecked-get snake "segments") 0) 1) hy))
(let [other (if (identical? dir -1) 1 -1)]
(when (if (identical? other -1) left-free right-free)
(engine/engine-move eng other))
(let [snake2 (unchecked-get eng "snake")]
(when (and ^boolean (js* "!!(~{})" snake2)
(identical? (aget (aget (unchecked-get snake2 "segments") 0) 0) hx)
(identical? (aget (aget (unchecked-get snake2 "segments") 0) 1) hy))
(engine/hard-drop eng))))))
js/undefined))))))))
js/undefined)
|