Add support for more objects to map editor.
This commit is contained in:
David Thompson
parent
3f24b3bd89
commit
111f4d37f1
9 changed files with 151 additions and 107 deletions
|
|
@ -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)))))
|
||||
(iota (tile-layer-width layer)))))
|
||||
(iota (tile-layer-height layer))))))
|
||||
(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)
|
||||
("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)
|
||||
(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 (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)))
|
||||
(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)
|
||||
,(tile-map-height tile-map)
|
||||
,(compile-walls tile-map "background"))))))))
|
||||
(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")))))))))
|
||||
(_ (error "file name expected")))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue