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/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
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 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)
|
||||||
|
|
|
@ -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
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"?>
|
<?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>
|
||||||
|
|
|
@ -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>
|
||||||
|
|
|
@ -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")))
|
||||||
|
|
Loading…
Add table
Reference in a new issue