Add support for ASCII/Binary PPM files
author |
Steve Losh <steve@stevelosh.com> |
date |
Tue, 28 Nov 2017 20:43:25 -0500 |
parents |
de4030a2d5b9
|
children |
85cfdad82fbd
|
branches/tags |
(none) |
files |
src/main.lisp trivial-ppm.asd |
Changes
--- a/src/main.lisp Tue Nov 28 18:48:55 2017 -0500
+++ b/src/main.lisp Tue Nov 28 20:43:25 2017 -0500
@@ -1,1 +1,125 @@
(in-package :trivial-ppm)
+
+;;;; Utils --------------------------------------------------------------------
+(defun skip-comment (stream)
+ (peek-char #\newline stream nil nil)
+ (read-char stream nil nil))
+
+(defun skip-whitespace (stream)
+ (when (eql #\# (peek-char t stream nil nil))
+ (skip-comment stream)))
+
+(defun peek (stream)
+ (peek-char nil stream nil nil))
+
+
+(defun read-number (stream)
+ (skip-whitespace stream)
+ (loop :with i = 0
+ :for ch = (peek stream)
+ :while ch
+ :for digit = (digit-char-p ch)
+ :while digit
+ :do (read-char stream)
+ :do (setf i (+ (* i 10) digit))
+ :finally (return i)))
+
+(defun read-magic-byte (stream)
+ (assert (eql (read-char stream) #\P))
+ (read-char stream))
+
+(defun read-header (stream)
+ (values (read-number stream)
+ (read-number stream)
+ (read-number stream)))
+
+
+(defun file-format (magic-byte)
+ (ecase magic-byte
+ (#\1 :pbm-ascii)
+ (#\2 :pgm-ascii)
+ (#\3 :ppm-ascii)
+ (#\4 :pbm-binary)
+ (#\5 :pgm-binary)
+ (#\6 :ppm-binary)))
+
+(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)))
+
+
+;;;; 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 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)))
+ (destructuring-bind (height width) (array-dimensions data)
+ (format stream "P~D~%~D ~D~%~D~%"
+ (magic-byte file-format) 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))
+
+
+;;;; 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)))))
+
+(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))))
--- a/trivial-ppm.asd Tue Nov 28 18:48:55 2017 -0500
+++ b/trivial-ppm.asd Tue Nov 28 20:43:25 2017 -0500
@@ -6,7 +6,7 @@
:license "MIT/X11"
- :depends-on ()
+ :depends-on (:flexi-streams)
:serial t
:components ((:module "vendor" :serial t