--- 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
--- 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)'
--- /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))
--- /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
--- /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
--- /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
--- /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
--- /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)
--- /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))
--- 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"))))
+
--- 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")
--- 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 ;;;;