Add start of tiled map compilation for levels.
This commit is contained in:
David Thompson
parent
ebd57bae3a
commit
3a3f4e31a1
12 changed files with 664 additions and 15 deletions
1
.gitignore
vendored
1
.gitignore
vendored
|
|
@ -1 +1,2 @@
|
||||||
/game.wasm
|
/game.wasm
|
||||||
|
/modules/game/levels/*.scm
|
||||||
|
|
|
||||||
9
Makefile
9
Makefile
|
|
@ -22,9 +22,16 @@ modules = \
|
||||||
modules/srfi/srfi-9.scm \
|
modules/srfi/srfi-9.scm \
|
||||||
modules/srfi/srfi-11.scm
|
modules/srfi/srfi-11.scm
|
||||||
|
|
||||||
game.wasm: game.scm $(modules)
|
levels = \
|
||||||
|
modules/game/levels/level-1.scm
|
||||||
|
|
||||||
|
game.wasm: game.scm $(modules) $(levels)
|
||||||
guild compile-wasm -L modules -o $@ $<
|
guild compile-wasm -L modules -o $@ $<
|
||||||
|
|
||||||
|
$(levels): %.scm: %.tmx scripts/compile-map.scm
|
||||||
|
mkdir -p modules/game/levels
|
||||||
|
guile scripts/compile-map.scm $< > $@
|
||||||
|
|
||||||
serve: game.wasm
|
serve: game.wasm
|
||||||
guile -c '((@ (hoot web-server) serve))'
|
guile -c '((@ (hoot web-server) serve))'
|
||||||
|
|
||||||
|
|
|
||||||
Binary file not shown.
BIN
assets/sounds/no.wav
Normal file
BIN
assets/sounds/no.wav
Normal file
Binary file not shown.
Binary file not shown.
BIN
assets/sounds/push.wav
Normal file
BIN
assets/sounds/push.wav
Normal file
Binary file not shown.
BIN
assets/sounds/undo.wav
Normal file
BIN
assets/sounds/undo.wav
Normal file
Binary file not shown.
40
game.scm
40
game.scm
|
|
@ -26,8 +26,10 @@
|
||||||
(dom media)
|
(dom media)
|
||||||
(dom window)
|
(dom window)
|
||||||
(game actors)
|
(game actors)
|
||||||
|
(game levels level-1)
|
||||||
(game tileset)
|
(game tileset)
|
||||||
(goblins core)
|
(goblins core)
|
||||||
|
(hoot bytevectors)
|
||||||
(hoot ffi)
|
(hoot ffi)
|
||||||
(hoot hashtables)
|
(hoot hashtables)
|
||||||
(ice-9 match)
|
(ice-9 match)
|
||||||
|
|
@ -52,7 +54,14 @@
|
||||||
320 240
|
320 240
|
||||||
(inexact->exact tile-width)
|
(inexact->exact tile-width)
|
||||||
(inexact->exact tile-height)))
|
(inexact->exact tile-height)))
|
||||||
(define audio:bump (make-audio "assets/sounds/bump.wav"))
|
(define* (load-sound-effect name #:key (volume 0.5))
|
||||||
|
(let ((audio (make-audio (string-append "assets/sounds/" name ".wav"))))
|
||||||
|
(set-media-volume! audio volume)
|
||||||
|
audio))
|
||||||
|
(define audio:bump (load-sound-effect "bump"))
|
||||||
|
(define audio:push (load-sound-effect "push"))
|
||||||
|
(define audio:undo (load-sound-effect "undo"))
|
||||||
|
(define audio:no (load-sound-effect "no"))
|
||||||
|
|
||||||
;; Game state
|
;; Game state
|
||||||
(define *actormap* (make-whactormap))
|
(define *actormap* (make-whactormap))
|
||||||
|
|
@ -64,6 +73,8 @@
|
||||||
(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!)
|
||||||
|
|
@ -72,10 +83,11 @@
|
||||||
(set! *snapshots* (cons (copy-whactormap *actormap*) *snapshots*)))
|
(set! *snapshots* (cons (copy-whactormap *actormap*) *snapshots*)))
|
||||||
(define (rollback-snapshot!)
|
(define (rollback-snapshot!)
|
||||||
(match *snapshots*
|
(match *snapshots*
|
||||||
(() #f)
|
(() (media-play audio:no))
|
||||||
((snapshot . older-snapshots)
|
((snapshot . older-snapshots)
|
||||||
(set! *actormap* snapshot)
|
(set! *actormap* snapshot)
|
||||||
(set! *snapshots* older-snapshots))))
|
(set! *snapshots* older-snapshots)
|
||||||
|
(media-play audio:undo))))
|
||||||
|
|
||||||
(define (update-grid!)
|
(define (update-grid!)
|
||||||
(set! *grid* ($ *level* 'describe)))
|
(set! *grid* ($ *level* 'describe)))
|
||||||
|
|
@ -84,7 +96,10 @@
|
||||||
(set! *actormap* (make-whactormap))
|
(set! *actormap* (make-whactormap))
|
||||||
(clear-snapshots!)
|
(clear-snapshots!)
|
||||||
(with-goblins
|
(with-goblins
|
||||||
(set! *level* (spawn ^level level-width level-height))
|
(call-with-values load-level-1
|
||||||
|
(lambda (background level)
|
||||||
|
(set! *background* background)
|
||||||
|
(set! *level* level)))
|
||||||
(update-grid!)))
|
(update-grid!)))
|
||||||
|
|
||||||
;; Update loop
|
;; Update loop
|
||||||
|
|
@ -92,7 +107,8 @@
|
||||||
(save-snapshot!)
|
(save-snapshot!)
|
||||||
(with-goblins
|
(with-goblins
|
||||||
(match ($ *level* 'move-player dir)
|
(match ($ *level* 'move-player dir)
|
||||||
(#f (media-play audio:bump))
|
('bump (media-play audio:bump))
|
||||||
|
('push (media-play audio:push))
|
||||||
(_ #f))
|
(_ #f))
|
||||||
(update-grid!)))
|
(update-grid!)))
|
||||||
|
|
||||||
|
|
@ -154,7 +170,19 @@
|
||||||
(('block type) (draw-block 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-background)
|
||||||
|
(let* ((bv *background*)
|
||||||
|
(len (bytevector-length bv)))
|
||||||
|
(let lp ((i 0))
|
||||||
|
(when (< i len)
|
||||||
|
(let ((x (bytevector-ieee-single-native-ref bv i))
|
||||||
|
(y (bytevector-ieee-single-native-ref bv (+ i 4)))
|
||||||
|
(idx (bytevector-s16-native-ref bv (+ i 8))))
|
||||||
|
(draw-tile context tileset idx x y)
|
||||||
|
(lp (+ i 10)))))))
|
||||||
|
|
||||||
(define (draw-level)
|
(define (draw-level)
|
||||||
|
(draw-background)
|
||||||
(let ((grid *grid*))
|
(let ((grid *grid*))
|
||||||
(let y-loop ((y 0))
|
(let y-loop ((y 0))
|
||||||
(when (< y level-height)
|
(when (< y level-height)
|
||||||
|
|
@ -166,8 +194,6 @@
|
||||||
|
|
||||||
(define (draw prev-time)
|
(define (draw prev-time)
|
||||||
(clear-rect context 0.0 0.0 *canvas-width* *canvas-height*)
|
(clear-rect context 0.0 0.0 *canvas-width* *canvas-height*)
|
||||||
(set-fill-color! context "#cbdbfc")
|
|
||||||
(fill-rect context 0.0 0.0 *canvas-width* *canvas-height*)
|
|
||||||
(set-transform! context 1.0 0.0 0.0 1.0 0.0 0.0)
|
(set-transform! context 1.0 0.0 0.0 1.0 0.0 0.0)
|
||||||
(set-scale! context *canvas-scale* *canvas-scale*)
|
(set-scale! context *canvas-scale* *canvas-scale*)
|
||||||
(draw-level)
|
(draw-level)
|
||||||
|
|
|
||||||
|
|
@ -29,7 +29,7 @@
|
||||||
(('set-wire-state type)
|
(('set-wire-state type)
|
||||||
(bcom (^wall bcom type)))
|
(bcom (^wall bcom type)))
|
||||||
(('describe) `(wall ,type))
|
(('describe) `(wall ,type))
|
||||||
(('collide) 'stop)))
|
(('collide) 'bump)))
|
||||||
|
|
||||||
(define (^block bcom type)
|
(define (^block bcom type)
|
||||||
(match-lambda*
|
(match-lambda*
|
||||||
|
|
@ -42,7 +42,7 @@
|
||||||
(('set-wire-state type)
|
(('set-wire-state type)
|
||||||
(bcom (^block bcom type)))
|
(bcom (^block bcom type)))
|
||||||
(('describe) `(block ,type))
|
(('describe) `(block ,type))
|
||||||
(('collide) 'displace)))
|
(('collide) 'push)))
|
||||||
|
|
||||||
(define (^clock-emitter bcom interval)
|
(define (^clock-emitter bcom interval)
|
||||||
(define timer (spawn ^cell 0))
|
(define timer (spawn ^cell 0))
|
||||||
|
|
@ -59,7 +59,7 @@
|
||||||
'copper))))
|
'copper))))
|
||||||
(('set-wire-state type) #f)
|
(('set-wire-state type) #f)
|
||||||
(('describe) '(clock-emitter))
|
(('describe) '(clock-emitter))
|
||||||
(('collide) 'stop)))
|
(('collide) 'bump)))
|
||||||
|
|
||||||
(define (^player bcom)
|
(define (^player bcom)
|
||||||
(match-lambda*
|
(match-lambda*
|
||||||
|
|
@ -106,9 +106,9 @@
|
||||||
($ player-coords (vector x y)))
|
($ player-coords (vector x y)))
|
||||||
(occupant
|
(occupant
|
||||||
(match ($ occupant 'collide)
|
(match ($ occupant 'collide)
|
||||||
('stop #f)
|
('bump 'bump)
|
||||||
('goal (pk 'GOAL))
|
('goal (pk 'GOAL))
|
||||||
('displace
|
('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)
|
||||||
(#f
|
(#f
|
||||||
|
|
@ -116,7 +116,7 @@
|
||||||
($ cell player)
|
($ cell player)
|
||||||
($ old-cell #f)
|
($ old-cell #f)
|
||||||
($ player-coords (vector x y))
|
($ player-coords (vector x y))
|
||||||
'displace)
|
'push)
|
||||||
(_ #f)))))))))))
|
(_ #f)))))))))))
|
||||||
(define (warp-player x y)
|
(define (warp-player x y)
|
||||||
($ (grid-ref grid x y) player)
|
($ (grid-ref grid x y) player)
|
||||||
|
|
@ -182,7 +182,7 @@
|
||||||
|
|
||||||
($ (grid-ref grid 4 3) (spawn ^clock-emitter 3))
|
($ (grid-ref grid 4 3) (spawn ^clock-emitter 3))
|
||||||
($ (grid-ref grid 5 3) (spawn ^wall 'copper))
|
($ (grid-ref grid 5 3) (spawn ^wall 'copper))
|
||||||
($ (grid-ref grid 6 4) (spawn ^block 'copper))
|
($ (grid-ref grid 6 5) (spawn ^block 'copper))
|
||||||
($ (grid-ref grid 7 3) (spawn ^wall 'copper))
|
($ (grid-ref grid 7 3) (spawn ^wall 'copper))
|
||||||
($ (grid-ref grid 8 3) (spawn ^wall 'copper))
|
($ (grid-ref grid 8 3) (spawn ^wall 'copper))
|
||||||
($ (grid-ref grid 9 3) (spawn ^wall 'copper))
|
($ (grid-ref grid 9 3) (spawn ^wall 'copper))
|
||||||
|
|
|
||||||
23
modules/game/levels/level-1.tmx
Normal file
23
modules/game/levels/level-1.tmx
Normal file
|
|
@ -0,0 +1,23 @@
|
||||||
|
<?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">
|
||||||
|
<tileset firstgid="1" source="tiles.tsx"/>
|
||||||
|
<layer id="1" name="background" width="20" height="15">
|
||||||
|
<data encoding="csv">
|
||||||
|
24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,
|
||||||
|
24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,
|
||||||
|
24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,
|
||||||
|
24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,
|
||||||
|
24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,
|
||||||
|
24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,
|
||||||
|
24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,
|
||||||
|
24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,
|
||||||
|
24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,
|
||||||
|
24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,
|
||||||
|
24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,
|
||||||
|
24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,
|
||||||
|
24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,
|
||||||
|
24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,
|
||||||
|
24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24
|
||||||
|
</data>
|
||||||
|
</layer>
|
||||||
|
</map>
|
||||||
4
modules/game/levels/tiles.tsx
Normal file
4
modules/game/levels/tiles.tsx
Normal file
|
|
@ -0,0 +1,4 @@
|
||||||
|
<?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"/>
|
||||||
|
</tileset>
|
||||||
588
scripts/compile-map.scm
Normal file
588
scripts/compile-map.scm
Normal file
|
|
@ -0,0 +1,588 @@
|
||||||
|
;;; Adapted from the Chickadee Game Toolkit
|
||||||
|
;;; Copyright © 2018, 2020, 2021, 2023 David Thompson <dthompson2@worcester.edu>
|
||||||
|
;;;
|
||||||
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||||
|
;;; you may not use this file except in compliance with the License.
|
||||||
|
;;; You may obtain a copy of the License at
|
||||||
|
;;;
|
||||||
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||||||
|
;;;
|
||||||
|
;;; Unless required by applicable law or agreed to in writing, software
|
||||||
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||||||
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||||
|
;;; See the License for the specific language governing permissions and
|
||||||
|
;;; limitations under the License.
|
||||||
|
|
||||||
|
(use-modules (ice-9 match)
|
||||||
|
(ice-9 pretty-print)
|
||||||
|
((rnrs base) #:select (mod))
|
||||||
|
(rnrs bytevectors)
|
||||||
|
(srfi srfi-1)
|
||||||
|
(srfi srfi-11)
|
||||||
|
(srfi srfi-9)
|
||||||
|
(srfi srfi-43)
|
||||||
|
(sxml simple)
|
||||||
|
(sxml xpath))
|
||||||
|
|
||||||
|
(define-record-type <vec2>
|
||||||
|
(make-vec2 x y)
|
||||||
|
vec2?
|
||||||
|
(x vec2-x)
|
||||||
|
(y vec2-y))
|
||||||
|
|
||||||
|
(define-record-type <rect>
|
||||||
|
(make-rect x y width height)
|
||||||
|
rect?
|
||||||
|
(x rect-x)
|
||||||
|
(y rect-y)
|
||||||
|
(width rect-width)
|
||||||
|
(height rect-height))
|
||||||
|
|
||||||
|
(define-record-type <color>
|
||||||
|
(make-color r g b a)
|
||||||
|
color?
|
||||||
|
(r color-r)
|
||||||
|
(g color-g)
|
||||||
|
(b color-b)
|
||||||
|
(a color-a))
|
||||||
|
|
||||||
|
(define-record-type <image>
|
||||||
|
(make-image src width height trans)
|
||||||
|
image?
|
||||||
|
(src image-src)
|
||||||
|
(width image-width)
|
||||||
|
(height image-height)
|
||||||
|
(trans image-trans))
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Tileset
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(define-record-type <animation-frame>
|
||||||
|
(make-animation-frame id duration)
|
||||||
|
animation-frame?
|
||||||
|
(id animation-frame-id)
|
||||||
|
(duration animation-frame-duration))
|
||||||
|
|
||||||
|
(define-record-type <animation>
|
||||||
|
(%make-animation frames duration)
|
||||||
|
animation?
|
||||||
|
(frames animation-frames)
|
||||||
|
(duration animation-duration))
|
||||||
|
|
||||||
|
(define (make-animation atlas first-gid frame-spec)
|
||||||
|
(let ((frames (map (match-lambda
|
||||||
|
((id duration)
|
||||||
|
(make-animation-frame (- id first-gid) duration)))
|
||||||
|
frame-spec)))
|
||||||
|
(%make-animation (list->vector frames)
|
||||||
|
(fold (lambda (frame memo)
|
||||||
|
(+ (animation-frame-duration frame) memo))
|
||||||
|
0 frames))))
|
||||||
|
|
||||||
|
(define (animation-frame-for-time animation time)
|
||||||
|
(let* ((time (mod time (animation-duration animation)))
|
||||||
|
(frames (animation-frames animation)))
|
||||||
|
(let loop ((i 0)
|
||||||
|
(t 0))
|
||||||
|
(let* ((frame (vector-ref frames i))
|
||||||
|
(d (animation-frame-duration frame)))
|
||||||
|
(if (< time (+ t d))
|
||||||
|
frame
|
||||||
|
(loop (+ i 1) (+ t d)))))))
|
||||||
|
|
||||||
|
(define-record-type <tile>
|
||||||
|
(make-tile id image animation properties)
|
||||||
|
tile?
|
||||||
|
(id tile-id)
|
||||||
|
(image tile-image)
|
||||||
|
(animation tile-animation)
|
||||||
|
(properties tile-properties))
|
||||||
|
|
||||||
|
(define (animated-tile? tile)
|
||||||
|
(animation? (tile-animation tile)))
|
||||||
|
|
||||||
|
(define (tile-frame-for-time tile time)
|
||||||
|
(let ((animation (tile-animation tile)))
|
||||||
|
(and animation (animation-frame-for-time animation time))))
|
||||||
|
|
||||||
|
(define-record-type <tileset>
|
||||||
|
(%make-tileset name first-gid tile-width tile-height
|
||||||
|
margin spacing rows columns tiles properties)
|
||||||
|
tileset?
|
||||||
|
(name tileset-name)
|
||||||
|
(first-gid tileset-first-gid)
|
||||||
|
(tile-width tileset-tile-width)
|
||||||
|
(tile-height tileset-tile-height)
|
||||||
|
(margin tileset-margin)
|
||||||
|
(spacing tileset-spacing)
|
||||||
|
(rows tileset-rows)
|
||||||
|
(columns tileset-columns)
|
||||||
|
(tiles tileset-tiles)
|
||||||
|
(properties tileset-properties))
|
||||||
|
|
||||||
|
(define (tileset-dimensions image tile-width tile-height margin spacing)
|
||||||
|
(values (inexact->exact
|
||||||
|
(ceiling (/ (- (image-width image) margin)
|
||||||
|
(+ tile-width spacing))))
|
||||||
|
(inexact->exact
|
||||||
|
(ceiling (/ (- (image-height image) margin)
|
||||||
|
(+ tile-height spacing))))))
|
||||||
|
|
||||||
|
(define* (make-tileset image tile-width tile-height #:key
|
||||||
|
(first-gid 1) (margin 0) (spacing 0)
|
||||||
|
(name "anonymous") (properties '())
|
||||||
|
(custom-tiles '()))
|
||||||
|
(let-values (((columns rows)
|
||||||
|
(tileset-dimensions image tile-width tile-height margin spacing)))
|
||||||
|
(let* ((tiles (make-vector (* columns rows))))
|
||||||
|
(do ((i 0 (+ i 1)))
|
||||||
|
((= i (vector-length tiles)))
|
||||||
|
(let* ((id (+ first-gid i))
|
||||||
|
(custom (or (assv-ref custom-tiles id) '()))
|
||||||
|
(animation (assq-ref custom 'animation))
|
||||||
|
(properties (assq-ref custom 'properties))
|
||||||
|
(tile (make-tile id i
|
||||||
|
(and animation
|
||||||
|
(make-animation image first-gid animation))
|
||||||
|
(or properties '()))))
|
||||||
|
(vector-set! tiles i tile)))
|
||||||
|
(%make-tileset name first-gid tile-width tile-height margin spacing
|
||||||
|
rows columns tiles properties))))
|
||||||
|
|
||||||
|
(define (tileset-size tileset)
|
||||||
|
(vector-length (tileset-tiles tileset)))
|
||||||
|
|
||||||
|
(define (tileset-ref tileset i)
|
||||||
|
(vector-ref (tileset-tiles tileset) (- i (tileset-first-gid tileset))))
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Object Layer
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(define-record-type <object-layer>
|
||||||
|
(%make-object-layer name objects properties)
|
||||||
|
object-layer?
|
||||||
|
(name object-layer-name)
|
||||||
|
(objects object-layer-objects)
|
||||||
|
(properties object-layer-properties))
|
||||||
|
|
||||||
|
(define-record-type <polygon>
|
||||||
|
(make-polygon points)
|
||||||
|
polygon?
|
||||||
|
(points polygon-points))
|
||||||
|
|
||||||
|
(define-record-type <map-object>
|
||||||
|
(%make-map-object id name type shape properties)
|
||||||
|
map-object?
|
||||||
|
(id map-object-id)
|
||||||
|
(name map-object-name)
|
||||||
|
(type map-object-type)
|
||||||
|
(shape map-object-shape)
|
||||||
|
(properties map-object-properties))
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Tile Layer
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(define-record-type <map-tile>
|
||||||
|
(%make-map-tile tile flipped-horizontally? flipped-vertically?
|
||||||
|
flipped-diagonally?)
|
||||||
|
map-tile?
|
||||||
|
(tile map-tile-ref)
|
||||||
|
(flipped-horizontally? map-tile-flipped-horizontally?)
|
||||||
|
(flipped-vertically? map-tile-flipped-vertically?)
|
||||||
|
(flipped-diagonally? map-tile-flipped-diagonally?))
|
||||||
|
|
||||||
|
(define* (make-map-tile tile #:key flipped-horizontally?
|
||||||
|
flipped-vertically? flipped-diagonally?)
|
||||||
|
(%make-map-tile tile flipped-horizontally? flipped-vertically?
|
||||||
|
flipped-diagonally?))
|
||||||
|
|
||||||
|
(define-record-type <tile-layer>
|
||||||
|
(%make-tile-layer name width height properties tiles)
|
||||||
|
tile-layer?
|
||||||
|
(name tile-layer-name)
|
||||||
|
(width tile-layer-width)
|
||||||
|
(height tile-layer-height)
|
||||||
|
(properties tile-layer-properties)
|
||||||
|
(tiles tile-layer-tiles))
|
||||||
|
|
||||||
|
(define* (make-tile-layer width height tile-width tile-height #:key
|
||||||
|
(name "anonymous")
|
||||||
|
(properties '()))
|
||||||
|
(%make-tile-layer name width height properties (make-vector (* width height))))
|
||||||
|
|
||||||
|
(define (tile-layer-bounds-check layer x y)
|
||||||
|
(unless (and (>= x 0) (>= y 0)
|
||||||
|
(< x (tile-layer-width layer))
|
||||||
|
(< y (tile-layer-height layer)))
|
||||||
|
(error "tile layer coordinates out of bounds" layer x y)))
|
||||||
|
|
||||||
|
(define (tile-layer-ref layer x y)
|
||||||
|
(vector-ref (tile-layer-tiles layer) (+ (* y (tile-layer-width layer)) x)))
|
||||||
|
|
||||||
|
(define (tile-layer-set! layer x y tile)
|
||||||
|
(vector-set! (tile-layer-tiles layer) (+ (* y (tile-layer-width layer)) x) tile))
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Tile Map
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(define-record-type <tile-map>
|
||||||
|
(%make-tile-map orientation width height tile-width tile-height
|
||||||
|
tilesets layers properties)
|
||||||
|
tile-map?
|
||||||
|
(orientation tile-map-orientation)
|
||||||
|
(width tile-map-width)
|
||||||
|
(height tile-map-height)
|
||||||
|
(tile-width tile-map-tile-width)
|
||||||
|
(tile-height tile-map-tile-height)
|
||||||
|
(tilesets tile-map-tilesets)
|
||||||
|
(layers tile-map-layers)
|
||||||
|
(properties tile-map-properties))
|
||||||
|
|
||||||
|
(define* (make-tile-map width height tile-width tile-height #:key
|
||||||
|
(orientation 'orthogonal) (tilesets '())
|
||||||
|
(layers '()) (properties '()))
|
||||||
|
"Make a tile map that is WIDTH x HEIGHT tiles in size and each tile
|
||||||
|
is TILE-WIDTH x TILE-HEIGHT pixels in size. TILESETS is a list of
|
||||||
|
tilesets to be associated with the map. LAYERS is a list of object
|
||||||
|
and/or tile layers, sorted from bottom to top. PROPERTIES is an alist
|
||||||
|
of arbitrary custom data to associate with the map. Currently, only
|
||||||
|
the default ORIENTATION value of 'orthogonal' is supported."
|
||||||
|
(unless (eq? orientation 'orthogonal)
|
||||||
|
(error "unsupport tile map orientation" orientation))
|
||||||
|
(%make-tile-map orientation width height tile-width tile-height
|
||||||
|
tilesets (list->vector layers) properties))
|
||||||
|
|
||||||
|
(define (tile-map-layer-ref tile-map name)
|
||||||
|
"Return the map layer named NAME."
|
||||||
|
(define (layer-name layer)
|
||||||
|
(if (tile-layer? layer)
|
||||||
|
(tile-layer-name layer)
|
||||||
|
(object-layer-name layer)))
|
||||||
|
(let ((layers (tile-map-layers tile-map)))
|
||||||
|
(let loop ((i 0))
|
||||||
|
(cond
|
||||||
|
((= i (vector-length layers))
|
||||||
|
#f)
|
||||||
|
((string=? name (layer-name (vector-ref layers i)))
|
||||||
|
(vector-ref layers i))
|
||||||
|
(else
|
||||||
|
(loop (+ i 1)))))))
|
||||||
|
|
||||||
|
(define (point->tile tile-map x y)
|
||||||
|
"Translate the pixel coordinates (X, Y) into tile coordinates."
|
||||||
|
(values (inexact->exact (floor (/ x (tile-map-tile-width tile-map))))
|
||||||
|
(inexact->exact (floor (/ y (tile-map-tile-height tile-map))))))
|
||||||
|
|
||||||
|
(define* (load-tile-map file-name)
|
||||||
|
"Load the Tiled TMX formatted map in FILE-NAME."
|
||||||
|
(define map-directory
|
||||||
|
(if (absolute-file-name? file-name)
|
||||||
|
(dirname file-name)
|
||||||
|
(string-append (getcwd) "/" (dirname file-name))))
|
||||||
|
(define (scope file-name)
|
||||||
|
(string-append map-directory "/" file-name))
|
||||||
|
(define* (attr node name #:optional (parse identity))
|
||||||
|
(let ((result ((sxpath `(@ ,name *text*)) node)))
|
||||||
|
(if (null? result)
|
||||||
|
#f
|
||||||
|
(parse (car result)))))
|
||||||
|
(define (parse-color-channel s start)
|
||||||
|
(/ (string->number (substring s start (+ start 2)) 16) 255.0))
|
||||||
|
(define (parse-property node)
|
||||||
|
(let ((name (attr node 'name string->symbol))
|
||||||
|
(type (or (attr node 'type string->symbol) 'string))
|
||||||
|
(value (attr node 'value)))
|
||||||
|
(cons name
|
||||||
|
(match type
|
||||||
|
((or 'string 'file) value)
|
||||||
|
('bool (not (string=? value "false")))
|
||||||
|
((or 'int 'float) (string->number value))
|
||||||
|
('color
|
||||||
|
(make-color (parse-color-channel value 3)
|
||||||
|
(parse-color-channel value 5)
|
||||||
|
(parse-color-channel value 7)
|
||||||
|
(parse-color-channel value 1)))
|
||||||
|
(_ (error "unsupported property type" type))))))
|
||||||
|
(define (parse-image node)
|
||||||
|
(let ((source (attr node 'source))
|
||||||
|
(width (string->number (attr node 'width)))
|
||||||
|
(height (string->number (attr node 'height)))
|
||||||
|
(trans (attr node 'trans)))
|
||||||
|
(make-image (scope source) width height trans)))
|
||||||
|
(define (invert-tile-id id first-gid rows columns)
|
||||||
|
(let ((id* (- id first-gid)))
|
||||||
|
(+ (* (- rows (floor (/ id* columns)) 1)
|
||||||
|
columns)
|
||||||
|
(modulo id* columns)
|
||||||
|
first-gid)))
|
||||||
|
(define (parse-frame node first-gid rows columns)
|
||||||
|
(let ((tile-id (attr node 'tileid string->number))
|
||||||
|
(duration (attr node 'duration string->number)))
|
||||||
|
(list (+ first-gid tile-id ;; (invert-tile-id tile-id 0 rows columns)
|
||||||
|
)
|
||||||
|
(/ duration 1000.0))))
|
||||||
|
(define (parse-tiles nodes first-gid rows columns)
|
||||||
|
(let ((frames (sxpath '(animation frame)))
|
||||||
|
(properties (sxpath '(properties property))))
|
||||||
|
(fold (lambda (node memo)
|
||||||
|
(let ((id (+ first-gid (attr node 'id string->number)
|
||||||
|
;; (invert-tile-id (attr node 'id string->number)
|
||||||
|
;; 0 rows columns)
|
||||||
|
)))
|
||||||
|
(cons `(,id . ((animation . ,(map (lambda (f)
|
||||||
|
(parse-frame f first-gid
|
||||||
|
rows columns))
|
||||||
|
(frames node)))
|
||||||
|
(properties . ,(map parse-property
|
||||||
|
(properties node)))))
|
||||||
|
memo)))
|
||||||
|
'()
|
||||||
|
nodes)))
|
||||||
|
(define (first-gid node)
|
||||||
|
(attr node 'firstgid string->number))
|
||||||
|
(define (parse-tileset node first-gid)
|
||||||
|
(let* ((name (attr node 'name))
|
||||||
|
(tile-width (attr node 'tilewidth string->number))
|
||||||
|
(tile-height (attr node 'tileheight string->number))
|
||||||
|
(margin (or (attr node 'margin string->number) 0))
|
||||||
|
(spacing (or (attr node 'spacing string->number) 0))
|
||||||
|
(image (parse-image ((sxpath '(image)) node)))
|
||||||
|
(properties (map parse-property
|
||||||
|
((sxpath '(properties property)) node))))
|
||||||
|
(make-tileset image tile-width tile-height
|
||||||
|
#:margin margin
|
||||||
|
#:spacing spacing
|
||||||
|
#:name name
|
||||||
|
#:first-gid first-gid
|
||||||
|
#:properties properties
|
||||||
|
#:custom-tiles '())))
|
||||||
|
(define (parse-external-tileset node)
|
||||||
|
(let* ((first-gid (attr node 'firstgid string->number))
|
||||||
|
(source (scope (attr node 'source)))
|
||||||
|
(tree (call-with-input-file source xml->sxml)))
|
||||||
|
(parse-tileset (car ((sxpath '(tileset)) tree)) first-gid)))
|
||||||
|
(define (parse-tileset* node)
|
||||||
|
(if (attr node 'source)
|
||||||
|
(parse-external-tileset node)
|
||||||
|
(parse-tileset node (first-gid node))))
|
||||||
|
(define (tile-gid->map-tile raw-gid tilesets x y tile-width tile-height)
|
||||||
|
;; The top 3 bits of the tile gid are flags for various types of
|
||||||
|
;; flipping.
|
||||||
|
(let* ((flipped-horizontally? (> (logand raw-gid #x80000000) 0))
|
||||||
|
(flipped-vertically? (> (logand raw-gid #x40000000) 0))
|
||||||
|
(flipped-diagonally? (> (logand raw-gid #x20000000) 0))
|
||||||
|
;; Remove the upper 3 bits to get the true tile id.
|
||||||
|
(gid (logand raw-gid #x1FFFFFFF))
|
||||||
|
(tileset (find (lambda (t)
|
||||||
|
(and (>= gid (tileset-first-gid t))
|
||||||
|
(< gid (+ (tileset-first-gid t)
|
||||||
|
(tileset-size t)))))
|
||||||
|
tilesets))
|
||||||
|
(tw (tileset-tile-width tileset))
|
||||||
|
(th (tileset-tile-height tileset))
|
||||||
|
(first-gid (tileset-first-gid tileset))
|
||||||
|
(rows (tileset-rows tileset))
|
||||||
|
(columns (tileset-columns tileset))
|
||||||
|
(id (- gid first-gid) ;; (invert-tile-id gid first-gid rows columns)
|
||||||
|
))
|
||||||
|
(make-map-tile (tileset-ref tileset id)
|
||||||
|
#:flipped-horizontally? flipped-horizontally?
|
||||||
|
#:flipped-vertically? flipped-vertically?
|
||||||
|
#:flipped-diagonally? flipped-diagonally?)))
|
||||||
|
(define (tile-gids->map-tiles gids width height tilesets)
|
||||||
|
(let ((tiles (make-vector (* width height))))
|
||||||
|
(let y-loop ((y 0)
|
||||||
|
(rows gids))
|
||||||
|
(when (< y height)
|
||||||
|
(match rows
|
||||||
|
((row . rest)
|
||||||
|
(let x-loop ((x 0)
|
||||||
|
(columns row))
|
||||||
|
(when (< x width)
|
||||||
|
(match columns
|
||||||
|
((gid . rest)
|
||||||
|
(vector-set! tiles
|
||||||
|
(+ (* width y) x)
|
||||||
|
(if (zero? gid)
|
||||||
|
#f
|
||||||
|
(tile-gid->map-tile gid tilesets
|
||||||
|
x y width height)))
|
||||||
|
(x-loop (+ x 1) rest)))))
|
||||||
|
(y-loop (+ y 1) rest)))))
|
||||||
|
tiles))
|
||||||
|
(define (parse-csv lines width height tilesets)
|
||||||
|
(let ((gids (map (lambda (line)
|
||||||
|
(filter-map (lambda (s)
|
||||||
|
(and (not (string-null? s))
|
||||||
|
(string->number s)))
|
||||||
|
(string-split line #\,)))
|
||||||
|
(take (drop (string-split lines #\newline) 1) height))))
|
||||||
|
(tile-gids->map-tiles gids width height tilesets)))
|
||||||
|
(define (parse-layer-data node width height tilesets)
|
||||||
|
(let ((encoding (attr node 'encoding string->symbol))
|
||||||
|
(data (car ((sxpath '(*text*)) node))))
|
||||||
|
(match encoding
|
||||||
|
('csv (parse-csv data width height tilesets))
|
||||||
|
(_ (error "unsupported tile layer encoding" encoding)))))
|
||||||
|
(define (parse-tile-layer node tile-width tile-height tilesets)
|
||||||
|
(let* ((name (attr node 'name))
|
||||||
|
(width (attr node 'width string->number))
|
||||||
|
(height (attr node 'height string->number))
|
||||||
|
(tiles (parse-layer-data ((sxpath '(data)) node)
|
||||||
|
width height tilesets))
|
||||||
|
(properties (map parse-property
|
||||||
|
((sxpath '(properties property)) node)))
|
||||||
|
(layer (make-tile-layer width height tile-width tile-height
|
||||||
|
#:name name
|
||||||
|
#:properties properties)))
|
||||||
|
(do ((y 0 (+ y 1)))
|
||||||
|
((= y height))
|
||||||
|
(do ((x 0 (+ x 1)))
|
||||||
|
((= x width))
|
||||||
|
(tile-layer-set! layer x y (vector-ref tiles (+ (* y width) x)))))
|
||||||
|
layer))
|
||||||
|
(define (parse-polygon node pixel-height)
|
||||||
|
(make-polygon
|
||||||
|
(list->vector
|
||||||
|
(map (lambda (s)
|
||||||
|
(match (string-split s #\,)
|
||||||
|
((x y)
|
||||||
|
(make-vec2 (string->number x) (string->number y)))))
|
||||||
|
(string-split (attr node 'points) #\space)))))
|
||||||
|
(define (parse-object node pixel-height)
|
||||||
|
(let* ((id (attr node 'id string->number))
|
||||||
|
(name (attr node 'name))
|
||||||
|
(type (attr node 'type string->symbol))
|
||||||
|
(x (attr node 'x string->number))
|
||||||
|
(y (attr node 'y string->number))
|
||||||
|
(width (attr node 'width string->number))
|
||||||
|
(height (attr node 'height string->number))
|
||||||
|
(shape (if (and width height)
|
||||||
|
(make-rect x y width height)
|
||||||
|
(parse-polygon (car ((sxpath '(polygon)) node))
|
||||||
|
pixel-height)))
|
||||||
|
(properties (map parse-property
|
||||||
|
((sxpath '(properties property)) node))))
|
||||||
|
(%make-map-object id name type shape properties)))
|
||||||
|
(define (parse-object-layer node pixel-height)
|
||||||
|
(let ((name (attr node 'name))
|
||||||
|
(objects (map (lambda (node)
|
||||||
|
(parse-object node pixel-height))
|
||||||
|
((sxpath '(object)) node)))
|
||||||
|
(properties (map parse-property
|
||||||
|
((sxpath '(properties property)) node))))
|
||||||
|
(%make-object-layer name objects properties)))
|
||||||
|
(let* ((tree (call-with-input-file file-name xml->sxml))
|
||||||
|
(m ((sxpath '(map)) tree))
|
||||||
|
(version (attr m 'version))
|
||||||
|
(orientation (attr m 'orientation string->symbol))
|
||||||
|
(width (attr m 'width string->number))
|
||||||
|
(height (attr m 'height string->number))
|
||||||
|
(tile-width (attr m 'tilewidth string->number))
|
||||||
|
(tile-height (attr m 'tileheight string->number))
|
||||||
|
(properties ((sxpath '(map properties property)) tree))
|
||||||
|
(tilesets (map parse-tileset* ((sxpath '(map tileset)) tree)))
|
||||||
|
(layers ((node-or (sxpath '(map layer))
|
||||||
|
(sxpath '(map objectgroup)))
|
||||||
|
tree)))
|
||||||
|
(make-tile-map width height tile-width tile-height
|
||||||
|
#:orientation orientation
|
||||||
|
#:tilesets tilesets
|
||||||
|
#:layers (map (lambda (node)
|
||||||
|
(match node
|
||||||
|
(('layer . _)
|
||||||
|
(parse-tile-layer node tile-width tile-height tilesets))
|
||||||
|
(('objectgroup . _)
|
||||||
|
(parse-object-layer node (* height tile-height)))))
|
||||||
|
layers)
|
||||||
|
#:properties (map parse-property properties))))
|
||||||
|
|
||||||
|
(define (bytevector-concat bvs)
|
||||||
|
(let* ((size (fold (lambda (bv sum)
|
||||||
|
(+ sum (bytevector-length bv)))
|
||||||
|
0 bvs))
|
||||||
|
(new-bv (make-bytevector size)))
|
||||||
|
(let loop ((bvs bvs) (offset 0))
|
||||||
|
(match bvs
|
||||||
|
(() new-bv)
|
||||||
|
((bv . rest)
|
||||||
|
(let ((len (bytevector-length bv)))
|
||||||
|
(bytevector-copy! bv 0 new-bv offset len)
|
||||||
|
(loop rest (+ offset len))))))))
|
||||||
|
|
||||||
|
(define (compile-tile-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)))
|
||||||
|
(bytevector-concat
|
||||||
|
(append-map (lambda (y)
|
||||||
|
(filter-map (lambda (x)
|
||||||
|
(let ((tile (tile-layer-ref layer x y)))
|
||||||
|
(and tile
|
||||||
|
(let ((bv (make-bytevector 10)))
|
||||||
|
(bytevector-ieee-single-native-set! bv 0 (* x tw))
|
||||||
|
(bytevector-ieee-single-native-set! bv 4 (* y th))
|
||||||
|
(bytevector-s16-native-set! bv 8 (tile-id (map-tile-ref tile)))
|
||||||
|
bv))))
|
||||||
|
(iota (tile-layer-width layer))))
|
||||||
|
(iota (tile-layer-height layer))))))
|
||||||
|
|
||||||
|
(define (compile-collision-layer layer)
|
||||||
|
(u8-list->bytevector
|
||||||
|
(append-map (lambda (y)
|
||||||
|
(map (lambda (x)
|
||||||
|
(if (tile-layer-ref layer x y) 1 0))
|
||||||
|
(iota (tile-layer-width 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)
|
||||||
|
(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))))))
|
||||||
|
|
||||||
|
(define (basename-strip-extension file-name)
|
||||||
|
(match (string-split (basename file-name) #\.)
|
||||||
|
((base . _) base)))
|
||||||
|
|
||||||
|
(match (command-line)
|
||||||
|
((_ file-name)
|
||||||
|
(let* ((name (basename-strip-extension file-name))
|
||||||
|
(module-name `(game levels ,(string->symbol name)))
|
||||||
|
(proc-name (string->symbol (string-append "load-" name)))
|
||||||
|
(tile-map (load-tile-map file-name)))
|
||||||
|
(for-each pretty-print
|
||||||
|
`((define-module ,module-name
|
||||||
|
#:use-module (game actors)
|
||||||
|
#:use-module (goblins core)
|
||||||
|
#:use-module (math vector)
|
||||||
|
#:export (,proc-name))
|
||||||
|
(define (,proc-name)
|
||||||
|
(values ,(compile-tile-layer tile-map "background")
|
||||||
|
(spawn ^level
|
||||||
|
,(tile-map-width tile-map)
|
||||||
|
,(tile-map-height tile-map))))))))
|
||||||
|
(_ (error "file name expected")))
|
||||||
Loading…
Add table
Reference in a new issue