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)
             (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 (* (ref image :height)
                         3
                         (+ (ref image :width)
                            (calc-row-padding (ref image :width) 3))))
      (def header-size (+ 14 40))
      (def file-size (+ image-size header-size))

      (def out (buffer/allocate file-size))
      (def b (:u8 out))
      (def i -1)
      (set! b (inc! i) #\B)
      (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 (ref image :width)))
      (set! i (buffer/view/le/set! b i 4 (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 (ref image :width) 3))
      (def pixels (- header-size 1)) ; Pixel data comes immediately after the header
      (let ((y (- (ref image :height) 1)))
           (while (>= y 0)
             (dotimes (x (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))))