# HG changeset patch # User Steve Losh # Date 1516149760 18000 # Node ID 85cfdad82fbd973361e112e1d070fe2c6c892032 # Parent f1ad2033144e065dce8c4ef2b7ebd94a1ae9d3b2 Clean up code, add file API diff -r f1ad2033144e -r 85cfdad82fbd src/main.lisp --- a/src/main.lisp Tue Nov 28 20:43:25 2017 -0500 +++ b/src/main.lisp Tue Jan 16 19:42:40 2018 -0500 @@ -24,102 +24,109 @@ :do (setf i (+ (* i 10) digit)) :finally (return i))) -(defun read-magic-byte (stream) - (assert (eql (read-char stream) #\P)) - (read-char stream)) +(defun write-number (value stream) + (format stream "~D " value)) + -(defun read-header (stream) - (values (read-number stream) - (read-number stream) - (read-number stream))) +(defun read-magic-byte (stream) + (assert (eql (read-byte stream) (char-code #\P))) + (code-char (read-byte stream))) (defun file-format (magic-byte) + "Return `(values format binary?)` for the given magic byte." (ecase magic-byte - (#\1 :pbm-ascii) - (#\2 :pgm-ascii) - (#\3 :ppm-ascii) - (#\4 :pbm-binary) - (#\5 :pgm-binary) - (#\6 :ppm-binary))) + (#\1 (values :pbm nil)) + (#\2 (values :pgm nil)) + (#\3 (values :ppm nil)) + (#\4 (values :pbm t)) + (#\5 (values :pgm t)) + (#\6 (values :ppm t)))) -(defun magic-byte (file-format) - (ecase file-format - (:pbm-ascii #\1) - (:pgm-ascii #\2) - (:ppm-ascii #\3) - (:pbm-binary #\4) - (:pgm-binary #\5) - (:ppm-binary #\6))) +(defun magic-byte (file-format binary?) + (if binary? + (ecase file-format + (:pbm #\4) + (:pgm #\5) + (:ppm #\6)) + (ecase file-format + (:pbm #\1) + (:pgm #\2) + (:ppm #\3)))) + + +(defun pixel-type (format bit-depth) + (ecase format + (:pbm 'bit) + (:pgm `(integer 0 ,bit-depth)) + (:ppm `(simple-array (integer 0 ,bit-depth) (3))))) ;;;; PPM ---------------------------------------------------------------------- -(declaim (inline read-ppm-from-stream)) - -(defun read-ppm-from-stream (reader stream binary?) - (multiple-value-bind (width height bit-depth) - (read-header stream) - (let ((data (make-array (list height width) - :element-type `(simple-array (integer 0 ,bit-depth) (3))))) - (when binary? - (read-char stream)) ; chomp last newline before bytes - (dotimes (y height) - (dotimes (x width) - (setf (aref data y x) - (make-array 3 :initial-contents (list (funcall reader stream) - (funcall reader stream) - (funcall reader stream)) - :element-type 'fixnum)))) - data))) - - -(defun read-ppm-ascii-from-stream (stream) - (read-ppm-from-stream #'read-number stream nil)) - -(defun read-ppm-binary-from-stream (stream) - (read-ppm-from-stream #'read-byte stream t)) +(defun read% (stream format binary?) + (let* ((width (read-number stream)) + (height (read-number stream)) + (bit-depth (if (eql :pbm format) 1 (read-number stream))) + (data (make-array (list height width) + :element-type (pixel-type format bit-depth))) + (reader (if binary? #'read-byte #'read-number))) + (when binary? + (read-char stream)) ; chomp last newline before bytes + (dotimes (row height) + (dotimes (col width) + (setf (aref data row col) + (ecase format + (:pbm (funcall reader stream)) + (:pgm (funcall reader stream)) + (:ppm (make-array 3 + :initial-contents (list (funcall reader stream) + (funcall reader stream) + (funcall reader stream)) + :element-type 'fixnum)))))) + data)) -(defun write-pixel-ascii (stream pixel) - (format stream "~D ~D ~D " - (aref pixel 0) - (aref pixel 1) - (aref pixel 2))) - -(defun write-pixel-binary (stream pixel) - (write-byte (aref pixel 0) stream) - (write-byte (aref pixel 1) stream) - (write-byte (aref pixel 2) stream)) - - -(declaim (inline write-ppm-to-stream)) - -(defun write-ppm-to-stream (file-format data stream maximum-value writer) - (let ((stream (flexi-streams:make-flexi-stream stream :external-format :ascii))) +(defun write% (data stream format binary? maximum-value) + (let ((stream (flexi-streams:make-flexi-stream stream :external-format :ascii)) + (writer (if binary? #'write-byte #'write-number))) (destructuring-bind (height width) (array-dimensions data) (format stream "P~D~%~D ~D~%~D~%" - (magic-byte file-format) width height maximum-value) + (magic-byte format binary?) width height maximum-value) (dotimes (row height) (dotimes (col width) - (funcall writer stream (aref data row col))))))) - -(defun write-ppm-ascii-to-stream (data stream maximum-value) - (write-ppm-to-stream :ppm-ascii data stream maximum-value #'write-pixel-ascii)) - -(defun write-ppm-binary-to-stream (data stream maximum-value) - (write-ppm-to-stream :ppm-binary data stream maximum-value #'write-pixel-binary)) + (let ((pixel (aref data row col))) + (ecase format + (:pbm (funcall writer pixel stream)) + (:pgm (funcall writer pixel stream)) + (:ppm (progn (funcall writer (aref pixel 0) stream) + (funcall writer (aref pixel 1) stream) + (funcall writer (aref pixel 2) stream)))))) + (unless binary? (terpri stream)))))) ;;;; API ---------------------------------------------------------------------- (defun read-from-stream (stream) - (let ((stream (flexi-streams:make-flexi-stream stream :external-format :ascii))) - (ecase (file-format (read-magic-byte stream)) - (:ppm-ascii (read-ppm-ascii-from-stream stream)) - (:ppm-binary (read-ppm-binary-from-stream stream))))) + (multiple-value-bind (format binary?) + (file-format (read-magic-byte stream)) + (read% (flexi-streams:make-flexi-stream stream :external-format :ascii) + format binary?))) (defun write-to-stream (stream data &key - (maximum-value 255) - (format :binary)) - (ccase format - (:ascii (write-ppm-ascii-to-stream data stream maximum-value)) - (:binary (write-ppm-binary-to-stream data stream maximum-value)))) + (format :ppm) + (encoding :binary) + (bit-depth (ecase format (:pbm 1) ((:pgm :ppm) 255)))) + (check-type format (member :ppm :pgm :pbm)) + (check-type encoding (member :binary :ascii)) + (write% data stream format (eql :binary encoding) bit-depth)) + + +(defun read-from-file (path) + (with-open-file (s path :direction :input :element-type '(unsigned-byte 8)) + (read-from-stream s))) + +(defun write-to-file (path data &key + (format :ppm) + (encoding :binary) + (bit-depth (ecase format (:pbm 1) ((:pgm :ppm) 255)))) + (with-open-file (s path :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)) + (write-to-stream s data :format format :encoding encoding :bit-depth bit-depth)))