Ben / Nujel

;;; Nujel - Copyright (C) 2020-2021 - Benjamin Vincent Schulenburg
;;; This project uses the MIT license, a copy should be included under /LICENSE
;;;
;;; Contains a simple BMP en-/decoder
;;;
;;; Since Nujel is still quite small we can leave this in the stdlib, would
;;; be put into a separate module though as soon as it becomes necessary.

[defn buffer/view/le/set! [u8v offset bytes val]
      [while [> bytes 0]
             [buffer/set! u8v [inc! offset] [bit-and #xFF val]]
             [dec! bytes]
             [set! val [bit-shift-right val 8]]]
      offset]

[defn calc-row-padding [width pixel-length]
      [def ret [- 4 [bit-and [* width pixel-length] 3]]]
      [if [= ret 4] 0 ret]]

[defn encode [image]
      :export
      [require :image]
      [def image-size [* [tree/ref image :height]
                         3
                         [+ [tree/ref image :width]
                            [calc-row-padding [tree/ref image :width] 3]]]]
      [def header-size [+ 14 40]]
      [def file-size [+ image-size header-size]]

      [def out [buffer/allocate file-size]]
      [def b [buffer/u8* out]]
      [def i -1]
      [buffer/set! b [inc! i] #\B]
      [buffer/set! b [inc! i] #\M]
      [set! i [buffer/view/le/set! b i 4 file-size]]
      [set! i [buffer/view/le/set! b i 4 0]]
      [set! i [buffer/view/le/set! b i 4 header-size]]
      [set! i [buffer/view/le/set! b i 4 40]] ; BITMAPINFOHEADER
      [set! i [buffer/view/le/set! b i 4 [tree/ref image :width]]]
      [set! i [buffer/view/le/set! b i 4 [tree/ref image :height]]]
      [set! i [buffer/view/le/set! b i 2 1]] ; Planes
      [set! i [buffer/view/le/set! b i 2 24]] ; BPP
      [set! i [buffer/view/le/set! b i 4 0]] ; Compression method
      [set! i [buffer/view/le/set! b i 4 image-size]]
      [set! i [buffer/view/le/set! b i 4 8192]] ; h. resolution
      [set! i [buffer/view/le/set! b i 4 8192]] ; v. resolution
      [set! i [buffer/view/le/set! b i 4 0]] ; Palette size, 0 for [^ 2 n]
      [set! i [buffer/view/le/set! b i 4 0]] ; Important colors, 0 for all

      [def row-padding [calc-row-padding [tree/ref image :width] 3]]
      [def pixels [- header-size 1]] ; Pixel data comes immediatly after the header
      [let [[y [- [tree/ref image :height] 1]]]
           [while [>= y 0]
             [dotimes [x [tree/ref image :width]]
               [set! pixels [buffer/view/le/set! b pixels 3 [image/ref image x y]]]]
             [set! pixels [+ pixels row-padding]]
             [set! y [add/int y -1]]]]
      [return out]]

[defn init! []
      :export
      [require :image]
      [image/add-encoder! "bmp" image/bmp/encode]]

[deftest 3149043687
  [import hash :crypto/adler32]
  [import [test-image-xor] :image]
  [hash [image/bmp/encode [test-image-xor]]]]