664 lines
26 KiB
Scheme
664 lines
26 KiB
Scheme
;;; 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 type image animation properties)
|
||
tile?
|
||
(id tile-id)
|
||
(type tile-type)
|
||
(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) '()))
|
||
(type (assq-ref custom 'type))
|
||
(animation (assq-ref custom 'animation))
|
||
(properties (assq-ref custom 'properties))
|
||
(tile (make-tile id type 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 'object) (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)
|
||
(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 . (,@(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))
|
||
(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)))
|
||
(custom-tiles (map parse-custom-tile ((sxpath '(tile)) node))))
|
||
(make-tileset image tile-width tile-height
|
||
#:margin margin
|
||
#:spacing spacing
|
||
#:name name
|
||
#:first-gid first-gid
|
||
#:properties properties
|
||
#:custom-tiles 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))))))))
|
||
|
||
;; Not a sparse layer packing. Assumes all tiles have something in
|
||
;; them.
|
||
(define (compile-tile-layer tile-map layer-name)
|
||
(let* ((layer (tile-map-layer-ref tile-map layer-name))
|
||
(w (tile-layer-width layer))
|
||
(h (tile-layer-height layer))
|
||
(bv (make-u16vector (* w h))))
|
||
(let y-loop ((y 0))
|
||
(when (< y h)
|
||
(let x-loop ((x 0))
|
||
(when (< x w)
|
||
(let ((tile (tile-layer-ref layer x y)))
|
||
(bytevector-u16-set! bv (* (+ (* y w) x) 2)
|
||
(tile-id (map-tile-ref tile))
|
||
(endianness little)))
|
||
(x-loop (1+ x))))
|
||
(y-loop (1+ y))))
|
||
bv))
|
||
|
||
(define obj:wall:inert 1)
|
||
(define obj:wall:copper 2)
|
||
(define obj:player-spawn 3)
|
||
(define obj:exit 4)
|
||
(define obj:block:copper 5)
|
||
(define obj:block:crate 6)
|
||
(define obj:clock-emitter 7)
|
||
(define obj:floor-switch 8)
|
||
(define obj:gem 9)
|
||
(define obj:gate 10)
|
||
(define obj:and-gate 11)
|
||
(define obj:electric-switch 12)
|
||
(define obj:xor-gate 13)
|
||
(define obj:electron-warp 14)
|
||
(define obj:or-gate 15)
|
||
(define obj:switched-emitter 16)
|
||
|
||
(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)))
|
||
(append-map (lambda (y)
|
||
(concatenate
|
||
(filter-map
|
||
(lambda (x)
|
||
(match (tile-layer-ref layer x y)
|
||
(#f #f)
|
||
((= map-tile-ref tile)
|
||
(match (tile-type tile)
|
||
(#f #f)
|
||
("wall"
|
||
(match (assq-ref (tile-properties tile) 'kind)
|
||
("inert" (list x y obj:wall:inert))
|
||
("copper" (list x y obj:wall:copper))
|
||
(kind (error "unsupported wall kind" kind))))
|
||
("exit" (list x y obj:exit))
|
||
(type (error "unsupported background object" type))))))
|
||
(iota (tile-layer-width layer)))))
|
||
(iota (tile-layer-height layer)))))
|
||
|
||
(define (compile-object-layer tile-map layer-name)
|
||
(define parse-direction
|
||
(match-lambda
|
||
("right" 1)
|
||
("left" 2)
|
||
("up" 3)
|
||
("down" 4)))
|
||
(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)))
|
||
(match type
|
||
('player-spawn (list x y obj:player-spawn))
|
||
('block
|
||
(match (assq-ref properties 'kind)
|
||
("crate" (list x y obj:block:crate))
|
||
("copper" (list x y obj:block:copper))
|
||
(kind (error "unsupported block kind" kind))))
|
||
('floor-switch (list x y obj:floor-switch
|
||
(assq-ref properties 'target-x)
|
||
(assq-ref properties 'target-y)))
|
||
('gem (list x y obj:gem))
|
||
('gate (list x y obj:gate))
|
||
('clock-emitter (list x y obj:clock-emitter
|
||
(assq-ref properties 'interval)))
|
||
('switched-emitter (list x y obj:switched-emitter
|
||
(assq-ref properties 'interval)))
|
||
('and-gate (list x y obj:and-gate
|
||
(parse-direction
|
||
(assq-ref properties 'direction))))
|
||
('xor-gate (list x y obj:xor-gate
|
||
(parse-direction
|
||
(assq-ref properties 'direction))))
|
||
('or-gate (list x y obj:or-gate
|
||
(parse-direction
|
||
(assq-ref properties 'direction))))
|
||
('electric-switch (list x y obj:electric-switch
|
||
(assq-ref properties 'target-x)
|
||
(assq-ref properties 'target-y)))
|
||
('electron-warp (list x y obj:electron-warp
|
||
(assq-ref properties 'target-x)
|
||
(assq-ref properties 'target-y)))
|
||
(_ (error "unsupported object type" type)))))
|
||
(object-layer-objects layer))))
|
||
|
||
(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)))
|
||
(compile-object-layer tile-map "objects")
|
||
(for-each pretty-print
|
||
`((define-module ,module-name
|
||
#:use-module (game level)
|
||
#:export (,proc-name))
|
||
(define (,proc-name collected-gem?)
|
||
(make-level ,(tile-map-width tile-map)
|
||
,(tile-map-height tile-map)
|
||
,(compile-tile-layer tile-map "background")
|
||
,(u8-list->bytevector
|
||
(append
|
||
(compile-environment-layer tile-map "background")
|
||
(compile-object-layer tile-map "objects")))
|
||
collected-gem?))))))
|
||
(_ (error "file name expected")))
|