SuperKamiGuru/foss-mmo
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add support for more objects to map editor.

Browse source
This commit is contained in:
David Thompson 2024-05-20 12:15:39 -04:00
parent 3f24b3bd89
commit 111f4d37f1
9 changed files with 151 additions and 107 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
Makefile
View file

@ -7,6 +7,7 @@ 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/level.scm \
modules/game/tileset.scm \ modules/game/tileset.scm \
modules/goblins/abstract-types.scm \ modules/goblins/abstract-types.scm \
modules/goblins/core.scm \ modules/goblins/core.scm \

BIN
assets/sounds/exit.wav Normal file
View file

Binary file not shown.

BIN
assets/sounds/pickup.wav Normal file
View file

Binary file not shown.

27
game.scm
View file

@ -26,6 +26,7 @@
(dom media) (dom media)
(dom window) (dom window)
(game actors) (game actors)
(game level)
(game levels level-1) (game levels level-1)
(game tileset) (game tileset)
(goblins core) (goblins core)
@ -54,7 +55,7 @@
320 240 320 240
(inexact->exact tile-width) (inexact->exact tile-width)
(inexact->exact tile-height))) (inexact->exact tile-height)))
(define* (load-sound-effect name #:key (volume 0.5)) (define* (load-sound-effect name #:key (volume 0.25))
(let ((audio (make-audio (string-append "assets/sounds/" name ".wav")))) (let ((audio (make-audio (string-append "assets/sounds/" name ".wav"))))
(set-media-volume! audio volume) (set-media-volume! audio volume)
audio)) audio))
@ -62,6 +63,7 @@
(define audio:push (load-sound-effect "push")) (define audio:push (load-sound-effect "push"))
(define audio:undo (load-sound-effect "undo")) (define audio:undo (load-sound-effect "undo"))
(define audio:no (load-sound-effect "no")) (define audio:no (load-sound-effect "no"))
(define audio:exit (load-sound-effect "exit"))
;; Game state ;; Game state
(define *actormap* (make-whactormap)) (define *actormap* (make-whactormap))
@ -73,8 +75,6 @@
(define *level* #f) (define *level* #f)
;; Latest representation of all actors in level ;; Latest representation of all actors in level
(define *grid* #f) (define *grid* #f)
;; Background tile layer.
(define *background* #f)
(define *snapshots* '()) (define *snapshots* '())
(define (clear-snapshots!) (define (clear-snapshots!)
@ -90,25 +90,23 @@
(media-play audio:undo)))) (media-play audio:undo))))
(define (update-grid!) (define (update-grid!)
(set! *grid* ($ *level* 'describe))) (set! *grid* ($ (level-actor *level*) 'describe)))
(define (reset-game!) (define (reset-game!)
(set! *actormap* (make-whactormap)) (set! *actormap* (make-whactormap))
(clear-snapshots!) (clear-snapshots!)
(with-goblins (with-goblins
(call-with-values load-level-1 (set! *level* (load-level-1))
(lambda (background level)
(set! *background* background)
(set! *level* level)))
(update-grid!))) (update-grid!)))
;; Update loop ;; Update loop
(define (move-player dir) (define (move-player dir)
(save-snapshot!) (save-snapshot!)
(with-goblins (with-goblins
(match ($ *level* 'move-player dir) (match ($ (level-actor *level*) 'move-player dir)
('bump (media-play audio:bump)) ('bump (media-play audio:bump))
('push (media-play audio:push)) ('push (media-play audio:push))
('exit (media-play audio:exit))
(_ #f)) (_ #f))
(update-grid!))) (update-grid!)))
@ -156,7 +154,7 @@
(_ #f))) (_ #f)))
(define (draw-clock-emitter x y) (define (draw-clock-emitter x y)
(draw-tile context tileset 2 x y)) (draw-tile context tileset 48 x y))
(define (draw-object x y obj) (define (draw-object x y obj)
(and obj (and obj
@ -171,7 +169,7 @@
(('clock-emitter) (draw-clock-emitter x y)))))) (('clock-emitter) (draw-clock-emitter x y))))))
(define (draw-background) (define (draw-background)
(let* ((bv *background*) (let* ((bv (level-background *level*))
(len (bytevector-length bv))) (len (bytevector-length bv)))
(let lp ((i 0)) (let lp ((i 0))
(when (< i len) (when (< i len)
@ -210,6 +208,7 @@
(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 (cond
((string=? key key:left) ((string=? key key:left)
(move-player 'left)) (move-player 'left))
@ -225,10 +224,6 @@
((string=? key key:confirm) ((string=? key key:confirm)
(reset-game!))))) (reset-game!)))))
(define (on-key-up event)
(let ((key (keyboard-event-code event)))
(pk 'key-up key)))
;; 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"))
@ -256,8 +251,6 @@
(procedure->external (lambda (_) (resize-canvas)))) (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"
(procedure->external on-key-up))
(resize-canvas) (resize-canvas)
(request-animation-frame draw-callback) (request-animation-frame draw-callback)
(timeout update-callback dt) (timeout update-callback dt)

58
modules/game/actors.scm
View file

@ -1,8 +1,12 @@
(define-module (game actors) (define-module (game actors)
#:use-module (goblins core) #:use-module (goblins core)
#:use-module (hoot bytevectors)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:export (^cell #:export (^cell
^exit
^wall
^block
^clock-emitter
^player
^level)) ^level))
(define* (^cell bcom #:optional val) (define* (^cell bcom #:optional val)
@ -17,7 +21,7 @@
(('wire-state) #f) (('wire-state) #f)
(('set-wire-state) #f) (('set-wire-state) #f)
(('describe) '(exit)) (('describe) '(exit))
(('collide) 'goal))) (('collide) 'exit)))
(define (^wall bcom type) (define (^wall bcom type)
(match-lambda* (match-lambda*
@ -68,8 +72,9 @@
(('wire-state) #f) (('wire-state) #f)
(('describe) '(player)))) (('describe) '(player))))
(define (^level bcom width height objects) (define (^level bcom width height)
(define player (spawn ^player)) (define player (spawn ^player))
;; TODO: Move this into the player actor.
(define player-coords (spawn ^cell)) (define player-coords (spawn ^cell))
(define (make-grid) (define (make-grid)
(make-vector (* width height))) (make-vector (* width height)))
@ -108,7 +113,11 @@
(occupant (occupant
(match ($ occupant 'collide) (match ($ occupant 'collide)
('bump 'bump) ('bump 'bump)
('goal (pk 'GOAL)) ('exit
($ old-cell #f)
($ cell player)
($ player-coords (vector x y))
'exit)
('push ('push
(let ((next-cell (grid-ref grid (wrap-x (+ x dx)) (wrap-y (+ y dy))))) (let ((next-cell (grid-ref grid (wrap-x (+ x dx)) (wrap-y (+ y dy)))))
(match ($ next-cell) (match ($ next-cell)
@ -174,42 +183,6 @@
(lambda (x y) (lambda (x y)
(grid-set! grid x y (spawn ^cell)))) (grid-set! grid x y (spawn ^cell))))
;; TODO: actually write levels
(warp-player 10 8)
;; Parsed packed object data and spawn objects.
(let ((len (bytevector-length objects)))
(let lp ((i 0))
(when (< i len)
(let ((x (bytevector-u8-ref objects i))
(y (bytevector-u8-ref objects (+ i 1)))
(obj (match (bytevector-u8-ref objects (+ i 2))
(1 (spawn ^wall 'brick))
(id (error "invalid level object" id)))))
($ (grid-ref grid x y) obj))
(lp (+ i 3)))))
($ (grid-ref grid 3 7) (spawn ^exit))
($ (grid-ref grid 4 3) (spawn ^clock-emitter 3))
($ (grid-ref grid 5 3) (spawn ^wall 'copper))
($ (grid-ref grid 6 5) (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* (match-lambda*
(('describe) (('describe)
(let ((grid* (make-grid))) (let ((grid* (make-grid)))
@ -220,6 +193,11 @@
(#f #f) (#f #f)
(refr ($ refr 'describe)))))) (refr ($ refr 'describe))))))
grid*)) grid*))
(('set-object x y obj)
($ (grid-ref grid x y) obj))
;; TODO: Move to player actor
(('warp-player x y)
(warp-player x y))
(('move-player dir) (('move-player dir)
(define result (define result
(match dir (match dir

40
modules/game/level.scm Normal file
View file

@ -0,0 +1,40 @@
(define-module (game level)
#:use-module (game actors)
#:use-module (goblins core)
#:use-module (hoot bytevectors)
#:use-module (ice-9 match)
#:use-module (srfi srfi-9)
#:export (make-level
level?
level-background
level-actor))
;; Client-side rendering info coupled with level actor that contains
;; game state.
(define-record-type <level>
(%make-level background actor)
level?
(background level-background)
(actor level-actor))
(define (make-level width height background objects)
(let ((level* (spawn ^level width height)))
;; Parsed packed object data and spawn objects.
(let ((len (bytevector-length objects)))
(let lp ((i 0))
(when (< i len)
(let ((x (bytevector-u8-ref objects i))
(y (bytevector-u8-ref objects (+ i 1)))
(id (bytevector-u8-ref objects (+ i 2))))
(if (= id 3) ; player-spawn
($ level* 'warp-player x y)
(let ((obj (match id
(1 (spawn ^wall 'brick))
(2 (spawn ^wall 'copper))
(4 (spawn ^exit))
(5 (spawn ^block 'copper))
(6 (spawn ^clock-emitter 4))
(id (error "invalid level object" id)))))
($ level* 'set-object x y obj))))
(lp (+ i 3)))))
(%make-level background level*)))

18
modules/game/levels/level-1.tmx
View file

@ -1,14 +1,14 @@
<?xml version="1.0" encoding="UTF-8"?> <?xml version="1.0" encoding="UTF-8"?>
<map version="1.8" tiledversion="1.8.6" orientation="orthogonal" renderorder="right-down" width="20" height="15" tilewidth="16" tileheight="16" infinite="0" nextlayerid="2" nextobjectid="1"> <map version="1.8" tiledversion="1.8.6" orientation="orthogonal" renderorder="right-down" width="20" height="15" tilewidth="16" tileheight="16" infinite="0" nextlayerid="3" nextobjectid="5">
<tileset firstgid="1" source="tiles.tsx"/> <tileset firstgid="1" source="tiles.tsx"/>
<layer id="1" name="background" width="20" height="15"> <layer id="1" name="background" width="20" height="15">
<data encoding="csv"> <data encoding="csv">
23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23, 23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,
23,23,23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23,23,23, 23,23,23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23,23,23,
23,23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23,23, 23,23,24,24,24,24,24,24,24,28,24,24,24,24,24,24,24,24,23,23,
23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23, 23,24,24,24,24,24,24,24,24,24,24,24,3,3,24,24,24,24,24,23,
23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23, 23,49,3,3,3,3,24,3,3,3,3,3,3,24,3,3,3,3,3,23,
23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23, 23,24,24,24,24,24,24,24,24,24,24,24,3,3,24,24,24,24,24,23,
23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23, 23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23,
23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23, 23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23,
23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23, 23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23,
@ -20,4 +20,12 @@
23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23 23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23
</data> </data>
</layer> </layer>
<objectgroup id="2" name="objects">
<object id="1" type="player-spawn" gid="1" x="128" y="144" width="16" height="16"/>
<object id="4" type="block" gid="4" x="96" y="80" width="16" height="16">
<properties>
<property name="kind" value="copper"/>
</properties>
</object>
</objectgroup>
</map> </map>

11
modules/game/levels/tiles.tsx
View file

@ -1,9 +1,16 @@
<?xml version="1.0" encoding="UTF-8"?> <?xml version="1.0" encoding="UTF-8"?>
<tileset version="1.8" tiledversion="1.8.6" name="tiles" tilewidth="16" tileheight="16" tilecount="300" columns="20"> <tileset version="1.8" tiledversion="1.8.6" name="tiles" tilewidth="16" tileheight="16" tilecount="300" columns="20">
<image source="../../../assets/images/cirkoban.png" width="320" height="240"/> <image source="../../../assets/images/cirkoban.png" width="320" height="240"/>
<tile id="22"> <tile id="2" type="wall">
<properties> <properties>
<property name="wall" type="bool" value="true"/> <property name="kind" value="copper"/>
</properties> </properties>
</tile> </tile>
<tile id="22" type="wall">
<properties>
<property name="kind" value="brick"/>
</properties>
</tile>
<tile id="27" type="exit"/>
<tile id="48" type="clock-emitter"/>
</tileset> </tileset>

103
scripts/compile-map.scm
View file

@ -93,9 +93,10 @@
(loop (+ i 1) (+ t d))))))) (loop (+ i 1) (+ t d)))))))
(define-record-type <tile> (define-record-type <tile>
(make-tile id image animation properties) (make-tile id type image animation properties)
tile? tile?
(id tile-id) (id tile-id)
(type tile-type)
(image tile-image) (image tile-image)
(animation tile-animation) (animation tile-animation)
(properties tile-properties)) (properties tile-properties))
@ -141,9 +142,10 @@
((= i (vector-length tiles))) ((= i (vector-length tiles)))
(let* ((id (+ first-gid i)) (let* ((id (+ first-gid i))
(custom (or (assv-ref custom-tiles id) '())) (custom (or (assv-ref custom-tiles id) '()))
(type (assq-ref custom 'type))
(animation (assq-ref custom 'animation)) (animation (assq-ref custom 'animation))
(properties (assq-ref custom 'properties)) (properties (assq-ref custom 'properties))
(tile (make-tile id i (tile (make-tile id type i
(and animation (and animation
(make-animation image first-gid animation)) (make-animation image first-gid animation))
(or properties '())))) (or properties '()))))
@ -351,9 +353,11 @@ the default ORIENTATION value of 'orthogonal' is supported."
(define (parse-tileset node first-gid) (define (parse-tileset node first-gid)
(define (parse-custom-tile node) (define (parse-custom-tile node)
(let ((id (attr node 'id string->number)) (let ((id (attr node 'id string->number))
(type (attr node 'type))
(properties (map parse-property (properties (map parse-property
((sxpath '(properties property)) node)))) ((sxpath '(properties property)) node))))
`(,id . ((properties . ,properties))))) `(,id . (,@(if type `((type . ,type)) '())
(properties . ,properties)))))
(let* ((name (attr node 'name)) (let* ((name (attr node 'name))
(tile-width (attr node 'tilewidth string->number)) (tile-width (attr node 'tilewidth string->number))
(tile-height (attr node 'tileheight string->number)) (tile-height (attr node 'tileheight string->number))
@ -541,42 +545,54 @@ the default ORIENTATION value of 'orthogonal' is supported."
(iota (tile-layer-width layer)))) (iota (tile-layer-width layer))))
(iota (tile-layer-height layer)))))) (iota (tile-layer-height layer))))))
(define (compile-walls tile-map layer-name) (define obj:wall:brick 1)
(define obj:wall:copper 2)
(define obj:player-spawn 3)
(define obj:exit 4)
(define obj:block:copper 5)
(define obj:clock-emitter 6)
(define (compile-environment-layer tile-map layer-name)
(let ((tw (tile-map-tile-width tile-map)) (let ((tw (tile-map-tile-width tile-map))
(th (tile-map-tile-height tile-map)) (th (tile-map-tile-height tile-map))
(layer (tile-map-layer-ref tile-map layer-name))) (layer (tile-map-layer-ref tile-map layer-name)))
(u8-list->bytevector (append-map (lambda (y)
(append-map (lambda (y) (concatenate
(concatenate (filter-map (lambda (x)
(filter-map (lambda (x) (match (tile-layer-ref layer x y)
(match (tile-layer-ref layer x y) (#f #f)
(#f #f) ((= map-tile-ref tile)
(tile (match (tile-type tile)
(and (assq-ref (tile-properties (map-tile-ref tile)) 'wall) (#f #f)
(list x y 1))))) ("wall"
(iota (tile-layer-width layer))))) (match (assq-ref (tile-properties tile) 'kind)
(iota (tile-layer-height layer)))))) ("brick" (list x y obj:wall:brick))
("copper" (list x y obj:wall:copper))
(kind (error "unsupported wall kind" kind))))
("exit" (list x y obj:exit))
("clock-emitter" (list x y obj:clock-emitter))
(type (error "unsupported background object" type))))))
(iota (tile-layer-width layer)))))
(iota (tile-layer-height layer)))))
(define (compile-object-layer tile-map layer) (define (compile-object-layer tile-map layer-name)
(let ((table (make-hash-table)) (let ((tw (tile-map-tile-width tile-map))
(tw (tile-map-tile-width tile-map)) (th (tile-map-tile-height tile-map))
(th (tile-map-tile-height tile-map))) (layer (tile-map-layer-ref tile-map layer-name)))
(for-each (lambda (obj) (append-map (lambda (obj)
(let* ((type (map-object-type obj)) (let* ((type (map-object-type obj))
(properties (map-object-properties obj)) (properties (map-object-properties obj))
(r (map-object-shape obj)) (r (map-object-shape obj))
(x (/ (rect-x r) tw)) (x (/ (rect-x r) tw))
(y (/ (rect-y r) th))) (y (/ (rect-y r) th)))
;; (format (current-error-port) "obj: ~a ~a ~a ~a\n" (rect-x r) (rect-y r) x y) (match type
(hashv-set! table y ('player-spawn (list x y obj:player-spawn))
(cons `(make-level-object ,x (quote ,type) ('block
(quote ,properties)) (match (assq-ref properties 'kind)
(hashv-ref table y '()))))) ("copper" (list x y obj:block:copper))
(object-layer-objects layer)) (kind (error "unsupported block kind" kind))))
`(vector (_ (error "unsupported object type" type)))))
,@(map (lambda (y) (object-layer-objects layer))))
`(list ,@(hashv-ref table y '())))
(iota (tile-map-height tile-map))))))
(define (basename-strip-extension file-name) (define (basename-strip-extension file-name)
(match (string-split (basename file-name) #\.) (match (string-split (basename file-name) #\.)
@ -588,16 +604,17 @@ the default ORIENTATION value of 'orthogonal' is supported."
(module-name `(game levels ,(string->symbol name))) (module-name `(game levels ,(string->symbol name)))
(proc-name (string->symbol (string-append "load-" name))) (proc-name (string->symbol (string-append "load-" name)))
(tile-map (load-tile-map file-name))) (tile-map (load-tile-map file-name)))
(compile-object-layer tile-map "objects")
(for-each pretty-print (for-each pretty-print
`((define-module ,module-name `((define-module ,module-name
#:use-module (game actors) #:use-module (game level)
#:use-module (goblins core)
#:use-module (math vector)
#:export (,proc-name)) #:export (,proc-name))
(define (,proc-name) (define (,proc-name)
(values ,(compile-tile-layer tile-map "background") (make-level ,(tile-map-width tile-map)
(spawn ^level ,(tile-map-height tile-map)
,(tile-map-width tile-map) ,(compile-tile-layer tile-map "background")
,(tile-map-height tile-map) ,(u8-list->bytevector
,(compile-walls tile-map "background")))))))) (append
(compile-environment-layer tile-map "background")
(compile-object-layer tile-map "objects")))))))))
(_ (error "file name expected"))) (_ (error "file name expected")))