path: root/bitmap.lsp

;;; Bitmap
;;; This could be extended to a general drawing interface, but for now it's probably better to use Tk's canvas.

(import "compat")

(defconstant +black+ 0)
(defconstant +white+ #xFFFFFF)
(defconstant +red+ #xFF0000)
(defconstant +green+ #x00FF00)
(defconstant +blue+ #x0000FF)

(defun make-rgb-pixel (r g b)
   (logior (ash (assure <integer> r) 16) (ash (assure <integer> g) 8) (assure <integer> b)))

(defun rgb-pixel-red (rgb)
   (logand (ash (assure <integer> rgb) -16) #xFF))

(defun rgb-pixel-green (rgb)
   (logand (ash (assure <integer> rgb) -8) #xFF))

(defun rgb-pixel-blue (rgb)
   (logand (assure <integer> rgb) #xFF))

(defun make-rgb-pixel-buffer (width height &rest args)
   (let ((initial-element (if (null args)
                              +black+
                              (car args))))
        (create-array (list (assure <integer> width) (assure <integer> height))
                      (assure <integer> initial-element))))

(defun rgb-pixel-buffer-width (buffer)
   (elt (array-dimensions buffer) 0))

(defun rgb-pixel-buffer-height (buffer)
   (elt (array-dimensions buffer) 1))

(defmacro rgb-pixel (buffer x y)
   `(aref (assure <general-array*> ,buffer) (assure <integer> ,x) (assure <integer> ,y)))

(defun fill-rgb-pixel-buffer (buffer pixel)
   (assure <general-array*> buffer)
   (let* ((dimensions (array-dimensions buffer))
          (width (elt dimensions 0))
          (height (elt dimensions 1)))
         (for ((y 0 (+ y 1)))
              ((>= y height) buffer)
              (for ((x 0 (+ x 1)))
                   ((>= x width) nil)
                   (setf (rgb-pixel buffer x y) (assure <integer> pixel))))))


;;; Write a PPM file

(defun write-rgb-buffer-to-ppm-file (filename buffer)
   (with-open-output-file (outstream filename 8)
        (let* ((dimensions (array-dimensions buffer))
               (width (elt dimensions 0))
               (height (elt dimensions 1))
               (header (create-string-output-stream)))
              (format header "P6~A~D ~D~A255~A"
                      #\newline
                      width height #\newline
                      #\newline)
              (let ((s (get-output-stream-string header)))
                   (for ((i 0 (+ i 1)))
                        ((>= i (length s)) nil)
                        (write-byte (convert (elt s i) <integer>) outstream)))
              
              (for ((x 0 (+ x 1)))
                   ((>= x width) filename)
                   (for ((y 0 (+ y 1)))
                        ((>= y height) nil)
                        (let* ((pixel (rgb-pixel buffer x y))
                               (red (rgb-pixel-red pixel))
                               (green (rgb-pixel-green pixel))
                               (blue (rgb-pixel-blue pixel)))
                              (write-byte red outstream)
                              (write-byte green outstream)
                              (write-byte blue outstream)))))))


;;; Read a PPM file

(defconstant +whitespace-chars+ '(#\SPACE \#carriage-return #\TAB #\NEWLINE))

(defun read-header-chars (stream &rest args)
   (let ((delimiter-list (if (null args)
                             +whitespace-chars+
                             (car args))))
        (do ((c (read-char stream nil :eof)
                (read-char stream nil :eof))
             (vals nil (if (or (null c) (char= c  #\#)) vals (cons c vals))))   ;;don't collect comment chars
            ((or (eql c :eof) (member c delimiter-list)) (map 'string #'identity (nreverse vals)))   ;;return strings
            (when (char= c #\#)   ;;skip comments
                  (read-line stream)))))

(defun read-ppm-file-header (file)
   (with-open-file (s file :direction :input)
      (do ((failure-count 0 (1+ failure-count))
           (tokens nil (let ((t1 (read-header-chars s)))
                            (if (> (length t1) 0)
                                (cons t1 tokens)
                                tokens))))
          ((>= (length tokens) 4) (values (nreverse tokens)
                                          (file-position s)))
          (when (>= failure-count 10)
                (error (format nil "File ~a does not seem to be a proper ppm file - maybe too many comment lines" file)))
          (when (= (length tokens) 1)
                (when (not (or (string= (first tokens) "P6") (string= (first tokens) "P3")))
                      (error (format nil "File ~a is not a ppm file - wrong magic-number. Read ~a instead of P6 or P3 " file (first tokens))))))))

(defun read-ppm-image (file)
   (flet ((image-data-reader (stream start-position width height image-build-function read-function)
             (file-position stream start-position)
             (dotimes (row height)
                (dotimes (col width)
                   (funcall image-build-function row col (funcall read-function stream))))))
      (multiple-value-bind (header file-pos) (read-ppm-file-header file)
         (let* ((image-type (first header))
                (width (parse-integer (second header) :junk-allowed t))
                (height (parse-integer (third header) :junk-allowed t))
                (max-value (parse-integer (fourth header) :junk-allowed t))
                (image (make-rgb-pixel-buffer width height)))
               (when (> max-value 255)
                     (error "unsupported depth - convert to 1byte depth with pamdepth"))
               (cond ((string= "P6" image-type)
                      (with-open-file (stream file :direction :input :element-type '(unsigned-byte 8))
                         (image-data-reader stream
                                            file-pos
                                            width
                                            height
                                            #'(lambda (w h val)
                                                 (setf (rgb-pixel image w h) val))
                                            #'(lambda (stream)
                                                 (make-rgb-pixel (read-byte stream)
                                                                 (read-byte stream)
                                                                 (read-byte stream))))
                         image))
                     ((string= "P3" image-type)
                      (with-open-file (stream file :direction :input)
                         (image-data-reader stream
                                            file-pos
                                            width
                                            height
                                            #'(lambda (w h val)
                                                 (setf (rgb-pixel image w h) val))
                                            #'(lambda (stream)
                                                 (make-rgb-pixel (read stream)
                                                                 (read stream)
                                                                 (read stream))))
                         image))
                     (t 'unsupported))
               image))))


;;; Grayscale image

(defun rgb-to-gray-image (rgb-image)
   (flet ((rgb-to-gray (rgb-value)
             (round (+ (* 0.2126 (rgb-pixel-red rgb-value))
                       (* 0.7152 (rgb-pixel-green rgb-value))
                       (* 0.0722 (rgb-pixel-blue rgb-value))))))
      (let ((gray-image (make-array (array-dimensions rgb-image) :element-type '(unsigned-byte 8))))
           (dotimes (i (array-total-size rgb-image))
              (setf (row-major-aref gray-image i) (rgb-to-gray (row-major-aref rgb-image i))))
           gray-image)))