diff options
Diffstat (limited to 'tilemap.scm')
| -rw-r--r-- | tilemap.scm | 235 |
1 files changed, 235 insertions, 0 deletions
diff --git a/tilemap.scm b/tilemap.scm new file mode 100644 index 0000000..6e4dc95 --- /dev/null +++ b/tilemap.scm @@ -0,0 +1,235 @@ +(module tilemap + * + (import scheme + (chicken io) + (chicken base) + (chicken string) + (chicken format) + (chicken process-context) + (chicken pathname) + (chicken pretty-print) + (srfi 1) + matchable + expat + defstruct + (prefix sdl2-image "img:") + (prefix sdl2 "sdl2:")) + +(+ 1 1) + + (defstruct tileset + tilewidth + tileheight + spacing + tilecount + columns + image-source + image) + + (+ 1 1) + + (defstruct layer + name + width + height + map) + + (defstruct object + name + type + x + y + width + height + properties) + + (defstruct tilemap + width + height + tilewidth + tileheight + tileset-source + tileset + layers + objects) + + (defstruct tile + id + rect) + + (define (maybe-do action) + (lambda (value) + (if (eq? value #f) + #f + (action value)))) + + (define (attempt action) + (lambda (value) + (or (action value) value))) + + (define maybe-string->number (maybe-do (attempt string->number))) + + (define (string-alist->alist string-alist) + (map (lambda (pair) (cons (string->symbol (car pair)) + (maybe-string->number (cdr pair)))) + string-alist)) + + (define (parse-tileset string-tileset) + (let ((parser (expat:make-parser)) + (tags '()) + (tileset (make-tileset 0 0 0 0 0 ""))) + (expat:set-start-handler! parser + (lambda (tag attrs) + (let ((symbol-attrs (string-alist->alist attrs))) + (match tag + ("tileset" (set! tileset (alist->tileset symbol-attrs))) + ("image" (tileset-image-source-set! tileset (alist-ref 'source symbol-attrs))) + (_ #f))) + (set! tags (cons tag tags)))) + (expat:set-end-handler! parser (lambda (tag) + (set! tags (cdr tags)))) + (expat:set-character-data-handler! parser (lambda (line) #f)) + (expat:parse parser string-tileset) + tileset)) + + (define (load-tileset file-name) + (call-with-input-file file-name + (lambda (port) + (let* ((tileset (parse-tileset (read-string #f port))) + (image-source (tileset-image-source tileset)) + (base-path (pathname-directory file-name)) + (img-to-load (if (absolute-pathname? image-source) + image-source + (pathname-replace-directory + image-source + (if (pathname-directory image-source) + (format "~a/~a" base-path (pathname-directory image-source)) + base-path))))) + (tileset-image-set! tileset (img:load img-to-load)) + tileset)))) + + (define (parse-tilemap string-tilemap) + (let ((parser (expat:make-parser)) + (tags '()) + (tilemap (make-tilemap width: 0 height: 0 tilewidth: 0 tileheight: 0 + tileset-source: "" tileset: #f + layers: '() objects: '())) + (layer '()) + (object '())) + (expat:set-start-handler! + parser + (lambda (tag attrs) + (let ((symbol-attrs (string-alist->alist attrs))) + (match tag + ("map" + (tilemap-width-set! tilemap (alist-ref 'width symbol-attrs)) + (tilemap-height-set! tilemap (alist-ref 'height symbol-attrs)) + (tilemap-tilewidth-set! tilemap (alist-ref 'tilewidth symbol-attrs)) + (tilemap-tileheight-set! tilemap (alist-ref 'tileheight symbol-attrs))) + ("tileset" + (tilemap-tileset-source-set! tilemap (alist-ref 'source symbol-attrs))) + ("layer" + (set! layer (alist->layer attrs))) + ("object" + (set! object (alist->object symbol-attrs))) + ("property" + (object-properties-set! + object + (cons (cons (alist-ref 'name symbol-attrs) (alist-ref 'value symbol-attrs)) + (or (object-properties object) '())))) + (_ #f)) + (set! tags (cons tag tags))))) + (expat:set-end-handler! + parser + (lambda (tag) + (match tag + ("layer" (begin + (tilemap-layers-set! tilemap + (cons layer (tilemap-layers tilemap))) + (set! layer '()))) + ("object" (tilemap-objects-set! tilemap (cons object (tilemap-objects tilemap)))) + (_ #f)) + (set! tags (cdr tags)))) + (expat:set-character-data-handler! + parser + (lambda (line) + (when (string=? (car tags) "data") + (let ((txt (string-chomp line))) + (when (not (string=? txt "")) + (layer-map-set! layer (append + (or (layer-map layer) '()) + (list (map string->number + (string-split txt ",")))))))))) + (expat:parse parser string-tilemap) + tilemap)) + + (define (tileset-rows tileset) + "Return the number of rows in the tileset" + (inexact->exact (ceiling (/ (tileset-tilecount tileset) (tileset-columns tileset))))) + + (define (tileset-tile tileset tile-id) + ;; Use the tileset's columns setting and the tileheight/tilewidth to + ;; find the tile's x,y location and create a rect + (let* ((tile-num (- tile-id 1)) ; tile-id starts at 1! + (tile-width (tileset-tilewidth tileset)) + (tile-height (tileset-tileheight tileset)) + (tile-x (modulo tile-num (tileset-columns tileset))) + (tile-y (inexact->exact (floor (/ tile-num (tileset-columns tileset))))) + (x (+ (* tile-x tile-width) tile-x)) + (y (+ (* tile-y tile-height) tile-y))) + (make-tile + id: tile-id + rect: (sdl2:make-rect x y tile-width tile-height)))) + + (define (load-tilemap file-name) + (call-with-input-file file-name + (lambda (port) + (let* ((tilemap (parse-tilemap (read-string #f port))) + (base-path (pathname-directory file-name)) + (tileset-source (tilemap-tileset-source tilemap))) + (tilemap-tileset-set! tilemap (load-tileset + (if (absolute-pathname? tileset-source) + tileset-source + (pathname-replace-directory + tileset-source + (if (pathname-directory tileset-source) + (format "~a/~a" base-path (pathname-directory tileset-source)) + base-path)) + ))) + tilemap)))) + + (when #f + + (let ((txt "<?xml version='1.0' encoding='UTF-8'?> +<tileset version='1.10' tiledversion='1.11.2' name='monochrome_transparent' tilewidth='16' tileheight='16' spacing='1' tilecount='1078' columns='49'> + <image source='monochrome-transparent.png' width='832' height='373'/> +</tileset> +")) + (tileset-image (parse-tileset txt))) + + (let ((txt "<?xml version='1.0' encoding='UTF-8'?> +<map version='1.10' tiledversion='1.11.0' orientation='orthogonal' renderorder='right-down' width='40' height='30' tilewidth='16' tileheight='16' infinite='0' nextlayerid='8' nextobjectid='5'> + <tileset firstgid='1' source='monochrome_transparent.tsx'/> + <layer id='3' name='ground' width='40' height='30'> + <data encoding='csv'> +0,0,0,0,168,169,0,0,0,0, +844,0,0,0,0,0,845,546,546,546, +</data> + </layer> + <objectgroup id='7' name='entities'> + <object id='2' name='player' type='Player' gid='29' x='182' y='350.5' width='16' height='16'/> + <object id='3' name='hint' type='Text' x='98.5' y='432.5' width='197' height='78'> + <properties> + <property name='text' value='hit enter to start a macro'/> + </properties> + </object> + <object id='4' name='goal' type='Goal' x='560.935' y='288.641' width='16' height='16'/> + </objectgroup> +</map> +")) + (tilemap-tileset (parse-tilemap txt))) + + (tileset-image (tilemap-tileset (load-tilemap "assets/level-0.tmx"))) + ) + + ) ;; End tilemap module |