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

58
modules/game/actors.scm
View file

@ -1,8 +1,12 @@
(define-module (game actors)
#:use-module (goblins core)
#:use-module (hoot bytevectors)
#:use-module (ice-9 match)
#:export (^cell
^exit
^wall
^block
^clock-emitter
^player
^level))
(define* (^cell bcom #:optional val)
@ -17,7 +21,7 @@
(('wire-state) #f)
(('set-wire-state) #f)
(('describe) '(exit))
(('collide) 'goal)))
(('collide) 'exit)))
(define (^wall bcom type)
(match-lambda*
@ -68,8 +72,9 @@
(('wire-state) #f)
(('describe) '(player))))
(define (^level bcom width height objects)
(define (^level bcom width height)
(define player (spawn ^player))
;; TODO: Move this into the player actor.
(define player-coords (spawn ^cell))
(define (make-grid)
(make-vector (* width height)))
@ -108,7 +113,11 @@
(occupant
(match ($ occupant 'collide)
('bump 'bump)
('goal (pk 'GOAL))
('exit
($ old-cell #f)
($ cell player)
($ player-coords (vector x y))
'exit)
('push
(let ((next-cell (grid-ref grid (wrap-x (+ x dx)) (wrap-y (+ y dy)))))
(match ($ next-cell)
@ -174,42 +183,6 @@
(lambda (x y)
(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*
(('describe)
(let ((grid* (make-grid)))
@ -220,6 +193,11 @@
(#f #f)
(refr ($ refr 'describe))))))
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)
(define result
(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"?>
<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"/>
<layer id="1" name="background" width="20" height="15">
<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,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,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,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,3,3,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,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,
@ -20,4 +20,12 @@
23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23
</data>
</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>

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

@ -1,9 +1,16 @@
<?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">
<image source="../../../assets/images/cirkoban.png" width="320" height="240"/>
<tile id="22">
<tile id="2" type="wall">
<properties>
<property name="wall" type="bool" value="true"/>
<property name="kind" value="copper"/>
</properties>
</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>

79
scripts/compile-map.scm
View file

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