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
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433 | ;; ported-from: src/games/host/valley-blocks-engine.ts @ v1.3.0
;; (itself: game2/client/src/game/core/game.ts @ 25e6d79)
;; divergences: class renamed Game → ValleyBlocksEngine; the seed constructor
;; arg is REQUIRED (the browser defaulted to randomSeed()/Math.random — a
;; headless seat always plays a host-dealt round seed); the cosmetic
;; `startedAt = Date.now()` field is dropped.
;;
;; Everything else — gravity/lock/snake timing, scoring, SRS kicks, the seeded
;; snake schedule — is verbatim, so a board stepped here from the same seed and
;; inputs matches a browser's board. THE TWO RNG STREAMS ARE SEPARATE AND MUST
;; STAY SO: the bag draws from mulberry32(seed), the snake schedule from
;; mulberry32(seed ^ 0x5f356495), so duel players are offered snakes at the same
;; piece indices. Pinned by test/vectors/valley-blocks-core.json (three scripted
;; input traces snapshotting rev/score/lines/level/active/hold/ghostY/nextQueue/
;; snake/boardStateOf after EVERY input, the exact event-callback order, and
;; 160-176 snake episodes per seed).
(ns ardegazu.peer.games.host.valley-blocks-engine
(:require [ardegazu.peer.games.host.rng :refer (mulberry32)]
[ardegazu.peer.games.host.valley-blocks-core :as core]
[shadow.cljs.modern :refer (defclass)]))
(def ^:private LOCK-DELAY 0.5)
(def ^:private MAX-LOCK-RESETS 15)
(def ^:private SNAKE-DELTA
(js-obj "up" #js [0 -1] "down" #js [0 1] "left" #js [-1 0] "right" #js [1 0]))
(def ^:private SNAKE-OPPOSITE
(js-obj "up" "down" "down" "up" "left" "right" "right" "left"))
;; The snake is a rare bonus piece: a half-row-long line the player steers
;; freely (snake-game style) to weave into gaps until it gets stuck, time runs
;; out, or they commit with hard drop — then it freezes into normal blocks.
;; Its schedule is drawn from the seeded rng only.
(def ^:private SNAKE-LEN 5) ; half a row
(def ^:private SNAKE-MIN-GAP 6) ; minimum pieces between snakes
(def ^:private SNAKE-GAP-SPREAD 15) ; upper spread; quadratic skew keeps gaps short
(def ^:private SNAKE-TURBO 0.35) ; interval multiplier while soft drop is held
(declare draw-snake-gap spawn engine-end settle-after-lock lock-piece
reset-lock-delay try-shift maybe-spawn-snake update-snake steer-snake
step-snake snake-cell-free? snake-stuck? freeze-snake ghost-y)
(defn- ev
"Fire an optional EngineEvents callback (`events.onLock?.()`)."
[self k & args]
(let [f (unchecked-get (unchecked-get self "_events") k)]
(when ^boolean (js* "!!(~{})" f) (apply f args))
js/undefined))
(defclass ValleyBlocksEngine
(constructor [this seed events]
(unchecked-set this "_events" (if ^boolean (js* "~{} == null" events) (js-obj) events))
(unchecked-set this "board" (core/Board.))
(unchecked-set this "hold" nil)
(unchecked-set this "holdUsed" false)
(unchecked-set this "score" 0)
(unchecked-set this "lines" 0)
(unchecked-set this "level" 1)
(unchecked-set this "over" false)
(unchecked-set this "snake" nil)
;; Bumped whenever anything visible changes — lets a caller skip
;; re-serializing identical board states.
(unchecked-set this "rev" 0)
(unchecked-set this "_gravityTimer" 0)
(unchecked-set this "_lockTimer" 0)
(unchecked-set this "_grounded" false)
(unchecked-set this "_lockResets" 0)
(unchecked-set this "_softDropping" false)
(unchecked-set this "_snakeTimer" 0)
(unchecked-set this "_pieceCount" 0)
(unchecked-set this "seed" seed)
;; constructor order matters: bag first, then the snake stream, then the
;; first gap draw, then the first spawn (the TS field-initializer order)
(unchecked-set this "bag" (core/Bag. (mulberry32 seed)))
(unchecked-set this "_snakeRng" (mulberry32 (bit-xor seed 0x5f356495)))
(unchecked-set this "_nextSnakeAt" (draw-snake-gap this))
(unchecked-set this "active" (spawn this (core/bag-next (unchecked-get this "bag"))))))
(defn- draw-snake-gap [self]
(let [r ((unchecked-get self "_snakeRng"))]
(+ SNAKE-MIN-GAP (js/Math.floor (* SNAKE-GAP-SPREAD r r)))))
(defn- spawn [self type]
;; y = 1 puts the piece's bottom row on the first visible row.
(let [piece (js-obj "type" type "rotation" 0
"x" (js/Math.floor (/ (- core/COLS 4) 2)) "y" 1)]
(when (core/collides? (unchecked-get self "board") piece)
(unchecked-set piece "y" 0))
piece))
(defn next-queue [self]
(core/bag-peek (unchecked-get self "bag") 3))
(defn ghost-y [self]
(let [a (unchecked-get self "active")
board (unchecked-get self "board")
test (js/Object.assign (js-obj) a)]
(loop []
(let [probe (js/Object.assign (js-obj) test)]
(unchecked-set probe "y" (inc (unchecked-get test "y")))
(when-not (core/collides? board probe)
(unchecked-set test "y" (inc (unchecked-get test "y")))
(recur))))
(unchecked-get test "y")))
(defn engine-update [self dt]
(when-not (unchecked-get self "over")
(if (unchecked-get self "snake")
(update-snake self dt)
(let [board (unchecked-get self "board")
a (unchecked-get self "active")
below (js/Object.assign (js-obj) a)]
(unchecked-set below "y" (inc (unchecked-get a "y")))
(if (core/collides? board below)
(do
(when-not (unchecked-get self "_grounded")
(unchecked-set self "_grounded" true)
(unchecked-set self "_lockTimer" 0))
(unchecked-set self "_lockTimer" (+ (unchecked-get self "_lockTimer") dt))
(when (>= (unchecked-get self "_lockTimer") LOCK-DELAY) (lock-piece self)))
(do
(unchecked-set self "_grounded" false)
(let [soft (unchecked-get self "_softDropping")
interval (if soft
(js/Math.min (/ (core/gravity-seconds (unchecked-get self "level")) 20)
0.05)
(core/gravity-seconds (unchecked-get self "level")))]
(unchecked-set self "_gravityTimer" (+ (unchecked-get self "_gravityTimer") dt))
(loop []
(when (>= (unchecked-get self "_gravityTimer") interval)
(unchecked-set self "_gravityTimer"
(- (unchecked-get self "_gravityTimer") interval))
(when (try-shift self 0 1)
(when (unchecked-get self "_softDropping")
(unchecked-set self "score"
(+ (unchecked-get self "score") core/SOFT-DROP-POINTS)))
(recur))))))))))
js/undefined)
(defn set-soft-drop [self on]
(if (unchecked-get self "snake")
(do
;; Holding soft drop is the snake's turbo modifier.
(when on (steer-snake self "down"))
(when (unchecked-get self "snake")
(unchecked-set (unchecked-get self "snake") "turbo" on)))
(do
(when (and on (not (unchecked-get self "_softDropping")))
(unchecked-set self "_gravityTimer" 0))
(unchecked-set self "_softDropping" on)))
js/undefined)
(defn soft-step
"One row of soft drop, used by touch drag."
[self]
(cond
(unchecked-get self "over") false
(unchecked-get self "snake") (do (steer-snake self "down") true)
:else (let [moved (try-shift self 0 1)]
(when moved
(unchecked-set self "score" (+ (unchecked-get self "score") core/SOFT-DROP-POINTS))
(unchecked-set self "_gravityTimer" 0))
moved)))
(defn engine-move [self dir]
(cond
(unchecked-get self "over") false
(unchecked-get self "snake")
(do (steer-snake self (if (identical? dir -1) "left" "right")) true)
:else (let [moved (try-shift self dir 0)]
(when moved
(ev self "onMove")
(reset-lock-delay self))
moved)))
(defn engine-rotate [self cw]
(cond
(unchecked-get self "over") false
;; Rotate inputs (and taps) steer the snake upward.
(unchecked-get self "snake") (do (steer-snake self "up") true)
:else
(let [a (unchecked-get self "active")
from (unchecked-get a "rotation")
to (mod (+ from (if cw 1 3)) 4)
board (unchecked-get self "board")
kicks (core/kicks-for (unchecked-get a "type") from cw)
n (.-length kicks)]
(loop [i 0]
(if (>= i n)
false
(let [k (aget kicks i)
test (js/Object.assign (js-obj) a)]
(unchecked-set test "rotation" to)
(unchecked-set test "x" (+ (unchecked-get a "x") (aget k 0)))
(unchecked-set test "y" (+ (unchecked-get a "y") (aget k 1)))
(if (core/collides? board test)
(recur (inc i))
(do
(unchecked-set self "active" test)
(unchecked-set self "rev" (inc (unchecked-get self "rev")))
(ev self "onRotate")
(reset-lock-delay self)
true))))))))
(defn hard-drop [self]
(when-not (unchecked-get self "over")
(if (unchecked-get self "snake")
;; Hard drop commits the snake where it is.
(freeze-snake self)
(let [a (unchecked-get self "active")
gy (ghost-y self)
dist (- gy (unchecked-get a "y"))]
(unchecked-set a "y" gy)
(unchecked-set self "score" (+ (unchecked-get self "score")
(* dist core/HARD-DROP-POINTS)))
(ev self "onHardDrop")
(lock-piece self))))
js/undefined)
(defn hold-piece [self]
(cond
(unchecked-get self "over") false
;; Hold button / swipe up steers the snake upward.
(unchecked-get self "snake") (do (steer-snake self "up") true)
(unchecked-get self "holdUsed") false
:else
(let [current (unchecked-get (unchecked-get self "active") "type")
held (unchecked-get self "hold")]
(unchecked-set self "active"
(spawn self (if ^boolean (js* "~{} == null" held)
(core/bag-next (unchecked-get self "bag"))
held)))
(unchecked-set self "hold" current)
(unchecked-set self "holdUsed" true)
(unchecked-set self "rev" (inc (unchecked-get self "rev")))
(unchecked-set self "_grounded" false)
(unchecked-set self "_lockTimer" 0)
(unchecked-set self "_lockResets" 0)
(unchecked-set self "_gravityTimer" 0)
(ev self "onHold")
(when (core/collides? (unchecked-get self "board") (unchecked-get self "active"))
(engine-end self))
true)))
(defn- try-shift [self dx dy]
(let [a (unchecked-get self "active")
test (js/Object.assign (js-obj) a)]
(unchecked-set test "x" (+ (unchecked-get a "x") dx))
(unchecked-set test "y" (+ (unchecked-get a "y") dy))
(if (core/collides? (unchecked-get self "board") test)
false
(do
(unchecked-set self "active" test)
(unchecked-set self "rev" (inc (unchecked-get self "rev")))
true))))
(defn- reset-lock-delay [self]
(when (and (unchecked-get self "_grounded")
(< (unchecked-get self "_lockResets") MAX-LOCK-RESETS))
(unchecked-set self "_lockTimer" 0)
(unchecked-set self "_lockResets" (inc (unchecked-get self "_lockResets"))))
js/undefined)
(defn- lock-piece [self]
(let [a (unchecked-get self "active")
;; A piece locking entirely above the visible field is a top-out.
above-field (.every (core/cells-for (unchecked-get a "type") (unchecked-get a "rotation"))
(fn [o] (< (+ (unchecked-get a "y") (aget o 1)) core/HIDDEN-ROWS)))]
(core/board-lock (unchecked-get self "board") a)
(ev self "onLock")
(settle-after-lock self above-field true))
js/undefined)
(defn- settle-after-lock
"Shared post-lock flow: clear lines, score, top-out check, next piece."
[self above-field allow-snake]
(unchecked-set self "rev" (inc (unchecked-get self "rev")))
(let [cleared (core/clear-lines (unchecked-get self "board"))]
(when (pos? (.-length cleared))
(unchecked-set self "score"
(+ (unchecked-get self "score")
(core/points-for-lines (.-length cleared) (unchecked-get self "level"))))
(unchecked-set self "lines" (+ (unchecked-get self "lines") (.-length cleared)))
(let [new-level (core/level-for-lines (unchecked-get self "lines"))]
(ev self "onLinesCleared" (.-length cleared) cleared)
(when (> new-level (unchecked-get self "level"))
(unchecked-set self "level" new-level)
(ev self "onLevelUp" new-level)))))
(if (or above-field (core/topped-out? (unchecked-get self "board")))
(engine-end self)
(do
(unchecked-set self "holdUsed" false)
(unchecked-set self "_grounded" false)
(unchecked-set self "_lockTimer" 0)
(unchecked-set self "_lockResets" 0)
(unchecked-set self "_gravityTimer" 0)
(let [spawned-snake
(when allow-snake
(unchecked-set self "_pieceCount" (inc (unchecked-get self "_pieceCount")))
(when (>= (unchecked-get self "_pieceCount") (unchecked-get self "_nextSnakeAt"))
(unchecked-set self "_nextSnakeAt"
(+ (unchecked-get self "_pieceCount") (draw-snake-gap self)))
(maybe-spawn-snake self)))]
(when-not spawned-snake
(unchecked-set self "active" (spawn self (core/bag-next (unchecked-get self "bag"))))
(when (core/collides? (unchecked-get self "board") (unchecked-get self "active"))
(engine-end self))))))
js/undefined)
;; ---------- Snake bonus piece ----------
(defn- maybe-spawn-snake [self]
;; Enter vertically at the top center, head lowest, tail reaching into the
;; hidden rows. Length is half a row. Skipped (not rescheduled) if the entry
;; column is blocked.
(let [x (js/Math.floor (/ core/COLS 2))
segments #js []
grid (unchecked-get (unchecked-get self "board") "grid")]
(dotimes [i SNAKE-LEN] (.push segments #js [x (- SNAKE-LEN 1 i)]))
(if (.some segments (fn [s] (not (identical? 0 (aget (aget grid (aget s 1)) (aget s 0))))))
false
(let [duration (core/snake-duration (unchecked-get self "level"))]
(unchecked-set self "snake"
(js-obj "segments" segments "dir" "down"
"timeLeft" duration "duration" duration "turbo" false))
(unchecked-set self "rev" (inc (unchecked-get self "rev")))
(unchecked-set self "_snakeTimer" 0)
(ev self "onSnakeStart")
true))))
(defn- update-snake [self dt]
(let [s (unchecked-get self "snake")]
(unchecked-set s "timeLeft" (- (unchecked-get s "timeLeft") dt))
(if (<= (unchecked-get s "timeLeft") 0)
(freeze-snake self)
(let [interval (* (core/snake-interval (unchecked-get self "level"))
(if (unchecked-get s "turbo") SNAKE-TURBO 1))]
(unchecked-set self "_snakeTimer"
(js/Math.min (+ (unchecked-get self "_snakeTimer") dt) (* interval 3)))
(loop []
(when (and (>= (unchecked-get self "_snakeTimer") interval)
(unchecked-get self "snake"))
(unchecked-set self "_snakeTimer" (- (unchecked-get self "_snakeTimer") interval))
(if (step-snake self (unchecked-get s "dir"))
(recur)
;; Blocked ahead: freeze only when there is no way out at all,
;; otherwise wait for the player to steer.
(when (snake-stuck? self) (freeze-snake self))))))))
js/undefined)
(defn- steer-snake [self dir]
(let [s (unchecked-get self "snake")]
(when (and (some? s) (not (identical? s js/undefined)))
(when-not (identical? (unchecked-get SNAKE-OPPOSITE dir) (unchecked-get s "dir"))
(unchecked-set s "dir" dir)
;; Steering also steps immediately, so quick taps accelerate the snake.
(if (step-snake self dir)
(do (unchecked-set self "_snakeTimer" 0)
(ev self "onMove"))
(when (snake-stuck? self) (freeze-snake self))))))
js/undefined)
(defn- step-snake [self dir]
(let [s (unchecked-get self "snake")
d (unchecked-get SNAKE-DELTA dir)
head (aget (unchecked-get s "segments") 0)
nx (+ (aget head 0) (aget d 0))
ny (+ (aget head 1) (aget d 1))]
(if-not (snake-cell-free? self nx ny)
false
(let [segs (unchecked-get s "segments")]
(.pop segs)
(.unshift segs #js [nx ny])
(unchecked-set self "rev" (inc (unchecked-get self "rev")))
true))))
(defn- snake-cell-free? [self x y]
(let [grid (unchecked-get (unchecked-get self "board") "grid")]
(cond
(or (< x 0) (>= x core/COLS) (< y 0) (>= y core/TOTAL-ROWS)) false
(not (identical? 0 (aget (aget grid y) x))) false
:else
;; The tail cell vacates as the head advances, so exclude it.
(let [body (.slice (unchecked-get (unchecked-get self "snake") "segments") 0 -1)]
(not (.some body (fn [b] (and (identical? (aget b 0) x) (identical? (aget b 1) y)))))))))
(defn- snake-stuck? [self]
(let [head (aget (unchecked-get (unchecked-get self "snake") "segments") 0)
hx (aget head 0)
hy (aget head 1)]
(.every #js ["up" "down" "left" "right"]
(fn [dir]
(let [d (unchecked-get SNAKE-DELTA dir)]
(not (snake-cell-free? self (+ hx (aget d 0)) (+ hy (aget d 1)))))))))
(defn- freeze-snake [self]
(let [s (unchecked-get self "snake")]
(when (and (some? s) (not (identical? s js/undefined)))
(let [segs (unchecked-get s "segments")
above-field (.every segs (fn [seg] (< (aget seg 1) core/HIDDEN-ROWS)))
grid (unchecked-get (unchecked-get self "board") "grid")]
(.forEach segs (fn [seg] (aset (aget grid (aget seg 1)) (aget seg 0) "N")))
(unchecked-set self "snake" nil)
(unchecked-set self "_snakeTimer" 0)
(ev self "onSnakeEnd")
(settle-after-lock self above-field false))))
js/undefined)
(defn- engine-end [self]
(when-not (unchecked-get self "over")
(unchecked-set self "over" true)
(unchecked-set self "rev" (inc (unchecked-get self "rev")))
(ev self "onGameOver"))
js/undefined)
;; string-named getters (rename-safe) + prototype methods: the surface TS
;; consumers and the brain use
(let [proto (.-prototype ValleyBlocksEngine)]
(js/Object.defineProperty proto "nextQueue"
#js {:get (fn [] (this-as self (next-queue self)))
:configurable true})
(js/Object.defineProperty proto "ghostY"
#js {:get (fn [] (this-as self (ghost-y self)))
:configurable true})
(unchecked-set proto "update" (fn [dt] (this-as self (engine-update self dt))))
(unchecked-set proto "setSoftDrop" (fn [on] (this-as self (set-soft-drop self on))))
(unchecked-set proto "softStep" (fn [] (this-as self (soft-step self))))
(unchecked-set proto "move" (fn [dir] (this-as self (engine-move self dir))))
(unchecked-set proto "rotate" (fn [cw] (this-as self (engine-rotate self cw))))
(unchecked-set proto "hardDrop" (fn [] (this-as self (hard-drop self))))
(unchecked-set proto "holdPiece" (fn [] (this-as self (hold-piece self)))))
|