123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207 |
- ;;;; Copyright ยฉ 2023, Jaidyn Ann <jadedctrl@posteo.at>
- ;;;;
- ;;;; This program is free software: you can redistribute it and/or
- ;;;; modify it under the terms of the GNU General Public License as
- ;;;; published by the Free Software Foundation, either version 3 of
- ;;;; the License, or (at your option) any later version.
- ;;;;
- ;;;; This program is distributed in the hope that it will be useful,
- ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
- ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ;;;; GNU General Public License for more details.
- ;;;;
- ;;;; You should have received a copy of the GNU General Public License
- ;;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
- ;;;; FLORA-SEARCH-AURORA.OVERWORLD.TILED
- ;;;; Import a Tiled-format (TMX) map into the hash-table/plist/alist format
- ;;;; used by the overworld.
- (defpackage :flora-search-aurora.overworld.tiled
- (:nicknames :fsa.o.t :overworld.tiled :๐.๐จ)
- (:use :cl
- :flora-search-aurora.overworld.util)
- (:export #:load-map))
- (in-package :flora-search-aurora.overworld.tiled)
- ;;; โโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโ
- ;;; Misc. utility
- ;;; โโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโ
- (defun collect-items-into-groups (list key-function &key (groups '()))
- "Given a LIST of items and a KEY-FUNCTION categorizing an individual item
- (returning a โcategoryโ symbol for any given item), return an sorted
- associative list built upon GROUPS.
- If NIL is returned from KEY-FUNCTION, the given item is thrown out."
- (loop for item in list
- do (let ((key (apply key-function (list item))))
- (when key
- (setf (assoc-utils:aget groups key)
- (append (assoc-utils:aget groups key)
- (list item))))))
- groups)
- (defun tiled-coords->world-coords (x y tiled-map)
- "Given X & Y coordinates with a parsed Tiled map, return the appropriate
- character-scale world coordinates in plist form."
- (list :x (floor (/ x (cl-tiled:map-tile-width tiled-map)))
- :y (floor (/ y (cl-tiled:map-tile-height tiled-map)))))
- ;;; โโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโ
- ;;; Object-layer (Persons/Triggers)
- ;;; โโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโ
- (defun tiled-rectangle-p (tiled-obj)
- "Whether or not a Tiled object is a valid rectangle."
- (and (> (cl-tiled:rect-width tiled-obj) 0)
- (> (cl-tiled:rect-height tiled-obj) 0)))
- (defun tiled-object->entity (tiled-obj tiled-map)
- "Convert a Tiled object into an entity plist."
- (when (not (tiled-rectangle-p tiled-obj))
- (let ((properties (cl-tiled:properties tiled-obj)))
- (append
- (list (โฆ:string->symbol (gethash "id" properties)))
- (loop for key being the hash-keys in properties
- for val being the hash-values in properties
- collect (intern (string-upcase key) "KEYWORD")
- collect val)
- (list
- :face (gethash "normal-face" properties)
- :coords (tiled-coords->world-coords (cl-tiled:object-x tiled-obj)
- (cl-tiled:object-y tiled-obj)
- tiled-map))))))
- (defun tiled-object->trigger (tiled-obj tiled-map)
- "Convert a Tiled object into a โtriggerโ plist. That is, a rectangle with
- a :FUNCTION to be triggered when itโs stepped upon."
- (when (tiled-rectangle-p tiled-obj)
- (let ((properties (cl-tiled:properties tiled-obj))
- (obj-x (cl-tiled:object-x tiled-obj))
- (obj-y (cl-tiled:object-y tiled-obj))
- (obj-width (cl-tiled:rect-width tiled-obj))
- (obj-height (cl-tiled:rect-height tiled-obj)))
- (append
- (loop for key being the hash-keys in properties
- for val being the hash-values in properties
- collect (intern (string-upcase key) "KEYWORD")
- collect val)
- (list
- :coords (tiled-coords->world-coords obj-x obj-y tiled-map)
- :width obj-width
- :height obj-height
- :bottom-coords (tiled-coords->world-coords (+ obj-x obj-width) (+ obj-y obj-height)
- tiled-map))))))
- (defun object-layer-entities (layer &optional (entity-chunks '()))
- "Convert all point objects in an object layer into entity plists."
- (let ((entities (mapcar (lambda (object) (tiled-object->entity object (cl-tiled:layer-map layer)))
- (layer-objects layer))))
- (collect-items-into-groups
- entities
- (lambda (entity)
- (when entity
- (world-coords-chunk (getf (cdr entity) :coords))))
- :groups entity-chunks)))
- (defun object-layer-triggers (layer &optional (trigger-chunks '()))
- "Convert all rectangle objects in an object layer into trigger plists."
- (let ((triggers (mapcar (lambda (object) (tiled-object->trigger object (cl-tiled:layer-map layer)))
- (layer-objects layer))))
- (collect-items-into-groups
- triggers
- (lambda (trigger)
- (when trigger
- (world-coords-chunk (getf trigger :coords))))
- :groups trigger-chunks)))
- ;;; โโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโ
- ;;; Tile-layer parsing (graphics)
- ;;; โโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโ
- (defun tiled-cell->cell (tiled-cell &key (language nil))
- "Convert a Tiled cell into a cell plist."
- (list :x (cl-tiled:cell-column tiled-cell)
- :y (cl-tiled:cell-row tiled-cell)
- :@ (tile-character (cl-tiled:cell-tile tiled-cell))
- :lang language))
- (defun tiled-layer-cells (layer)
- "Given a Tiled layer, return all of its cells in our custom cell plist-format."
- (let ((layer-lang
- (โฆ:langcode->keysym
- (gethash "language" (cl-tiled:properties layer)))))
- (mapcar (lambda (tiled-cell)
- (tiled-cell->cell tiled-cell :language layer-lang))
- (cl-tiled:layer-cells layer))))
- (defun tile-layer-chunks (layer &optional (chunks '()))
- "Given a Tiled tile-layer (that is, graphics of the map), parse it into an
- alist of Tiled cell โchunksโ."
- (collect-items-into-groups
- (tiled-layer-cells layer)
- (lambda (cell)
- (world-coords-chunk (list :x (getf cell :x) :y (getf cell :y))))
- :groups chunks))
- (defun layer-objects (layer)
- "Return all Tiled objects in the given object layer."
- (slot-value layer 'cl-tiled.data-types::objects))
- (defun tile-character (tile)
- "Given a tileset's tile, return it's corresponding text character,
- assuming that the tileset is a bitmap font starting with char-code 32
- with 15 characters-per-line."
- (code-char
- (+ (* (cl-tiled:tile-row tile) 15)
- (cl-tiled:tile-column tile)
- 32)))
- ;;; โโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโ
- ;;; Tiled maps โ Map lists
- ;;; โโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโโ
- (defun load-map (map-file)
- "Parse a map-file into an plist of its data. This consists of:
- :BUMP-MAP, an alist of tiles (keyed by chunk) in a โcollidableโ layer
- :TILES, an alist of visible tiles (keyed by chunk).
- :ENTITIES, a list of entity plists."
- (let ((tile-chunks '())
- (top-tiles '())
- (bump-map '())
- (entities '())
- (triggers '())
- (hash (make-hash-table)))
- (mapcar (lambda (layer)
- (typecase layer
- (cl-tiled.data-types:tile-layer
- ;; Add to the bump-map if the layer is colliding
- (when (gethash "colliding" (cl-tiled:properties layer))
- (setf bump-map (tile-layer-chunks layer bump-map)))
- (if (gethash "top-layer" (cl-tiled:properties layer))
- (setf top-tiles (tile-layer-chunks layer top-tiles))
- (setf tile-chunks (tile-layer-chunks layer tile-chunks))))
- (cl-tiled.data-types:object-layer
- (setf triggers (object-layer-triggers layer triggers))
- (setf entities (object-layer-entities layer entities)))))
- (cl-tiled:map-layers (cl-tiled:load-map map-file)))
- (setf (gethash :tiles hash) tile-chunks)
- (setf (gethash :top-tiles hash) top-tiles)
- (setf (gethash :bump-map hash) bump-map)
- (setf (gethash :entities hash) entities)
- (setf (gethash :triggers hash) triggers)
- hash))
|