honeylisp/game/tiles.fnl

(local util (require :lib.util))
(local lume (require :lib.lume))

(local flags [:walkable])
(local flag-to-bit {})
(each [iflag flag (ipairs flags)]
  (tset flag-to-bit flag (bit.lshift 1 (- iflag 1))))

(local encoded-tile-fields [:gfx :mask])
(fn convert [tile field method]
  (local oldval (. tile field))
  (when oldval
    (tset tile field (: oldval method)))
  tile)
(fn convert-all [tile method]
  (each [_ field (ipairs encoded-tile-fields)]
    (convert tile field method))
  tile)

(fn deserialize [tile]
  (match (type tile)
    :string {:gfx (tile:fromhex) :flags {}}
    :table  (convert-all tile :fromhex)))

(fn serialize [tile] (convert-all (lume.clone tile) :tohex))

(local fn-tiles "game/tiles.json")
(local fn-portraits "game/portraits.json")
(local fn-font "game/font.json")

(fn loadgfx [filename]
  (if (util.file-exists filename)
     (lume.map (util.readjson filename) deserialize)
     []))

(fn savegfx [filename gfx] (util.writejson filename (lume.map gfx serialize)))

(fn appendgfx [org gfx ?key ?ignore-labels]
  (each [_ g (ipairs gfx)]
    (when (and g.label (not ?ignore-labels)) (org:append g.label))
    (org:append [:bytes (. g (or ?key :gfx))])))

(fn appendtiles [org]
  (local tiles (loadgfx fn-tiles))
  (org:append [:align 0x100] :tileset)
  (appendgfx org tiles)
  (appendgfx org (loadgfx fn-portraits))
  (org:append :tileflags)
  (each [_ tile (ipairs tiles)]
    (var flags 0)
    (each [flag _ (pairs tile.flags)]
      (set flags (bit.bor flags (. flag-to-bit flag))))
    (org:append [:db flags])))

(fn append-portraitwords [vm ?overrides]
  (local overrides (or ?overrides {}))
  (each [_ p (ipairs (loadgfx fn-portraits))]
    (let [wordname (.. :draw- p.label)
          override (. overrides p.label)]
      (vm:word (.. :draw- p.label) :show-footer
        (if override (override p.label) [:vm :lit p.label])
        :draw-portrait))))

(fn encode-yx [xy]
  (if xy (bit.bor (bit.lshift (- xy.y 1) 8) (- xy.x 1)) 0xffff))

(fn encode-itile [itile]
  (bit.bor
    (bit.lshift (bit.band (- itile 1) 0x07) 5)
    (bit.rshift (bit.band (- itile 1) 0xf8) 3)))

(fn decode-itile [enctile]
  (+ 1 (bit.bor
    (bit.lshift (bit.band enctile 0x1f) 3)
    (bit.rshift (bit.band enctile 0xe0) 5))))

(fn find-itile [tiles label ?itilenext]
  (local itile (or ?itilenext 1))
  (local tile (. tiles itile))
  (assert (not= tile nil) (.. "No such tile " label))
  (if (= tile.label label) (encode-itile itile)
    (find-itile tiles label (+ itile 1))))

{: loadgfx : savegfx : appendtiles : appendgfx : append-portraitwords : flags : flag-to-bit : find-itile
 : fn-tiles : fn-portraits : fn-font : encode-yx : encode-itile : decode-itile}