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 image/bmp/row-padding [width pixel-length]
      [def ret [- 4 [bit-and [* width pixel-length] 3]]]
      [if [= ret 4] 0 ret]]

[export encode [defn image/bmp/encode [image]
                     [require :image]
                     [def image-size [* [tree/ref image :height]
                                        3
                                        [+ [tree/ref image :width]
                                           [image/bmp/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 [image/bmp/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]]]

[export init! [defn image/bmp/init! []
                    [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]]]]