honeylisp/editor/tiledraw/ii.fnl

(local {: putpixel : make-canvas} (require :editor.tiledraw))

(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 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 b (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 b]
        [: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))))))

{: tile-to-sprite : char-to-sprite : portrait-to-sprite : screen-to-sprite : scanline-to-sprite : screen-y-to-offset
 : tilestrip-to-sprite : pal-from-bit : pal-from-byte : draw-byte}