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/window.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/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)
guild compile-wasm -L modules -o $@ $<
@ -19,7 +30,7 @@ serve: game.wasm
bundle: game.wasm
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:
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 window)
(game actors)
(game tileset)
(goblins core)
(hoot ffi)
(hoot hashtables)
@ -45,7 +46,11 @@
(define *canvas-width* 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
(define *actormap* (make-whactormap))
@ -63,6 +68,12 @@
(set! *snapshots* '()))
(define (save-snapshot!)
(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!)
(set! *grid* ($ *level* 'describe)))
@ -76,11 +87,10 @@
;; Update loop
(define (move-player dir)
(save-snapshot!)
(with-goblins
($ *level* 'move-player dir)
(update-grid!))
;; (save-snapshot!)
)
(update-grid!)))
(define dt (/ 1000.0 60.0)) ; aim for updating at 60Hz
(define (update)
@ -98,58 +108,43 @@
str)))))
(define (draw-player x y)
(draw-image context image:tiles
0.0 0.0 tile-width tile-height
(* x tile-width) (* y tile-height) tile-width tile-height))
(draw-tile context tileset 0 x y))
(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-tile context tileset 22 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)))
(draw-tile context tileset 2 x y)))
(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))
(draw-tile context tileset 4 x y))
('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))
(draw-tile context tileset 5 x y))
(_ #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)
(draw-tile context tileset 3 x y)
(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))
(draw-tile context tileset 4 x y))
('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))
(draw-tile context tileset 5 x y))
(_ #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))
(draw-tile context tileset 2 x y))
(define (draw-tile x y obj)
(define (draw-object x y obj)
(and obj
(let ((x (* x tile-width))
(y (* y tile-height)))
(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))))
(('clock-emitter) (draw-clock-emitter x y))))))
(define (draw-level)
(let ((grid *grid*))
@ -157,7 +152,7 @@
(when (< y level-height)
(let x-loop ((x 0))
(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))))
(y-loop (1+ y))))))
@ -177,6 +172,7 @@
(define key:down "ArrowDown")
(define key:up "ArrowUp")
(define key:confirm "Enter")
(define key:undo "KeyZ")
(define (on-key-down event)
(let ((key (keyboard-event-code event)))
@ -188,7 +184,10 @@
((string=? key key:up)
(move-player 'up))
((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)
(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)))))