;; -*- mode: common-lisp; package: user -*-

;; This file implements writing of Device Independent Bitmap (dib, bmp)
;; file format that is a native format on Windows.

(in-package :user)

(defmacro lobyte (byte) `(logand #xff ,byte))
(defmacro hibyte (byte) `(logand #xff (ash ,byte -8)))
(defmacro loword (word) `(logand #xffff ,word))
(defmacro hiword (word) `(logand #xffff (ash ,word -16)))

(defun write-word (stream word)
  (write-byte (lobyte word) stream)
  (write-byte (hibyte word) stream))

(defun write-long (stream long)
   (write-word stream (loword long))
   (write-word stream (hiword long)))

(defun read-word (stream)
  (logior (read-byte stream)
	  (ash (read-byte stream) 8)))

(defun read-long (stream)
  (logior (read-word stream)
	  (ash (read-word stream) 16)))

(defmacro with-dib-writing ((stream writer padder
			     &key width height bits-per-pixel (colors #()))
			    &body body)
  (let ((gstream (gensym)))
    `(let ((,gstream ,stream))
       (multiple-value-bind (,writer ,padder)
	   (write-dib-header ,gstream ,width ,height ,bits-per-pixel ,colors)
	 ,@body))))

(defun write-dib-header (stream width height bits-per-pixel &optional (colors #()))
  (let* ((row-pad (if* (eq bits-per-pixel 24)
                     then (mod (- 4 (mod (* 3 width) 4)) 4)
                     else 0))
         (num-colors (length colors))
         (image-offset
          (+ 54 (* 4 num-colors))))	; 14 for file-header
					; 40 for bitmap-info-header
    (write-byte (char-int #\B) stream)
    (write-byte (char-int #\M) stream)
    (write-long stream
                   (+ image-offset
                      (* row-pad height)
                      (floor (* width height bits-per-pixel) ; pixels
                             8)))	; file size
    (write-long stream 0)		; reserved1 and 2
    (write-long stream image-offset)
    ;; end of file-header; start of bitmap-info-header
    (write-long stream 40)		; info-header-size [use the maximum]
    (write-long stream width)
    (write-long stream height)
    (write-word stream 1)		; bit-planes
    (write-word stream bits-per-pixel)
    (write-long stream 0)		; compression = no
    (write-long stream 0)		; size of all bits (needed if compression)
    (write-long stream 0)		; x-pixels-per-meter
    (write-long stream 0)		; y-pixels-per-meter
    (write-long stream num-colors)	; number of colors used
    (write-long stream num-colors)	; number of "important" colors
    (loop for color across colors
	do (write-byte (rgbi-blue color) stream)
	   (write-byte (rgbi-green color) stream)
	   (write-byte (rgbi-red color) stream)
	   (write-byte 0 stream))	; reserved (pad color to longword)
    (make-pixel-writers bits-per-pixel)))

;; This generic function is called with an number of bits-per-pixel and it
;; returns two functions.  The first is a function that writes a pixel value
;; to a stream.  It should be called with successive pixels for each row.
;; The second function should to be called to close out a row, doing any
;; necessary flushing and padding.

(defgeneric make-pixel-writers (bits-per-pixel))

(defmethod make-pixel-writers ((bits-per-pixel (eql 1)))
  (let ((bit 1)
	(byte 0))
    (values (lambda (stream pixel)
	      (when (eql pixel 1) (incf byte bit))
	      (when (eql (setf bit (ash bit 1)) #x100)
		(write-byte byte stream)
		(setf bit 1 byte 0)))
	    (lambda (stream)
	      ;; Pad the final byte if necessary.
	      (unless (eql bit 1)
		(write-byte byte stream))))))

(defmethod make-pixel-writers ((bits-per-pixel (eql 4)))
  (let ((hilo nil)
	(save 0))
    (values (lambda (stream pixel)
	      (if (null hilo)
		  (setq save (logand #x0f pixel)
			hilo t)
		(progn
		  (write-byte (logior save (ash (logand pixel #x0f) 4)) stream)
		  (setf hilo nil))))
	    (lambda (stream)
	      ;; Pad the final byte if necessary.
	      (when hilo
		(write-byte save stream))))))

(defmethod make-pixel-writers ((bits-per-pixel (eql 8)))
  (values (lambda (stream pixel)
	    (write-byte pixel stream))
	  (lambda (stream)
	    (declare (ignore stream))
	    nil)))

(defmethod make-pixel-writers ((bits-per-pixel (eql 16)))
  (values (lambda (stream pixel)
	    (write-byte (lobyte pixel) stream)
	    (write-byte (hibyte pixel) stream))
	  (lambda (stream)
	    (declare (ignore stream))
	    nil)))

(defmethod make-pixel-writers ((bits-per-pixel (eql 24)))
  (let ((width 0))
    (values (lambda (stream pixel)
	      (incf width)		; Count pixels in row.
	      (write-byte (rgbi-blue  pixel) stream)
	      (write-byte (rgbi-green pixel) stream)
	      (write-byte (rgbi-red   pixel) stream)
	      pixel)
	    (lambda (stream)
	      (dotimes (n (mod (- 4 (mod (* 3 width) 4)) 4))
		(write-byte 0 stream))
	      (setf width 0)))))

(defmethod make-pixel-writers ((bits-per-pixel (eql 32)))
  (values (lambda (stream pixel)
	    (write-byte (rgbi-blue  pixel) stream)
	    (write-byte (rgbi-green pixel) stream)
	    (write-byte (rgbi-red   pixel) stream)
	    (write-byte (rgbi-inten pixel) stream)
	    pixel)
	  (lambda (stream)
	    (declare (ignore stream))
	    nil)))