Add Bitmap task from Rosetta Code

1 files changed, 160 insertions, 0 deletions

diff --git a/bitmap.lsp b/bitmap.lsp
new file mode 100644
index 0000000..059c5cb
--- /dev/null
+++ b/bitmap.lsp
@@ -0,0 +1,160 @@
+;;; Bitmap
+
+(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 +whitespaces-chars+ '(#\SPACE #\RETURN #\TAB #\NEWLINE #\LINEFEED))
+
+(defun read-header-chars (stream &optional (delimiter-list +whitespaces-chars+))
+   (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)))