Add support for more objects to map editor.
This commit is contained in:
parent
3f24b3bd89
commit
111f4d37f1
9 changed files with 151 additions and 107 deletions
1
Makefile
1
Makefile
|
@ -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
BIN
assets/sounds/exit.wav
Normal file
Binary file not shown.
BIN
assets/sounds/pickup.wav
Normal file
BIN
assets/sounds/pickup.wav
Normal file
Binary file not shown.
27
game.scm
27
game.scm
|
@ -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)
|
||||
|
|
|
@ -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
40
modules/game/level.scm
Normal 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*)))
|
|
@ -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>
|
||||
|
|
|
@ -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>
|
||||
|
|
|
@ -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")))
|
||||
|
|
Loading…
Add table
Reference in a new issue