Add block pushing and wireworld simulation.

This commit is contained in:
David Thompson 2024-05-18 14:04:35 -04:00
parent b9f9e81381
commit a34a7e9b7a
12 changed files with 379 additions and 39 deletions

View file

@ -6,6 +6,7 @@ modules = \
modules/dom/image.scm \ modules/dom/image.scm \
modules/dom/media.scm \ modules/dom/media.scm \
modules/dom/window.scm \ modules/dom/window.scm \
modules/game/actors.scm \
modules/math.scm \ modules/math.scm \
modules/math/rect.scm \ modules/math/rect.scm \
modules/math/vector.scm modules/math/vector.scm

Binary file not shown.

Before

Width:  |  Height:  |  Size: 1.6 KiB

After

Width:  |  Height:  |  Size: 1.3 KiB

158
game.scm
View file

@ -25,6 +25,8 @@
(dom image) (dom image)
(dom media) (dom media)
(dom window) (dom window)
(game actors)
(goblins core)
(hoot ffi) (hoot ffi)
(hoot hashtables) (hoot hashtables)
(ice-9 match) (ice-9 match)
@ -36,16 +38,57 @@
(define game-height 240.0) (define game-height 240.0)
(define tile-width 16.0) (define tile-width 16.0)
(define tile-height 16.0) (define tile-height 16.0)
(define level-width (inexact->exact (floor (/ game-width tile-width))))
(define level-height (inexact->exact (floor (/ game-height tile-height))))
(define *canvas-scale* 0.0)
(define *canvas-width* 0)
(define *canvas-height* 0)
(define image:tiles (make-image "assets/images/cirkoban.png")) (define image:tiles (make-image "assets/images/cirkoban.png"))
;; Game state
(define *actormap* (make-whactormap))
(define (call-with-goblins thunk)
(actormap-churn-run! *actormap* thunk))
(define-syntax-rule (with-goblins body ...)
(call-with-goblins (lambda () body ...)))
(define *level* #f)
;; Latest representation of all actors in level
(define *grid* #f)
(define *snapshots* '())
(define (clear-snapshots!)
(set! *snapshots* '()))
(define (save-snapshot!)
(set! *snapshots* (cons (copy-whactormap *actormap*) *snapshots*)))
(define (update-grid!)
(set! *grid* ($ *level* 'describe)))
(define (reset-game!)
(set! *actormap* (make-whactormap))
(clear-snapshots!)
(with-goblins
(set! *level* (spawn ^level level-width level-height))
(update-grid!)))
;; Update loop
(define (move-player dir)
(with-goblins
($ *level* 'move-player dir)
(update-grid!))
;; (save-snapshot!)
)
(define dt (/ 1000.0 60.0)) ; aim for updating at 60Hz (define dt (/ 1000.0 60.0)) ; aim for updating at 60Hz
(define (update) (define (update)
#t ;; TODO: what kind of work do we need to do each frame?
(timeout update-callback dt)) (timeout update-callback dt))
(define update-callback (procedure->external update)) (define update-callback (procedure->external update))
;; Rendering ;; Render loop
(define number->string* (define number->string*
(let ((cache (make-eq-hashtable))) ; assuming fixnums only (let ((cache (make-eq-hashtable))) ; assuming fixnums only
(lambda (x) (lambda (x)
@ -54,27 +97,98 @@
(hashtable-set! cache x str) (hashtable-set! cache x str)
str))))) str)))))
(define (draw prev-time) (define (draw-player x y)
(set-fill-color! context "#140c1c")
(fill-rect context 0.0 0.0 game-width game-height)
(set-fill-color! context "#ffffff")
(set-font! context "bold 24px monospace")
(set-text-align! context "left")
(fill-text context "HELLO" 16.0 36.0)
(draw-image context image:tiles (draw-image context image:tiles
0.0 0.0 tile-width tile-height 0.0 0.0 tile-width tile-height
100.0 100.0 tile-width tile-height) (* x tile-width) (* y tile-height) tile-width tile-height))
(define (draw-wall type x y)
(match type
('brick
(draw-image context image:tiles
32.0 16.0 tile-width tile-height
(* x tile-width) (* y tile-height) tile-width tile-height))
(_
(draw-image context image:tiles
48.0 0.0 tile-width tile-height
(* x tile-width) (* y tile-height) tile-width tile-height)))
(match type
('electron-head
(draw-image context image:tiles
64.0 0.0 tile-width tile-height
(* x tile-width) (* y tile-height) tile-width tile-height))
('electron-tail
(draw-image context image:tiles
80.0 0.0 tile-width tile-height
(* x tile-width) (* y tile-height) tile-width tile-height))
(_ #f)))
(define (draw-block type x y)
(draw-image context image:tiles
32.0 0.0 tile-width tile-height
(* x tile-width) (* y tile-height) tile-width tile-height)
(match type
('electron-head
(draw-image context image:tiles
64.0 0.0 tile-width tile-height
(* x tile-width) (* y tile-height) tile-width tile-height))
('electron-tail
(draw-image context image:tiles
80.0 0.0 tile-width tile-height
(* x tile-width) (* y tile-height) tile-width tile-height))
(_ #f)))
(define (draw-clock-emitter x y)
(draw-image context image:tiles
48.0 0.0 tile-width tile-height
(* x tile-width) (* y tile-height) tile-width tile-height))
(define (draw-tile x y obj)
(match obj
(#f #f)
(('player) (draw-player x y))
(('wall type) (draw-wall type x y))
(('block type) (draw-block type x y))
(('clock-emitter) (draw-clock-emitter x y))))
(define (draw-level)
(let ((grid *grid*))
(let y-loop ((y 0))
(when (< y level-height)
(let x-loop ((x 0))
(when (< x level-width)
(draw-tile x y (vector-ref grid (+ (* y level-width) x)))
(x-loop (1+ x))))
(y-loop (1+ y))))))
(define (draw prev-time)
(clear-rect context 0.0 0.0 *canvas-width* *canvas-height*)
(set-fill-color! context "#cbdbfc")
(fill-rect context 0.0 0.0 *canvas-width* *canvas-height*)
(set-transform! context 1.0 0.0 0.0 1.0 0.0 0.0)
(set-scale! context *canvas-scale* *canvas-scale*)
(draw-level)
(request-animation-frame draw-callback)) (request-animation-frame draw-callback))
(define draw-callback (procedure->external draw)) (define draw-callback (procedure->external draw))
;; Input ;; Input
(define key:left "ArrowLeft") (define key:left "ArrowLeft")
(define key:right "ArrowRight") (define key:right "ArrowRight")
(define key:down "ArrowDown")
(define key:up "ArrowUp")
(define key:confirm "Enter") (define key:confirm "Enter")
(define (on-key-down event) (define (on-key-down event)
(let ((key (keyboard-event-code event))) (let ((key (keyboard-event-code event)))
(pk 'key-down key))) (cond
((string=? key key:left)
(move-player 'left))
((string=? key key:right)
(move-player 'right))
((string=? key key:up)
(move-player 'up))
((string=? key key:down)
(move-player 'down)))))
(define (on-key-up event) (define (on-key-up event)
(let ((key (keyboard-event-code event))) (let ((key (keyboard-event-code event)))
@ -83,11 +197,33 @@
;; Canvas and event loop setup ;; Canvas and event loop setup
(define canvas (get-element-by-id "canvas")) (define canvas (get-element-by-id "canvas"))
(define context (get-context canvas "2d")) (define context (get-context canvas "2d"))
(define (resize-canvas)
(let* ((win (current-window))
(w (window-inner-width win))
(h (window-inner-height win))
(gw (inexact->exact game-width))
(gh (inexact->exact game-height))
(scale (max (min (quotient w gw) (quotient h gh)) 1))
(cw (* gw scale))
(ch (* gh scale)))
(set-element-width! canvas cw)
(set-element-height! canvas ch)
(set-image-smoothing-enabled! context 0)
(set! *canvas-scale* (exact->inexact scale))
(set! *canvas-width* (* game-width *canvas-scale*))
(set! *canvas-height* (* game-height *canvas-scale*))
(pk 'resize-canvas *canvas-scale* *canvas-width* *canvas-height*)))
(set-element-width! canvas (inexact->exact game-width)) (set-element-width! canvas (inexact->exact game-width))
(set-element-height! canvas (inexact->exact game-height)) (set-element-height! canvas (inexact->exact game-height))
(add-event-listener! (current-window) "resize"
(procedure->external (lambda (_) (resize-canvas))))
(add-event-listener! (current-document) "keydown" (add-event-listener! (current-document) "keydown"
(procedure->external on-key-down)) (procedure->external on-key-down))
(add-event-listener! (current-document) "keyup" (add-event-listener! (current-document) "keyup"
(procedure->external on-key-up)) (procedure->external on-key-up))
(resize-canvas)
(request-animation-frame draw-callback) (request-animation-frame draw-callback)
(timeout update-callback dt) (timeout update-callback dt)
(reset-game!)

211
modules/game/actors.scm Normal file
View file

@ -0,0 +1,211 @@
(define-module (game actors)
#:use-module (dom canvas)
#:use-module (goblins core)
#:use-module (ice-9 match)
#:export (^cell
^level))
;; ^wall
;; ^wire
;; ^electron-head
;; ^electron-tail
(define* (^cell bcom #:optional val)
(case-lambda
(() val)
((new-val)
(bcom (^cell bcom new-val)))))
(define (^wall bcom type)
(match-lambda*
(('tick) #f)
(('wire-state)
(match type
((or 'copper 'electron-head 'electron-tail)
type)
(_ #f)))
(('set-wire-state type)
(bcom (^wall bcom type)))
(('describe) `(wall ,type))
(('collide) 'stop)))
(define (^block bcom type)
(match-lambda*
(('tick) #f)
(('wire-state)
(match type
((or 'copper 'electron-head 'electron-tail)
type)
(_ #f)))
(('set-wire-state type)
(bcom (^block bcom type)))
(('describe) `(block ,type))
(('collide) 'displace)))
(define (^clock-emitter bcom interval)
(define timer (spawn ^cell 0))
(match-lambda*
(('tick) ($ timer (+ ($ timer) 1)))
(('wire-state)
(let ((t ($ timer)))
(cond
((= (modulo t interval) 0)
'electron-head)
((= (modulo t interval) 1)
'electron-tail)
(else
'copper))))
(('set-wire-state type) #f)
(('describe) '(clock-emitter))
(('collide) 'stop)))
(define (^player bcom)
(match-lambda*
(('tick) #f)
(('wire-state) #f)
(('describe) '(player))))
(define (^level bcom width height)
(define player (spawn ^player))
(define player-coords (spawn ^cell))
(define (make-grid)
(make-vector (* width height)))
(define grid (make-grid))
(define (grid-ref grid x y)
(vector-ref grid (+ (* y width) x)))
(define (grid-ref/wrap grid x y)
(grid-ref grid (modulo x width) (modulo y height)))
(define (grid-set! grid x y val)
(vector-set! grid (+ (* y width) x) val))
(define (for-each-coord proc)
(let y-loop ((y 0))
(when (< y height)
(let x-loop ((x 0))
(when (< x width)
(proc x y)
(x-loop (1+ x))))
(y-loop (1+ y)))))
(define (wrap-x x)
(modulo x width))
(define (wrap-y y)
(modulo y height))
;; Assumes that dx/dy are in the range [0,1].
(define (move-player dx dy)
(match ($ player-coords)
(#(old-x old-y)
(let* ((x (wrap-x (+ old-x dx)))
(y (wrap-y (+ old-y dy)))
(old-cell (grid-ref grid old-x old-y))
(cell (grid-ref grid x y)))
(match ($ cell)
(#f
($ old-cell #f)
($ cell player)
($ player-coords (vector x y)))
(occupant
(match ($ occupant 'collide)
('stop #f)
('displace
(let ((next-cell (grid-ref grid (wrap-x (+ x dx)) (wrap-y (+ y dy)))))
(match ($ next-cell)
(#f
($ next-cell ($ cell))
($ cell player)
($ old-cell #f)
($ player-coords (vector x y)))
(_ #f)))))))))))
(define (warp-player x y)
($ (grid-ref grid x y) player)
(match ($ player-coords)
(#f
($ player-coords (vector x y)))
(#(old-x old-y)
($ player-coords (vector x y))
($ (grid-ref grid old-x old-y) #f))))
(define (tick)
(define (neighbors x y)
(define (check x y)
(match ($ (grid-ref/wrap grid x y))
(#f 0)
(refr
(match ($ refr 'wire-state)
('electron-head 1)
(_ 0)))))
(+ (check (- x 1) (- y 1))
(check x (- y 1))
(check (+ x 1) (- y 1))
(check (+ x 1) y)
(check (+ x 1) (+ y 1))
(check x (+ y 1))
(check (- x 1) (+ y 1))
(check (- x 1) y)))
(for-each (match-lambda
((refr . wire-state)
($ refr 'set-wire-state wire-state)))
(let y-loop ((y 0) (updates '()))
(if (< y height)
(y-loop (1+ y)
(let x-loop ((x 0) (updates updates))
(if (< x width)
(match ($ (grid-ref grid x y))
(#f (x-loop (1+ x) updates))
(refr
($ refr 'tick)
(match ($ refr 'wire-state)
(#f (x-loop (1+ x) updates))
('copper
(if (<= 1 (neighbors x y) 2)
(x-loop (1+ x) (cons `(,refr . electron-head) updates))
(x-loop (1+ x) updates)))
('electron-head
(x-loop (1+ x) (cons `(,refr . electron-tail) updates)))
('electron-tail
(x-loop (1+ x) (cons `(,refr . copper) updates))))))
updates)))
updates))))
;; Initialize grid cells
(for-each-coord
(lambda (x y)
(grid-set! grid x y (spawn ^cell))))
;; TODO: actually write levels
(warp-player 10 8)
($ (grid-ref grid 4 4) (spawn ^wall 'brick))
($ (grid-ref grid 4 3) (spawn ^clock-emitter 3))
($ (grid-ref grid 5 3) (spawn ^wall 'copper))
($ (grid-ref grid 6 4) (spawn ^block 'copper))
($ (grid-ref grid 7 3) (spawn ^wall 'copper))
($ (grid-ref grid 8 3) (spawn ^wall 'copper))
($ (grid-ref grid 9 3) (spawn ^wall 'copper))
($ (grid-ref grid 10 3) (spawn ^wall 'copper))
($ (grid-ref grid 11 3) (spawn ^wall 'copper))
($ (grid-ref grid 12 3) (spawn ^wall 'copper))
($ (grid-ref grid 13 2) (spawn ^wall 'copper))
($ (grid-ref grid 13 3) (spawn ^wall 'copper))
($ (grid-ref grid 13 4) (spawn ^wall 'copper))
($ (grid-ref grid 14 2) (spawn ^wall 'copper))
($ (grid-ref grid 14 4) (spawn ^wall 'copper))
($ (grid-ref grid 15 3) (spawn ^wall 'copper))
($ (grid-ref grid 16 3) (spawn ^wall 'copper))
($ (grid-ref grid 17 3) (spawn ^wall 'copper))
($ (grid-ref grid 18 3) (spawn ^wall 'copper))
(match-lambda*
(('describe)
(let ((grid* (make-grid)))
(for-each-coord
(lambda (x y)
(grid-set! grid* x y
(match ($ (grid-ref grid x y))
(#f #f)
(refr ($ refr 'describe))))))
grid*))
(('move-player dir)
(match dir
('up (move-player 0 -1))
('down (move-player 0 1))
('left (move-player -1 0))
('right (move-player 1 0)))
(tick))))

View file

@ -23,6 +23,7 @@
(define-module (goblins core-types) (define-module (goblins core-types)
#:use-module (hoot hashtables) #:use-module (hoot hashtables)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (srfi srfi-9)
#:export (<actormap> #:export (<actormap>
_make-actormap _make-actormap
actormap? actormap?
@ -89,10 +90,6 @@
live-refr? live-refr?
promise-refr?)) promise-refr?))
;; hoot hacks
(define *unspecified* (if #f #f))
;; Actormaps, etc ;; Actormaps, etc
;; ============== ;; ==============
(define-record-type <actormap> (define-record-type <actormap>

View file

@ -102,24 +102,22 @@
near-resolved-promise-value near-resolved-promise-value
;; test-core.scm needs these; they are not otherwise exported ;; test-core.scm needs these; they are not otherwise exported
*unspecified*
transactormap-set! transactormap-set!
transactormap-ref transactormap-ref
mactor:local-link?) mactor:local-link?)
#:pure #:use-module (hoot bytevectors)
#:use-module ((hoot errors) #:select (raise-exception))
#:use-module ((hoot error-handling) #:select (format-exception)) #:use-module ((hoot error-handling) #:select (format-exception))
#:use-module (hoot exceptions) #:use-module ((hoot exceptions) #:select (make-exception-with-irritants))
#:use-module (hoot hashtables) #:use-module (hoot hashtables)
#:use-module (hoot match) #:use-module ((hoot ports) #:select (flush-output-port))
#:use-module ((hoot syntax) #:select (define*)) #:use-module ((ice-9 control) #:select (call/ec))
#:use-module (ice-9 control) #:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:use-module (ice-9 q) #:use-module (ice-9 q)
#:use-module (ice-9 vlist)
#:use-module (goblins core-types) #:use-module (goblins core-types)
#:use-module (goblins ghash) #:use-module (goblins ghash)
#:use-module (scheme base) #:use-module (srfi srfi-9)
#:use-module (scheme write)) #:use-module (srfi srfi-11))
;;; Utilities (which should be moved to their own modules) ;;; Utilities (which should be moved to their own modules)
@ -128,8 +126,6 @@
;;; hoot hacks ;;; hoot hacks
(define *unspecified* (if #f #f))
;;; Here's basically your pre-goblins area. ;;; Here's basically your pre-goblins area.
;; mimic Racket's seteq ;; mimic Racket's seteq
@ -2110,7 +2106,8 @@ Type: Actormap (-> Any) (Optioan (#:reckless? Boolean)) -> Any"
(display msg (current-error-port)) (newline (current-error-port)) (display msg (current-error-port)) (newline (current-error-port))
(display ";; exception: " (current-error-port)) (display ";; exception: " (current-error-port))
(format-exception err (current-error-port)) (format-exception err (current-error-port))
(newline (current-error-port)) (flush-output-port (current-error-port))) (newline (current-error-port))
(flush-output-port (current-error-port)))
(define (make-no-op msg) (define (make-no-op msg)
(lambda _ *unspecified*)) (lambda _ *unspecified*))

View file

@ -28,7 +28,7 @@
#:use-module (hoot hashtables) #:use-module (hoot hashtables)
#:use-module ((hoot lists) #:select (fold)) #:use-module ((hoot lists) #:select (fold))
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (scheme write) #:use-module (srfi srfi-9)
#:export (make-ghash #:export (make-ghash
ghash? ghash?

View file

@ -22,7 +22,7 @@
;;; Code: ;;; Code:
(define-module (guile list) (define-module (guile list)
#:export (delete delq delq! last-pair)) #:export (delete delq delq!))
(define (fold proc acc lst) (define (fold proc acc lst)
(if (null? lst) (if (null? lst)
@ -34,11 +34,6 @@
(define (fold-right proc acc lst) (define (fold-right proc acc lst)
(fold proc acc (reverse lst))) (fold proc acc (reverse lst)))
(define (last-pair lst)
(if (null? (cdr lst))
lst
(last-pair (cdr lst))))
(define (delete item lst . eq-pair) (define (delete item lst . eq-pair)
(define eq (if (pair? eq-pair) (car eq-pair) equal?)) (define eq (if (pair? eq-pair) (car eq-pair) equal?))
(fold-right (lambda (i acc) (fold-right (lambda (i acc)

View file

@ -23,7 +23,6 @@
;;; Code: ;;; Code:
(define-module (ice-9 control) (define-module (ice-9 control)
#:use-module (hoot control)
#:export (make-prompt-tag #:export (make-prompt-tag
default-prompt-tag default-prompt-tag
call-with-prompt call-with-prompt

View file

@ -44,9 +44,9 @@
;;; Code: ;;; Code:
(define-module (ice-9 vlist) (define-module (ice-9 vlist)
#:use-module (hoot fluids)
#:use-module (hoot hashtables) #:use-module (hoot hashtables)
#:use-module ((hoot lists) #:select (fold)) #:use-module ((hoot lists) #:select (fold))
#:use-module (srfi srfi-9)
#:export (vlist? vlist-cons vlist-head vlist-tail vlist-null? #:export (vlist? vlist-cons vlist-head vlist-tail vlist-null?
vlist-null list->vlist vlist-ref vlist-drop vlist-take vlist-null list->vlist vlist-ref vlist-drop vlist-take
vlist-length vlist-fold vlist-fold-right vlist-map vlist-length vlist-fold vlist-fold-right vlist-map
@ -65,8 +65,6 @@
;;; Hoot Hacks™ (not really ™) ;;; Hoot Hacks™ (not really ™)
;; XXX hashes using equal? and eqv? have not been defined; use only eq? ;; XXX hashes using equal? and eqv? have not been defined; use only eq?
(define equal? eq?)
(define eqv? eq?)
(define hash hashq) (define hash hashq)
(define hashv hashq) (define hashv hashq)
(define (fold-right proc init lst) (define (fold-right proc init lst)

3
modules/srfi/srfi-11.scm Normal file
View file

@ -0,0 +1,3 @@
(define-module (srfi srfi-11)
#:use-module ((hoot syntax) #:select (let-values let*-values))
#:re-export (let-values let*-values))

3
modules/srfi/srfi-9.scm Normal file
View file

@ -0,0 +1,3 @@
(define-module (srfi srfi-9)
#:use-module ((scheme base) #:select (define-record-type))
#:re-export (define-record-type))