honeylisp/editor/tiledraw.fnl

137 lines
4.5 KiB
Fennel

(fn pal-from-bit [bit]
(if bit
(values [20 207 253] [255 106 60])
(values [255 68 253] [20 245 60])))
(fn pal-from-byte [byte]
(pal-from-bit (not= 0 (bit.band byte 0x80))))
(fn putpixel [x y color]
(when color
(love.graphics.setColor (/ (. color 1) 255) (/ (. color 2) 255) (/ (. color 3) 255))
(love.graphics.points (+ x 0.5) (+ y 0.5))))
(fn make-canvas [w h f]
(local canvas (love.graphics.newCanvas w h))
(local prevcanvas (love.graphics.getCanvas))
(canvas:setFilter :nearest :nearest)
(local scissor [(love.graphics.getScissor)])
(love.graphics.setScissor)
(love.graphics.setCanvas canvas)
(love.graphics.clear 0 0 0)
(f canvas)
(love.graphics.setCanvas prevcanvas)
(love.graphics.setScissor (table.unpack scissor))
(love.graphics.setColor 1 1 1 1)
canvas)
(fn draw-byte [bytes ibyte xoffset y ?state ?prevpal]
(local byte (string.byte (bytes:sub ibyte ibyte)))
(var prevstate nil)
(var state (or ?state :off))
(var pal [(pal-from-byte byte)])
(var prevpal (or ?prevpal pal))
(for [bitx 0 6]
(local x (+ bitx xoffset))
(local bit (not= 0 (bit.band byte (bit.lshift 1 bitx))))
(local prevart (. prevpal (+ 1 (% x 2))))
(local art (. pal (+ 1 (% x 2))))
(set prevstate state)
(set prevpal pal)
(set state
(match [prevstate bit]
[:off false] :off
[:off true] :rising
[:rising false] :falling
[:rising true] :on
[:falling false] :off
[:falling true] :rising
[:on true] :on
[:on false] :falling))
(local white [255 255 255])
(local (prevcolor color)
(match [prevstate state]
[_ :on] (values white white)
[:off :rising] (values nil art)
[:falling :rising] (values prevart art)))
(putpixel (- x 1) y prevcolor)
(putpixel x y color))
(values state pal))
(fn tilestrip-to-sprite [tiles]
(make-canvas (* 14 (length tiles)) 16 (fn [canvas]
(for [y 0 15]
(var state nil)
(var prevpal nil)
(each [itile tile (ipairs tiles)]
(local x (* (- itile 1) 14))
(set (state prevpal) (draw-byte tile (+ y 1) x y state prevpal))
(set (state prevpal) (draw-byte tile (+ y 17) (+ x 7) y state prevpal)))))))
(fn tile-to-sprite [tile] (if tile (tilestrip-to-sprite [tile]) (make-canvas 14 16 #nil)))
(fn screen-y-to-offset [y]
(var offset (* (% y 8) 0x400))
(local ybox (math.floor (/ y 8)))
(local ysection (match (math.floor (/ ybox 8))
0 0x0000
1 0x0028
2 0x0050))
(+ offset ysection (* (% ybox 8) 0x80)))
(fn draw-scanline [screen y ydest]
(local ibyte (+ 1 (screen-y-to-offset y)))
(var state nil) (var prevpal nil)
(for [x 0 39]
(set (state prevpal) (draw-byte screen (+ ibyte x) (* x 7) ydest state prevpal))))
(fn scanline-to-sprite [screen y]
(make-canvas 280 1 (fn [canvas] (draw-scanline screen y 0))))
(fn screen-to-sprite [screen]
(make-canvas 280 192 (fn [canvas]
(for [y 0 191] (draw-scanline screen y y)))))
(fn portrait-to-sprite [gfx]
(local top (tilestrip-to-sprite [(gfx:sub 1 32) (gfx:sub 65 96)]))
(local bottom (tilestrip-to-sprite [(gfx:sub 33 64) (gfx:sub 97 128)]))
(make-canvas 28 32 (fn [canvas]
(love.graphics.draw top 0 0)
(love.graphics.draw bottom 0 16))))
(fn char-to-sprite [gfx]
(make-canvas 7 8 (fn [canvas]
(when gfx
(for [y 0 7]
(draw-byte gfx (+ y 1) 0 y))))))
(fn TileCache [tiles ?spritegen]
{: tiles
:spritegen (or ?spritegen tile-to-sprite)
:tilesprites []
:tile (fn [self itile] (or (. self.tiles itile) {:flags {}}))
:cachekey (fn [itile ?key] (.. (or ?key :gfx) itile))
:update-tile
(fn [self itile tile ?key]
(tset self.tiles itile
(-> (self:tile itile)
(doto (tset (or ?key :gfx) tile))))
(tset self.tilesprites (self.cachekey itile ?key) nil))
:set-flag
(fn [self itile flag clear]
(tset (. self.tiles itile :flags) flag (if clear nil true)))
:load
(fn [self tiles]
(set self.tiles tiles)
(set self.tilesprites []))
:sprite
(fn [self itile ?key]
(local key (self.cachekey itile ?key))
(when (and (= nil (. self.tilesprites key)) (not= nil (. self.tiles itile)))
(tset self.tilesprites key (self.spritegen (. self.tiles itile (or ?key :gfx)))))
(. self.tilesprites key))})
{: tile-to-sprite : tilestrip-to-sprite : portrait-to-sprite : char-to-sprite : scanline-to-sprite
: screen-y-to-offset : pal-from-bit : pal-from-byte : TileCache : make-canvas : draw-byte}