From bd88ae0b1da3e48032a251ce779f347329a52ed7 Mon Sep 17 00:00:00 2001 From: Darren Bane Date: Sun, 7 Jun 2020 18:57:01 +0100 Subject: Add Bitmap task from Rosetta Code --- bitmap.lsp | 160 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 160 insertions(+) create mode 100644 bitmap.lsp (limited to 'bitmap.lsp') 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 r) 16) (ash (assure g) 8) (assure b))) + +(defun rgb-pixel-red (rgb) + (logand (ash (assure rgb) -16) #xFF)) + +(defun rgb-pixel-green (rgb) + (logand (ash (assure rgb) -8) #xFF)) + +(defun rgb-pixel-blue (rgb) + (logand (assure rgb) #xFF)) + +(defun make-rgb-pixel-buffer (width height &rest args) + (let ((initial-element (if (null args) + +black+ + (car args)))) + (create-array (list (assure width) (assure height)) + (assure 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 ,buffer) (assure ,x) (assure ,y))) + +(defun fill-rgb-pixel-buffer (buffer pixel) + (assure 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 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) ) 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))) -- cgit 1.4.1-2-gfad0