fb0afda02c8a

Add fuzz tests and fix bugs
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Mon, 24 Dec 2018 19:12:09 -0500
parents 05f84301a061
children 1e155f658715
branches/tags (none)
files .hgignore docs/03-reference.markdown package.lisp src/main.lisp test/data/1x1-black.binary.pbm test/data/1x1-black.binary.pgm test/data/1x1-black.binary.ppm test/data/4x3-rgb.binary.ppm test/tests.lisp

Changes

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))))))