# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1516940081 18000
# Node ID 1320162a9ed0bada7d1e3d52cf2e1353da3c0762
# Parent  aa5470cfe0267f95ccf587fb5554e9d79927ec9e
Add a basic test suite

diff -r aa5470cfe026 -r 1320162a9ed0 .hgignore
--- a/.hgignore	Mon Jan 22 18:35:39 2018 -0500
+++ b/.hgignore	Thu Jan 25 23:14:41 2018 -0500
@@ -3,4 +3,4 @@
 scratch.lisp
 *.log
 docs/build
-data
+images
diff -r aa5470cfe026 -r 1320162a9ed0 Makefile
--- a/Makefile	Mon Jan 22 18:35:39 2018 -0500
+++ b/Makefile	Thu Jan 25 23:14:41 2018 -0500
@@ -1,8 +1,9 @@
-.PHONY: vendor docs pubdocs
+.PHONY: vendor docs pubdocs test test-sbcl test-ccl test-ecl test-abcl
 
 sourcefiles = $(shell ffind --full-path --literal .lisp)
 docfiles = $(shell ls docs/*.markdown)
 apidocs = $(shell ls docs/*reference*.markdown)
+heading_printer = $(shell which heading || echo 'true')
 
 # Vendor ----------------------------------------------------------------------
 vendor/quickutils.lisp: vendor/make-quickutils.lisp
@@ -10,6 +11,25 @@
 
 vendor: vendor/quickutils.lisp
 
+# Testing ---------------------------------------------------------------------
+test: test-sbcl test-ccl test-ecl test-abcl
+
+test-sbcl: vendor
+	$(heading_printer) computer 'SBCL'
+	sbcl --load test/run.lisp
+
+test-ccl: vendor
+	$(heading_printer) slant 'CCL'
+	ccl --load test/run.lisp
+
+test-ecl: vendor
+	$(heading_printer) roman 'ECL'
+	ecl --load test/run.lisp
+
+test-abcl: vendor
+	$(heading_printer) broadway 'ABCL'
+	abcl --load test/run.lisp
+
 # Documentation ---------------------------------------------------------------
 $(apidocs): $(sourcefiles)
 	sbcl --noinform --load docs/api.lisp  --eval '(quit)'
diff -r aa5470cfe026 -r 1320162a9ed0 package.test.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/package.test.lisp	Thu Jan 25 23:14:41 2018 -0500
@@ -0,0 +1,8 @@
+(defpackage :trivial-ppm/test
+  (:use
+    :cl
+    :1am
+    :trivial-ppm
+    :trivial-ppm.quickutils)
+  (:export
+    :run-tests))
diff -r aa5470cfe026 -r 1320162a9ed0 test/data/1x1-black.ascii.pbm
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/test/data/1x1-black.ascii.pbm	Thu Jan 25 23:14:41 2018 -0500
@@ -0,0 +1,3 @@
+P1
+1 1
+0
diff -r aa5470cfe026 -r 1320162a9ed0 test/data/1x1-black.ascii.pgm
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/test/data/1x1-black.ascii.pgm	Thu Jan 25 23:14:41 2018 -0500
@@ -0,0 +1,4 @@
+P2
+1 1
+255
+0
diff -r aa5470cfe026 -r 1320162a9ed0 test/data/1x1-black.ascii.ppm
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/test/data/1x1-black.ascii.ppm	Thu Jan 25 23:14:41 2018 -0500
@@ -0,0 +1,4 @@
+P3
+1 1
+255
+0 0 0
diff -r aa5470cfe026 -r 1320162a9ed0 test/data/4x3-rgb.ascii.ppm
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/test/data/4x3-rgb.ascii.ppm	Thu Jan 25 23:14:41 2018 -0500
@@ -0,0 +1,6 @@
+P3
+4 3
+255
+255 0 0 255 100 0 255 0 0 255 0 0
+0 255 0 0 255 0 0 255 0 0 255 0
+0 0 255 0 0 255 0 0 255 0 0 255
diff -r aa5470cfe026 -r 1320162a9ed0 test/run.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/test/run.lisp	Thu Jan 25 23:14:41 2018 -0500
@@ -0,0 +1,5 @@
+#+ecl (setf compiler:*user-cc-flags* "-Wno-shift-negative-value")
+
+(ql:quickload :trivial-ppm)
+(time (asdf:test-system :trivial-ppm))
+(quit)
diff -r aa5470cfe026 -r 1320162a9ed0 test/tests.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/test/tests.lisp	Thu Jan 25 23:14:41 2018 -0500
@@ -0,0 +1,57 @@
+(in-package :trivial-ppm/test)
+
+
+;;;; Utils --------------------------------------------------------------------
+(defmacro define-test (name &body body)
+  `(test ,(symb 'test- name)
+    (let ((*package* ,*package*)
+          (r #(255 0 0))
+          (g #(0 255 0))
+          (b #(0 0 255))
+          (k #(0 0 0))
+          (w #(255 255 255)))
+      (declare (ignorable r g b k w))
+      ,@body)))
+
+(defun make-image-array (initial-data)
+  (make-array (list (length (elt initial-data 0))
+                    (length initial-data))
+              :initial-contents (transpose initial-data)))
+
+(defmacro check (form expected-data expected-format expected-bit-depth)
+  (with-gensyms (data format bit-depth)
+    `(multiple-value-bind (,data ,format ,bit-depth) ,form
+       (is (equalp (make-image-array ,expected-data) ,data))
+       (is (eql ,expected-format ,format))
+       (is (= ,expected-bit-depth ,bit-depth)))))
+
+(defun run-tests ()
+  (1am:run))
+
+
+;;;; Tests --------------------------------------------------------------------
+(define-test 1x1-black-ascii-pbm
+  (check (trivial-ppm:read-from-file "test/data/1x1-black.ascii.pbm")
+         '((0))
+         :pbm
+         1))
+
+(define-test 1x1-black-ascii-pgm
+  (check (trivial-ppm:read-from-file "test/data/1x1-black.ascii.pgm")
+         '((0))
+         :pgm
+         255))
+
+(define-test 1x1-black-ascii-ppm
+  (check (trivial-ppm:read-from-file "test/data/1x1-black.ascii.ppm")
+         `((,k))
+         :ppm
+         255))
+
+(define-test 4x3-rgb.ascii-ppm
+  (check (trivial-ppm:read-from-file "test/data/4x3-rgb.ascii.ppm")
+         `((,r ,r ,r ,r)
+           (,g ,g ,g ,g)
+           (,b ,b ,b ,b))
+         :ppm
+         255))
diff -r aa5470cfe026 -r 1320162a9ed0 trivial-ppm.asd
--- a/trivial-ppm.asd	Mon Jan 22 18:35:39 2018 -0500
+++ b/trivial-ppm.asd	Thu Jan 25 23:14:41 2018 -0500
@@ -3,11 +3,14 @@
   "Common Lisp support for reading/writing the PPM/PGM/PBM image formats."
 
   :author "Steve Losh <steve@stevelosh.com>"
-
+  :homepage "https://sjl.bitbucket.io/trivial-ppm/"
   :license "MIT/X11"
+  :version "0.0.1"
 
   :depends-on (:flexi-streams)
 
+  :in-order-to ((asdf:test-op (asdf:test-op :trivial-ppm/test)))
+
   :serial t
   :components ((:module "vendor" :serial t
                 :components ((:file "quickutils-package")
@@ -17,3 +20,21 @@
                 :components
                 ((:file "main")))))
 
+(asdf:defsystem :trivial-ppm/test
+  :description
+  "Test suite for trivial-ppm."
+
+  :author "Steve Losh <steve@stevelosh.com>"
+
+  :license "MIT/X11"
+
+  :depends-on (:trivial-ppm :1am)
+
+  :serial t
+  :components ((:file "package.test")
+               (:module "test"
+                :serial t
+                :components ((:file "tests"))))
+  :perform (asdf:test-op (op system)
+             (funcall (read-from-string "trivial-ppm/test:run-tests"))))
+
diff -r aa5470cfe026 -r 1320162a9ed0 vendor/make-quickutils.lisp
--- a/vendor/make-quickutils.lisp	Mon Jan 22 18:35:39 2018 -0500
+++ b/vendor/make-quickutils.lisp	Thu Jan 25 23:14:41 2018 -0500
@@ -5,6 +5,9 @@
   :utilities '(
 
                :curry
+               :symb
+               :with-gensyms
+               :transpose
 
                )
   :package "TRIVIAL-PPM.QUICKUTILS")
diff -r aa5470cfe026 -r 1320162a9ed0 vendor/quickutils.lisp
--- a/vendor/quickutils.lisp	Mon Jan 22 18:35:39 2018 -0500
+++ b/vendor/quickutils.lisp	Thu Jan 25 23:14:41 2018 -0500
@@ -2,7 +2,7 @@
 ;;;; See http://quickutil.org for details.
 
 ;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:CURRY) :ensure-package T :package "TRIVIAL-PPM.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:CURRY :SYMB :WITH-GENSYMS :TRANSPOSE) :ensure-package T :package "TRIVIAL-PPM.QUICKUTILS")
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (unless (find-package "TRIVIAL-PPM.QUICKUTILS")
@@ -14,7 +14,8 @@
 
 (when (boundp '*utilities*)
   (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
-                                         :CURRY))))
+                                         :CURRY :MKSTR :SYMB :STRING-DESIGNATOR
+                                         :WITH-GENSYMS :TRANSPOSE))))
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun make-gensym-list (length &optional (x "G"))
     "Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`,
@@ -58,7 +59,73 @@
          (lambda (&rest more)
            (apply ,fun ,@curries more)))))
   
+
+  (defun mkstr (&rest args)
+    "Receives any number of objects (string, symbol, keyword, char, number), extracts all printed representations, and concatenates them all into one string.
+
+Extracted from _On Lisp_, chapter 4."
+    (with-output-to-string (s)
+      (dolist (a args) (princ a s))))
+  
+
+  (defun symb (&rest args)
+    "Receives any number of objects, concatenates all into one string with `#'mkstr` and converts them to symbol.
+
+Extracted from _On Lisp_, chapter 4.
+
+See also: `symbolicate`"
+    (values (intern (apply #'mkstr args))))
+  
+
+  (deftype string-designator ()
+    "A string designator type. A string designator is either a string, a symbol,
+or a character."
+    `(or symbol string character))
+  
+
+  (defmacro with-gensyms (names &body forms)
+    "Binds each variable named by a symbol in `names` to a unique symbol around
+`forms`. Each of `names` must either be either a symbol, or of the form:
+
+    (symbol string-designator)
+
+Bare symbols appearing in `names` are equivalent to:
+
+    (symbol symbol)
+
+The string-designator is used as the argument to `gensym` when constructing the
+unique symbol the named variable will be bound to."
+    `(let ,(mapcar (lambda (name)
+                     (multiple-value-bind (symbol string)
+                         (etypecase name
+                           (symbol
+                            (values name (symbol-name name)))
+                           ((cons symbol (cons string-designator null))
+                            (values (first name) (string (second name)))))
+                       `(,symbol (gensym ,string))))
+            names)
+       ,@forms))
+
+  (defmacro with-unique-names (names &body forms)
+    "Binds each variable named by a symbol in `names` to a unique symbol around
+`forms`. Each of `names` must either be either a symbol, or of the form:
+
+    (symbol string-designator)
+
+Bare symbols appearing in `names` are equivalent to:
+
+    (symbol symbol)
+
+The string-designator is used as the argument to `gensym` when constructing the
+unique symbol the named variable will be bound to."
+    `(with-gensyms ,names ,@forms))
+  
+
+  (defun transpose (lists)
+    "Analog to matrix transpose for a list of lists given by `lists`."
+    (apply #'mapcar #'list lists))
+  
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (export '(curry)))
+  (export '(curry symb with-gensyms with-unique-names transpose)))
 
 ;;;; END OF quickutils.lisp ;;;;