# HG changeset patch # User Steve Losh # Date 1545696729 18000 # Node ID fb0afda02c8a551436e8a58758ab105f63de5486 # Parent 05f84301a0618f0a7337b587734a40ea4a5c83d6 Add fuzz tests and fix bugs diff -r 05f84301a061 -r fb0afda02c8a .hgignore --- a/.hgignore Sat Feb 10 16:47:39 2018 -0500 +++ b/.hgignore Mon Dec 24 19:12:09 2018 -0500 @@ -4,3 +4,4 @@ *.log docs/build images +test/data/fuzz.* diff -r 05f84301a061 -r fb0afda02c8a docs/03-reference.markdown --- a/docs/03-reference.markdown Sat Feb 10 16:47:39 2018 -0500 +++ b/docs/03-reference.markdown Mon Dec 24 19:12:09 2018 -0500 @@ -0,0 +1,108 @@ +# API Reference + +The following is a list of all user-facing parts of trivial-ppm. + +If there are backwards-incompatible changes to anything listed here, they will +be noted in the changelog and the author will feel bad. + +Anything not listed here is subject to change at any time with no warning, so +don't touch it. + +[TOC] + +## Package `TRIVIAL-PPM` + +### `READ-FROM-FILE` (function) + + (READ-FROM-FILE PATH) + +Read a PPM image file from `path`, returning an array of pixels and more. + + The primary return value will be a 2D array with dimensions `(width height)`. + Each element of the array will be a single pixel whose type depends on the + image file format: + + * PBM: `bit` + * PGM: `(integer 0 maximum-value)` + * PPM: `(simple-array (integer 0 maximum-value) (3))` + + Two other values are returned: + + * The format of the image that was read (one of `:pbm`, `:pgm`, `:ppm`). + * The bit depth of the image. + + + +### `READ-FROM-STREAM` (function) + + (READ-FROM-STREAM STREAM) + +Read a PPM image file from `stream`, returning an array of pixels and more. + + `stream` must be a binary input stream. + + The primary return value will be a 2D array with dimensions `(width height)`. + Each element of the array will be a single pixel whose type depends on the + image file format: + + * PBM: `bit` + * PGM: `(integer 0 maximum-value)` + * PPM: `(simple-array (integer 0 maximum-value) (3))` + + Two other values are returned: + + * The format of the image that was read (one of `:pbm`, `:pgm`, `:ppm`). + * The bit depth of the image. + + + +### `WRITE-TO-FILE` (function) + + (WRITE-TO-FILE PATH DATA &KEY (IF-EXISTS NIL IF-EXISTS-GIVEN) (FORMAT :PPM) (ENCODING :BINARY) + (MAXIMUM-VALUE (ECASE FORMAT (:PBM 1) ((:PGM :PPM) 255)))) + +Write a PPM image array `data` to a file at `path`. + + Nothing is returned. + + `format` must be one of `:pbm`, `:pgm`, `:ppm`. + + `encoding` must be one of `:binary`, `:ascii`. + + `maximum-value` must be the desired bit depth of the image (the maximum value + any particular pixel can have). For PBM images it must be `1`. + + For PBM and PGM images, `data` must be a two dimensional array of integers + between `0` and `maximum-value` inclusive. + + For PPM images, `data` must be a two dimensional array of pixels, each of + which must be a 3 element vector of integers between `0` and `maximum-value` + inclusive. + + + +### `WRITE-TO-STREAM` (function) + + (WRITE-TO-STREAM STREAM DATA &KEY (FORMAT :PPM) (ENCODING :BINARY) + (MAXIMUM-VALUE (ECASE FORMAT (:PBM 1) ((:PGM :PPM) 255)))) + +Write a PPM image array `data` to `stream`. + + Nothing is returned. + + `format` must be one of `:pbm`, `:pgm`, `:ppm`. + + `encoding` must be one of `:binary`, `:ascii`. + + `maximum-value` must be the desired bit depth of the image (the maximum value + any particular pixel can have). For PBM images it must be `1`. + + For PBM and PGM images, `data` must be a two dimensional array of integers + between `0` and `maximum-value` inclusive. + + For PPM images, `data` must be a two dimensional array of pixels, each of + which must be a 3 element vector of integers between `0` and `maximum-value` + inclusive. + + + diff -r 05f84301a061 -r fb0afda02c8a package.lisp --- a/package.lisp Sat Feb 10 16:47:39 2018 -0500 +++ b/package.lisp Mon Dec 24 19:12:09 2018 -0500 @@ -1,9 +1,8 @@ (defpackage :trivial-ppm - (:use - :cl - :trivial-ppm.quickutils) + (:use :cl :trivial-ppm.quickutils) (:export :read-from-file :read-from-stream :write-to-file - :write-to-stream)) + :write-to-stream) + (:shadow :read-byte)) diff -r 05f84301a061 -r fb0afda02c8a src/main.lisp --- a/src/main.lisp Sat Feb 10 16:47:39 2018 -0500 +++ b/src/main.lisp Mon Dec 24 19:12:09 2018 -0500 @@ -1,39 +1,42 @@ (in-package :trivial-ppm) ;;;; Peekable Streams --------------------------------------------------------- -(defstruct (peekable-stream (:conc-name "") +(defstruct (peekable-stream (:conc-name nil) (:constructor make-peekable-stream (s))) (p nil :type (or null (unsigned-byte 8))) (s (error "Required") :type stream)) -(defun ps-actually-read-byte (stream &optional eof-error-p) - (read-byte (s stream) eof-error-p nil)) +(defun actually-read-byte (stream &optional eof-error-p) + (cl:read-byte (s stream) eof-error-p nil)) -(defun ps-read-byte (stream &optional eof-error-p) +(defun read-byte (stream &optional (eof-error-p t)) (if (p stream) (prog1 (p stream) (setf (p stream) nil)) - (ps-actually-read-byte stream eof-error-p))) + (actually-read-byte stream eof-error-p))) -(defun ps-peek-byte (stream) +(defun peek-byte (stream) (when (null (p stream)) - (setf (p stream) (ps-actually-read-byte stream))) + (setf (p stream) (actually-read-byte stream))) (p stream)) -(defun ps-unread-byte (stream byte) +(defun unread-byte (stream byte) (assert (null (p stream))) (setf (p stream) byte) (values)) ;;;; Utils -------------------------------------------------------------------- +;;; TODO: We're explicit about ASCII values here, but other places in the code +;;; rely on char-code and friends returning ASCII. Eventually we should +;;; probably fix that. + (defconstant +space+ 32) (defconstant +tab+ 9) (defconstant +line-feed+ 10) (defconstant +vertical-tab+ 11) (defconstant +form-feed+ 12) (defconstant +carriage-return+ 13) - (defconstant +comment-char+ 35) @@ -51,26 +54,31 @@ (defun skip-comment-body (stream) - (loop :until (line-terminator-p (ps-read-byte stream t)))) + (loop :until (line-terminator-p (read-byte stream)))) (defun skip-whitespace (stream) - (loop :for byte = (ps-read-byte stream) + (loop :for byte = (read-byte stream nil) :while (white-space-p byte) - :finally (ps-unread-byte stream byte))) + :finally (unread-byte stream byte))) (defun error-junk (section byte) (error "Junk byte in ~A data: ~D (~S)" section byte (code-char byte))) +(defun byte-to-digit (byte) + (when (and byte (<= (char-code #\0) byte (char-code #\9))) + (- byte (char-code #\0)))) + + (defun read-raster-number (stream) "Read the next ASCII-encoded number from `stream` (does not allow comments)." (skip-whitespace stream) (loop :with i = nil - :for byte = (ps-read-byte stream) - :for digit = (when byte (digit-char-p (code-char byte))) + :for byte = (read-byte stream nil) + :for digit = (byte-to-digit byte) :unless (or (null byte) digit (white-space-p byte)) :do (error-junk "raster" byte) - :while (and byte digit) + :while digit :do (setf i (+ (* (or i 0) 10) digit)) :finally (return i))) @@ -78,8 +86,8 @@ "Read the next ASCII-encoded number from `stream` (allows comments)." (skip-whitespace stream) (loop :with i = nil - :for byte = (ps-read-byte stream) - :for digit = (when byte (digit-char-p (code-char byte))) + :for byte = (read-byte stream nil) + :for digit = (byte-to-digit byte) :while byte :while (cond ((= byte +comment-char+) (skip-comment-body stream) t) (digit (setf i (+ (* (or i 0) 10) digit)) t) @@ -89,8 +97,10 @@ (defun read-magic-byte (stream) "Read the initial `P#` from `stream`, returning the magic `#` character." - (assert (eql (read-byte stream) (char-code #\P))) - (code-char (read-byte stream))) + (assert (eql (cl:read-byte stream) (char-code #\P)) (stream) + "Stream ~S does not appear to be in P*M file." + stream) + (code-char (cl:read-byte stream))) (defun write-string-as-bytes (string stream) @@ -102,7 +112,7 @@ (defmacro check-number (place maximum-value) `(assert (typep ,place `(integer 0 ,maximum-value)) (,place) - "Cannot write sample value ~D to PPM with maximum value of ~D" + "Cannot write sample value ~D to P*M with maximum value of ~D" ,place ,maximum-value)) @@ -149,52 +159,100 @@ ;;;; PPM ---------------------------------------------------------------------- +(defun bits (byte) + (loop :for i :from 7 :downto 0 + :collect (ldb (byte 1 i) byte))) + (defun read% (stream format binary?) - (let* ((width (read-header-number stream)) - (height (read-header-number stream)) - (bit-depth (if (eql :pbm format) 1 (read-header-number stream))) - (data (make-array (list width height) - :element-type (pixel-type format bit-depth))) - (reader (if binary? #'read-byte #'read-raster-number))) - (when binary? - (read-char stream)) ; chomp last newline before bytes - (dotimes (y height) - (dotimes (x width) - (setf (aref data x y) - (ecase format - (:pbm (- 1 (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)))))) - (values data format bit-depth))) + (let ((buffer nil)) + (flet ((read-bit-binary (stream) + (when (null buffer) + (setf buffer (bits (read-byte stream)))) + (pop buffer)) + (flush-buffer () + (setf buffer nil))) + (let* ((width (read-header-number stream)) + (height (read-header-number stream)) + (bit-depth (if (eql :pbm format) 1 (read-header-number stream))) + (data (make-array (list width height) + :element-type (pixel-type format bit-depth))) + (reader (if binary? + (if (eql format :pbm) + #'read-bit-binary + #'read-byte) + #'read-raster-number))) + (dotimes (y height) + (dotimes (x width) + (setf (aref data x y) + (ecase format + (:pbm (- 1 (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))))) + (flush-buffer)) + (values data format bit-depth))))) (defun write% (data stream format binary? maximum-value) - (let ((writer (if binary? - (curry #'write-number-binary maximum-value) - (curry #'write-number-ascii maximum-value)))) - (destructuring-bind (width height) (array-dimensions data) - (format-to-stream stream "P~D~%~D ~D~%~D~%" - (magic-byte format binary?) width height maximum-value) - (dotimes (y height) - (dotimes (x width) - (let ((pixel (aref data x y))) - (ecase format - (:pbm (funcall writer (- 1 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? (write-byte +line-feed+ stream)))))) + (let ((buffer 0) + (buffer-length 0)) + (labels ((write-bit-binary (bit stream) + (declare (ignore stream)) + (setf buffer (+ (ash buffer 1) bit)) + (incf buffer-length) + (when (= buffer-length 8) + (flush-buffer))) + (flush-buffer () + (when (plusp buffer-length) + (write-byte (ash buffer (- 8 buffer-length)) stream) + (setf buffer 0 buffer-length 0)))) + (let ((writer (if binary? + (if (eql format :pbm) + #'write-bit-binary + (curry #'write-number-binary maximum-value)) + (curry #'write-number-ascii maximum-value)))) + (destructuring-bind (width height) (array-dimensions data) + (format-to-stream stream "P~D~%~D ~D~%" + (magic-byte format binary?) width height) + (unless (eql format :pbm) + (format-to-stream stream "~D~%" maximum-value)) + (dotimes (y height) + (dotimes (x width) + (let ((pixel (aref data x y))) + (ecase format + (:pbm (funcall writer (- 1 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)))))) + (flush-buffer) + (unless binary? (write-byte +line-feed+ stream)))))))) ;;;; API ---------------------------------------------------------------------- +;;; TODO: The stream type checking here is kind of a mess. Basically what we +;;; care about is the following: +;;; +;;; * For input streams we need to be able to call (read-byte …) and get +;;; back numbers in the range 0-255. +;;; * For output streams we need to be able to call (write-byte …) with +;;; numbers in the range 0-255. +;;; +;;; As far as I can tell, there's no way to verify this in advance. Or, indeed, +;;; *at all*, because the spec for `write-byte` says: +;;; +;;; > Might signal an error of type type-error if byte is not an integer of the +;;; > stream element type of stream. +;;; +;;; "Might"?! + (defun read-from-stream (stream) "Read a PPM image file from `stream`, returning an array of pixels and more. - `stream` must be a binary input stream. + `stream` must be a binary input stream, specifically of `(unsigned-byte 8)`s + unless you *really* know what you're doing. The primary return value will be a 2D array with dimensions `(width height)`. Each element of the array will be a single pixel whose type depends on the @@ -210,6 +268,9 @@ * The bit depth of the image. " + (check-type stream stream) + (assert (input-stream-p stream) (stream) + "Stream ~S is not an input stream." stream) (multiple-value-bind (format binary?) (file-format (read-magic-byte stream)) (read% (make-peekable-stream stream) format binary?))) @@ -222,6 +283,9 @@ Nothing is returned. + `stream` must be a binary output stream, specifically of `(unsigned-byte 8)`s + unless you *really* know what you're doing. + `format` must be one of `:pbm`, `:pgm`, `:ppm`. `encoding` must be one of `:binary`, `:ascii`. @@ -237,6 +301,9 @@ inclusive. " + (check-type stream stream) + (assert (output-stream-p stream) (stream) + "Stream ~S is not an output stream." stream) (check-type format (member :ppm :pgm :pbm)) (check-type encoding (member :binary :ascii)) (if (eql format :pbm) @@ -290,6 +357,11 @@ inclusive. " + (check-type format (member :ppm :pgm :pbm)) + (check-type encoding (member :binary :ascii)) + (if (eql format :pbm) + (check-type maximum-value (eql 1)) + (check-type maximum-value (integer 1 *))) (flet ((write-it (stream) (write-to-stream stream data :format format diff -r 05f84301a061 -r fb0afda02c8a test/data/1x1-black.binary.pbm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/test/data/1x1-black.binary.pbm Mon Dec 24 19:12:09 2018 -0500 @@ -0,0 +1,3 @@ +P4 +1 1 +€ \ No newline at end of file diff -r 05f84301a061 -r fb0afda02c8a test/data/1x1-black.binary.pgm Binary file test/data/1x1-black.binary.pgm has changed diff -r 05f84301a061 -r fb0afda02c8a test/data/1x1-black.binary.ppm Binary file test/data/1x1-black.binary.ppm has changed diff -r 05f84301a061 -r fb0afda02c8a test/data/4x3-rgb.binary.ppm Binary file test/data/4x3-rgb.binary.ppm has changed diff -r 05f84301a061 -r fb0afda02c8a test/tests.lisp --- a/test/tests.lisp Sat Feb 10 16:47:39 2018 -0500 +++ b/test/tests.lisp Mon Dec 24 19:12:09 2018 -0500 @@ -55,3 +55,109 @@ (,b ,b ,b ,b)) :ppm 255)) + + +(define-test 1x1-black-binary-pbm + (check (trivial-ppm:read-from-file "test/data/1x1-black.binary.pbm") + '((0)) + :pbm + 1)) + +(define-test 1x1-black-binary-pgm + (check (trivial-ppm:read-from-file "test/data/1x1-black.binary.pgm") + '((0)) + :pgm + 255)) + +(define-test 1x1-black-binary-ppm + (check (trivial-ppm:read-from-file "test/data/1x1-black.binary.ppm") + `((,k)) + :ppm + 255)) + +(define-test 4x3-rgb.binary-ppm + (check (trivial-ppm:read-from-file "test/data/4x3-rgb.binary.ppm") + `((,r ,r ,r ,r) + (,g ,g ,g ,g) + (,b ,b ,b ,b)) + :ppm + 255)) + + +;;;; Fuzzer ------------------------------------------------------------------- +(defparameter *fuzz-test-count* 500) + + +(defun random-bit () + (random 2)) + +(defun random-gray () + (random 256)) + +(defun random-color () + (make-array 3 :initial-contents (list (random 256) + (random 256) + (random 256)))) + +(defun random-format () + (ecase (random 3) + (0 :pbm) + (1 :pgm) + (2 :ppm))) + +(defun make-random-array () + (let* ((width (1+ (random 50))) + (height (1+ (random 50))) + (format (random-format)) + (data (make-array (list width height)))) + (dotimes (x width) + (dotimes (y height) + (setf (aref data x y) + (ecase format + (:pbm (random-bit)) + (:pgm (random-gray)) + (:ppm (random-color)))))) + (values data format))) + + +(define-test fuzz-ascii + (dotimes (i *fuzz-test-count*) + (multiple-value-bind (original original-format) (make-random-array) + (write-to-file "test/data/fuzz.ascii" original + :if-exists :supersede + :format original-format + :encoding :ascii) + (multiple-value-bind (new new-format) + (read-from-file "test/data/fuzz.ascii") + (is (eql original-format new-format)) + (is (equalp original new)))))) + +(define-test fuzz-binary + (dotimes (i *fuzz-test-count*) + (multiple-value-bind (original original-format) (make-random-array) + (write-to-file "test/data/fuzz.binary" original + :if-exists :supersede + :format original-format + :encoding :binary) + (multiple-value-bind (new new-format) + (read-from-file "test/data/fuzz.binary") + (is (eql original-format new-format)) + (is (equalp original new)))))) + +(define-test fuzz-convert + (dotimes (i *fuzz-test-count*) + (multiple-value-bind (original original-format) (make-random-array) + (write-to-file "test/data/fuzz.convert.in" original + :if-exists :supersede + :format original-format + :encoding :ascii) + (uiop:run-program (list "convert" "-format" (ecase original-format + (:ppm "ppm") + (:pgm "pgm") + (:pbm "pbm")) + "test/data/fuzz.convert.in" + "test/data/fuzz.convert.out")) + (multiple-value-bind (new new-format) + (read-from-file "test/data/fuzz.convert.out") + (is (eql original-format new-format)) + (is (equalp original new))))))