overworld.tiled.lisp 8.5 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207
  1. ;;;; Copyright © 2023, Jaidyn Ann <jadedctrl@posteo.at>
  2. ;;;;
  3. ;;;; This program is free software: you can redistribute it and/or
  4. ;;;; modify it under the terms of the GNU General Public License as
  5. ;;;; published by the Free Software Foundation, either version 3 of
  6. ;;;; the License, or (at your option) any later version.
  7. ;;;;
  8. ;;;; This program is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. ;;;; GNU General Public License for more details.
  12. ;;;;
  13. ;;;; You should have received a copy of the GNU General Public License
  14. ;;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
  15. ;;;; FLORA-SEARCH-AURORA.OVERWORLD.TILED
  16. ;;;; Import a Tiled-format (TMX) map into the hash-table/plist/alist format
  17. ;;;; used by the overworld.
  18. (defpackage :flora-search-aurora.overworld.tiled
  19. (:nicknames :fsa.o.t :overworld.tiled :🌍.🀨)
  20. (:use :cl
  21. :flora-search-aurora.overworld.util)
  22. (:export #:load-map))
  23. (in-package :flora-search-aurora.overworld.tiled)
  24. ;;; ———————————————————————————————————
  25. ;;; Misc. utility
  26. ;;; ———————————————————————————————————
  27. (defun collect-items-into-groups (list key-function &key (groups '()))
  28. "Given a LIST of items and a KEY-FUNCTION categorizing an individual item
  29. (returning a “category” symbol for any given item), return an sorted
  30. associative list built upon GROUPS.
  31. If NIL is returned from KEY-FUNCTION, the given item is thrown out."
  32. (loop for item in list
  33. do (let ((key (apply key-function (list item))))
  34. (when key
  35. (setf (assoc-utils:aget groups key)
  36. (append (assoc-utils:aget groups key)
  37. (list item))))))
  38. groups)
  39. (defun tiled-coords->world-coords (x y tiled-map)
  40. "Given X & Y coordinates with a parsed Tiled map, return the appropriate
  41. character-scale world coordinates in plist form."
  42. (list :x (floor (/ x (cl-tiled:map-tile-width tiled-map)))
  43. :y (floor (/ y (cl-tiled:map-tile-height tiled-map)))))
  44. ;;; ———————————————————————————————————
  45. ;;; Object-layer (Persons/Triggers)
  46. ;;; ———————————————————————————————————
  47. (defun tiled-rectangle-p (tiled-obj)
  48. "Whether or not a Tiled object is a valid rectangle."
  49. (and (> (cl-tiled:rect-width tiled-obj) 0)
  50. (> (cl-tiled:rect-height tiled-obj) 0)))
  51. (defun tiled-object->entity (tiled-obj tiled-map)
  52. "Convert a Tiled object into an entity plist."
  53. (when (not (tiled-rectangle-p tiled-obj))
  54. (let ((properties (cl-tiled:properties tiled-obj)))
  55. (append
  56. (list (…:string->symbol (gethash "id" properties)))
  57. (loop for key being the hash-keys in properties
  58. for val being the hash-values in properties
  59. collect (intern (string-upcase key) "KEYWORD")
  60. collect val)
  61. (list
  62. :face (gethash "normal-face" properties)
  63. :coords (tiled-coords->world-coords (cl-tiled:object-x tiled-obj)
  64. (cl-tiled:object-y tiled-obj)
  65. tiled-map))))))
  66. (defun tiled-object->trigger (tiled-obj tiled-map)
  67. "Convert a Tiled object into a “trigger” plist. That is, a rectangle with
  68. a :FUNCTION to be triggered when it’s stepped upon."
  69. (when (tiled-rectangle-p tiled-obj)
  70. (let ((properties (cl-tiled:properties tiled-obj))
  71. (obj-x (cl-tiled:object-x tiled-obj))
  72. (obj-y (cl-tiled:object-y tiled-obj))
  73. (obj-width (cl-tiled:rect-width tiled-obj))
  74. (obj-height (cl-tiled:rect-height tiled-obj)))
  75. (append
  76. (loop for key being the hash-keys in properties
  77. for val being the hash-values in properties
  78. collect (intern (string-upcase key) "KEYWORD")
  79. collect val)
  80. (list
  81. :coords (tiled-coords->world-coords obj-x obj-y tiled-map)
  82. :width obj-width
  83. :height obj-height
  84. :bottom-coords (tiled-coords->world-coords (+ obj-x obj-width) (+ obj-y obj-height)
  85. tiled-map))))))
  86. (defun object-layer-entities (layer &optional (entity-chunks '()))
  87. "Convert all point objects in an object layer into entity plists."
  88. (let ((entities (mapcar (lambda (object) (tiled-object->entity object (cl-tiled:layer-map layer)))
  89. (layer-objects layer))))
  90. (collect-items-into-groups
  91. entities
  92. (lambda (entity)
  93. (when entity
  94. (world-coords-chunk (getf (cdr entity) :coords))))
  95. :groups entity-chunks)))
  96. (defun object-layer-triggers (layer &optional (trigger-chunks '()))
  97. "Convert all rectangle objects in an object layer into trigger plists."
  98. (let ((triggers (mapcar (lambda (object) (tiled-object->trigger object (cl-tiled:layer-map layer)))
  99. (layer-objects layer))))
  100. (collect-items-into-groups
  101. triggers
  102. (lambda (trigger)
  103. (when trigger
  104. (world-coords-chunk (getf trigger :coords))))
  105. :groups trigger-chunks)))
  106. ;;; ———————————————————————————————————
  107. ;;; Tile-layer parsing (graphics)
  108. ;;; ———————————————————————————————————
  109. (defun tiled-cell->cell (tiled-cell &key (language nil))
  110. "Convert a Tiled cell into a cell plist."
  111. (list :x (cl-tiled:cell-column tiled-cell)
  112. :y (cl-tiled:cell-row tiled-cell)
  113. :@ (tile-character (cl-tiled:cell-tile tiled-cell))
  114. :lang language))
  115. (defun tiled-layer-cells (layer)
  116. "Given a Tiled layer, return all of its cells in our custom cell plist-format."
  117. (let ((layer-lang
  118. (…:langcode->keysym
  119. (gethash "language" (cl-tiled:properties layer)))))
  120. (mapcar (lambda (tiled-cell)
  121. (tiled-cell->cell tiled-cell :language layer-lang))
  122. (cl-tiled:layer-cells layer))))
  123. (defun tile-layer-chunks (layer &optional (chunks '()))
  124. "Given a Tiled tile-layer (that is, graphics of the map), parse it into an
  125. alist of Tiled cell “chunks”."
  126. (collect-items-into-groups
  127. (tiled-layer-cells layer)
  128. (lambda (cell)
  129. (world-coords-chunk (list :x (getf cell :x) :y (getf cell :y))))
  130. :groups chunks))
  131. (defun layer-objects (layer)
  132. "Return all Tiled objects in the given object layer."
  133. (slot-value layer 'cl-tiled.data-types::objects))
  134. (defun tile-character (tile)
  135. "Given a tileset's tile, return it's corresponding text character,
  136. assuming that the tileset is a bitmap font starting with char-code 32
  137. with 15 characters-per-line."
  138. (code-char
  139. (+ (* (cl-tiled:tile-row tile) 15)
  140. (cl-tiled:tile-column tile)
  141. 32)))
  142. ;;; ———————————————————————————————————
  143. ;;; Tiled maps → Map lists
  144. ;;; ———————————————————————————————————
  145. (defun load-map (map-file)
  146. "Parse a map-file into an plist of its data. This consists of:
  147. :BUMP-MAP, an alist of tiles (keyed by chunk) in a “collidable” layer
  148. :TILES, an alist of visible tiles (keyed by chunk).
  149. :ENTITIES, a list of entity plists."
  150. (let ((tile-chunks '())
  151. (top-tiles '())
  152. (bump-map '())
  153. (entities '())
  154. (triggers '())
  155. (hash (make-hash-table)))
  156. (mapcar (lambda (layer)
  157. (typecase layer
  158. (cl-tiled.data-types:tile-layer
  159. ;; Add to the bump-map if the layer is colliding
  160. (when (gethash "colliding" (cl-tiled:properties layer))
  161. (setf bump-map (tile-layer-chunks layer bump-map)))
  162. (if (gethash "top-layer" (cl-tiled:properties layer))
  163. (setf top-tiles (tile-layer-chunks layer top-tiles))
  164. (setf tile-chunks (tile-layer-chunks layer tile-chunks))))
  165. (cl-tiled.data-types:object-layer
  166. (setf triggers (object-layer-triggers layer triggers))
  167. (setf entities (object-layer-entities layer entities)))))
  168. (cl-tiled:map-layers (cl-tiled:load-map map-file)))
  169. (setf (gethash :tiles hash) tile-chunks)
  170. (setf (gethash :top-tiles hash) top-tiles)
  171. (setf (gethash :bump-map hash) bump-map)
  172. (setf (gethash :entities hash) entities)
  173. (setf (gethash :triggers hash) triggers)
  174. hash))