Add basic undo with Z key.

This commit is contained in:
David Thompson 2024-05-18 18:51:45 -04:00
parent de7078ef85
commit 9b6ed8ba71
5 changed files with 99 additions and 42 deletions

View file

@ -7,9 +7,20 @@ modules = \
modules/dom/media.scm \ modules/dom/media.scm \
modules/dom/window.scm \ modules/dom/window.scm \
modules/game/actors.scm \ modules/game/actors.scm \
modules/game/tileset.scm \
modules/goblins/abstract-types.scm \
modules/goblins/core.scm \
modules/goblins/core-types.scm \
modules/goblins/ghash.scm \
modules/guile/list.scm \
modules/ice-9/control.scm \
modules/ice-9/q.scm \
modules/ice-9/vlist.scm \
modules/math.scm \ modules/math.scm \
modules/math/rect.scm \ modules/math/rect.scm \
modules/math/vector.scm modules/math/vector.scm \
modules/srfi/srfi-9.scm \
modules/srfi/srfi-11.scm
game.wasm: game.scm $(modules) game.wasm: game.scm $(modules)
guild compile-wasm -L modules -o $@ $< guild compile-wasm -L modules -o $@ $<
@ -19,7 +30,7 @@ serve: game.wasm
bundle: game.wasm bundle: game.wasm
rm game.zip || true rm game.zip || true
zip game.zip -r assets/ js-runtime/ game.js game.css game.wasm index.html zip game.zip -r assets/ reflect.js game.js game.css reflect.wasm wtf8.wasm game.wasm index.html
clean: clean:
rm -f game.wasm game.zip rm -f game.wasm game.zip

Binary file not shown.

Before

Width:  |  Height:  |  Size: 1.3 KiB

After

Width:  |  Height:  |  Size: 1.6 KiB

View file

@ -26,6 +26,7 @@
(dom media) (dom media)
(dom window) (dom window)
(game actors) (game actors)
(game tileset)
(goblins core) (goblins core)
(hoot ffi) (hoot ffi)
(hoot hashtables) (hoot hashtables)
@ -45,7 +46,11 @@
(define *canvas-width* 0) (define *canvas-width* 0)
(define *canvas-height* 0) (define *canvas-height* 0)
(define image:tiles (make-image "assets/images/cirkoban.png")) (define tileset
(make-tileset (make-image "assets/images/cirkoban.png")
320 240
(inexact->exact tile-width)
(inexact->exact tile-height)))
;; Game state ;; Game state
(define *actormap* (make-whactormap)) (define *actormap* (make-whactormap))
@ -63,6 +68,12 @@
(set! *snapshots* '())) (set! *snapshots* '()))
(define (save-snapshot!) (define (save-snapshot!)
(set! *snapshots* (cons (copy-whactormap *actormap*) *snapshots*))) (set! *snapshots* (cons (copy-whactormap *actormap*) *snapshots*)))
(define (rollback-snapshot!)
(match *snapshots*
(() #f)
((snapshot . older-snapshots)
(set! *actormap* snapshot)
(set! *snapshots* older-snapshots))))
(define (update-grid!) (define (update-grid!)
(set! *grid* ($ *level* 'describe))) (set! *grid* ($ *level* 'describe)))
@ -76,11 +87,10 @@
;; Update loop ;; Update loop
(define (move-player dir) (define (move-player dir)
(save-snapshot!)
(with-goblins (with-goblins
($ *level* 'move-player dir) ($ *level* 'move-player dir)
(update-grid!)) (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)
@ -98,58 +108,43 @@
str))))) str)))))
(define (draw-player x y) (define (draw-player x y)
(draw-image context image:tiles (draw-tile context tileset 0 x y))
0.0 0.0 tile-width tile-height
(* x tile-width) (* y tile-height) tile-width tile-height))
(define (draw-wall type x y) (define (draw-wall type x y)
(match type (match type
('brick ('brick
(draw-image context image:tiles (draw-tile context tileset 22 x y))
32.0 16.0 tile-width tile-height
(* x tile-width) (* y tile-height) tile-width tile-height))
(_ (_
(draw-image context image:tiles (draw-tile context tileset 2 x y)))
48.0 0.0 tile-width tile-height
(* x tile-width) (* y tile-height) tile-width tile-height)))
(match type (match type
('electron-head ('electron-head
(draw-image context image:tiles (draw-tile context tileset 4 x y))
64.0 0.0 tile-width tile-height
(* x tile-width) (* y tile-height) tile-width tile-height))
('electron-tail ('electron-tail
(draw-image context image:tiles (draw-tile context tileset 5 x y))
80.0 0.0 tile-width tile-height
(* x tile-width) (* y tile-height) tile-width tile-height))
(_ #f))) (_ #f)))
(define (draw-block type x y) (define (draw-block type x y)
(draw-image context image:tiles (draw-tile context tileset 3 x y)
32.0 0.0 tile-width tile-height
(* x tile-width) (* y tile-height) tile-width tile-height)
(match type (match type
('electron-head ('electron-head
(draw-image context image:tiles (draw-tile context tileset 4 x y))
64.0 0.0 tile-width tile-height
(* x tile-width) (* y tile-height) tile-width tile-height))
('electron-tail ('electron-tail
(draw-image context image:tiles (draw-tile context tileset 5 x y))
80.0 0.0 tile-width tile-height
(* x tile-width) (* y tile-height) tile-width tile-height))
(_ #f))) (_ #f)))
(define (draw-clock-emitter x y) (define (draw-clock-emitter x y)
(draw-image context image:tiles (draw-tile context tileset 2 x y))
48.0 0.0 tile-width tile-height
(* x tile-width) (* y tile-height) tile-width tile-height))
(define (draw-tile x y obj) (define (draw-object x y obj)
(match obj (and obj
(#f #f) (let ((x (* x tile-width))
(('player) (draw-player x y)) (y (* y tile-height)))
(('wall type) (draw-wall type x y)) (match obj
(('block type) (draw-block type x y)) (#f #f)
(('clock-emitter) (draw-clock-emitter x y)))) (('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) (define (draw-level)
(let ((grid *grid*)) (let ((grid *grid*))
@ -157,7 +152,7 @@
(when (< y level-height) (when (< y level-height)
(let x-loop ((x 0)) (let x-loop ((x 0))
(when (< x level-width) (when (< x level-width)
(draw-tile x y (vector-ref grid (+ (* y level-width) x))) (draw-object x y (vector-ref grid (+ (* y level-width) x)))
(x-loop (1+ x)))) (x-loop (1+ x))))
(y-loop (1+ y)))))) (y-loop (1+ y))))))
@ -177,6 +172,7 @@
(define key:down "ArrowDown") (define key:down "ArrowDown")
(define key:up "ArrowUp") (define key:up "ArrowUp")
(define key:confirm "Enter") (define key:confirm "Enter")
(define key:undo "KeyZ")
(define (on-key-down event) (define (on-key-down event)
(let ((key (keyboard-event-code event))) (let ((key (keyboard-event-code event)))
@ -188,7 +184,10 @@
((string=? key key:up) ((string=? key key:up)
(move-player 'up)) (move-player 'up))
((string=? key key:down) ((string=? key key:down)
(move-player 'down))))) (move-player 'down))
((string=? key key:undo)
(rollback-snapshot!)
(with-goblins (update-grid!))))))
(define (on-key-up event) (define (on-key-up event)
(let ((key (keyboard-event-code event))) (let ((key (keyboard-event-code event)))

BIN
game.wasm

Binary file not shown.

47
modules/game/tileset.scm Normal file
View file

@ -0,0 +1,47 @@
(define-module (game tileset)
#:use-module (dom canvas)
#:use-module (dom image)
#:use-module (ice-9 match)
#:use-module (math rect)
#:use-module (srfi srfi-9)
#:export (make-tileset
tileset?
tileset-image
tileset-tile-width
tileset-tile-height
draw-tile))
(define-record-type <tileset>
(%make-tileset image tile-width tile-height tiles)
tileset?
(image tileset-image)
(tile-width tileset-tile-width)
(tile-height tileset-tile-height)
(tiles tileset-tiles))
(define (make-tileset image width height tile-width tile-height)
(let* ((w (quotient width tile-width))
(h (quotient height tile-height))
(tiles (make-vector (* w h))))
(let y-loop ((y 0))
(when (< y h)
(let x-loop ((x 0))
(when (< x w)
(vector-set! tiles (+ (* y w) x)
(make-rect (* x tile-width)
(* y tile-height)
tile-width
tile-height))
(x-loop (1+ x))))
(y-loop (1+ y))))
(%make-tileset image tile-width tile-height tiles)))
(define (draw-tile context tileset idx x y)
(match tileset
(($ <tileset> image _ _ tiles)
(let* ((tile (vector-ref tiles idx))
(sx (rect-x tile))
(sy (rect-y tile))
(w (rect-width tile))
(h (rect-height tile)))
(draw-image context image sx sy w h x y w h)))))