# HG changeset patch # User Steve Losh # Date 1545884464 18000 # Node ID 1e155f6587153c57d066e27bfc33d7775c87f040 # Parent fb0afda02c8a551436e8a58758ab105f63de5486 Rename library diff -r fb0afda02c8a -r 1e155f658715 Makefile --- a/Makefile Mon Dec 24 19:12:09 2018 -0500 +++ b/Makefile Wed Dec 26 23:21:04 2018 -0500 @@ -41,6 +41,6 @@ pubdocs: docs hg -R ~/src/sjl.bitbucket.org pull -u - rsync --delete -a ./docs/build/ ~/src/sjl.bitbucket.org/trivial-ppm - hg -R ~/src/sjl.bitbucket.org commit -Am 'trivial-ppm: Update site.' + rsync --delete -a ./docs/build/ ~/src/sjl.bitbucket.org/cl-netpbm + hg -R ~/src/sjl.bitbucket.org commit -Am 'cl-netpbm: Update site.' hg -R ~/src/sjl.bitbucket.org push diff -r fb0afda02c8a -r 1e155f658715 README.markdown --- a/README.markdown Mon Dec 24 19:12:09 2018 -0500 +++ b/README.markdown Wed Dec 26 23:21:04 2018 -0500 @@ -1,7 +1,7 @@ -trivial-ppm is a Common Lisp library for reading and writing the [PPM, PGM, and -PBM image formats](https://en.wikipedia.org/wiki/Netpbm_format). +cl-netpbm is a Common Lisp library for reading and writing the [netpbm image +formats (PPM, PGM, and PBM)](https://en.wikipedia.org/wiki/Netpbm_format). * **License:** MIT/X11 -* **Documentation:** -* **Mercurial:** -* **Git:** +* **Documentation:** +* **Mercurial:** +* **Git:** diff -r fb0afda02c8a -r 1e155f658715 cl-netpbm.asd --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/cl-netpbm.asd Wed Dec 26 23:21:04 2018 -0500 @@ -0,0 +1,37 @@ +(asdf:defsystem :cl-netpbm + :description + "Common Lisp support for reading/writing the netpbm image formats (PPM, PGM, and PBM)." + + :author "Steve Losh " + :homepage "https://sjl.bitbucket.io/cl-netpbm/" + :license "MIT/X11" + :version "0.0.1" + + :depends-on () + + :in-order-to ((asdf:test-op (asdf:test-op :netpbm/test))) + + :serial t + :components ((:module "vendor" :serial t + :components ((:file "quickutils-package") + (:file "quickutils"))) + (:file "package") + (:module "src" :serial t + :components + ((:file "main"))))) + +(asdf:defsystem :cl-netpbm/test + :description "Test suite for cl-netpbm." + :author "Steve Losh " + :license "MIT/X11" + + :depends-on (:netpbm :1am) + + :serial t + :components ((:file "package.test") + (:module "test" + :serial t + :components ((:file "tests")))) + :perform (asdf:test-op (op system) + (funcall (read-from-string "netpbm/test:run-tests")))) + diff -r fb0afda02c8a -r 1e155f658715 docs/01-installation.markdown --- a/docs/01-installation.markdown Mon Dec 24 19:12:09 2018 -0500 +++ b/docs/01-installation.markdown Wed Dec 26 23:21:04 2018 -0500 @@ -1,7 +1,7 @@ Installation ============ -trivial-ppm is compatible with Quicklisp, but not *in* Quicklisp (yet?). You +cl-netpbm is compatible with Quicklisp, but not *in* Quicklisp (yet?). You can clone the repository into your [Quicklisp local-projects][local] directory for now. diff -r fb0afda02c8a -r 1e155f658715 docs/02-usage.markdown --- a/docs/02-usage.markdown Mon Dec 24 19:12:09 2018 -0500 +++ b/docs/02-usage.markdown Wed Dec 26 23:21:04 2018 -0500 @@ -1,7 +1,6 @@ Usage ===== -trivial-ppm [TOC] diff -r fb0afda02c8a -r 1e155f658715 docs/03-reference.markdown --- a/docs/03-reference.markdown Mon Dec 24 19:12:09 2018 -0500 +++ b/docs/03-reference.markdown Wed Dec 26 23:21:04 2018 -0500 @@ -1,6 +1,6 @@ # API Reference -The following is a list of all user-facing parts of trivial-ppm. +The following is a list of all user-facing parts of cl-netpbm. If there are backwards-incompatible changes to anything listed here, they will be noted in the changelog and the author will feel bad. @@ -10,7 +10,7 @@ [TOC] -## Package `TRIVIAL-PPM` +## Package `NETPBM` ### `READ-FROM-FILE` (function) @@ -39,7 +39,8 @@ 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 @@ -90,6 +91,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`. diff -r fb0afda02c8a -r 1e155f658715 docs/api.lisp --- a/docs/api.lisp Mon Dec 24 19:12:09 2018 -0500 +++ b/docs/api.lisp Wed Dec 26 23:21:04 2018 -0500 @@ -1,7 +1,7 @@ (ql:quickload "cl-d-api") (defparameter *header* - "The following is a list of all user-facing parts of trivial-ppm. + "The following is a list of all user-facing parts of cl-netpbm. If there are backwards-incompatible changes to anything listed here, they will be noted in the changelog and the author will feel bad. @@ -12,9 +12,9 @@ ") (d-api:generate-documentation - :trivial-ppm + :cl-netpbm #p"docs/03-reference.markdown" - (list "TRIVIAL-PPM") + (list :netpbm) *header* :title "API Reference") diff -r fb0afda02c8a -r 1e155f658715 docs/index.markdown --- a/docs/index.markdown Mon Dec 24 19:12:09 2018 -0500 +++ b/docs/index.markdown Wed Dec 26 23:21:04 2018 -0500 @@ -1,7 +1,7 @@ -trivial-ppm is a Common Lisp library for reading and writing the [PPM, PGM, and -PBM image formats](https://en.wikipedia.org/wiki/Netpbm_format). +cl-netpbm is a Common Lisp library for reading and writing the [netpbm image +formats (PPM, PGM, and PBM)](https://en.wikipedia.org/wiki/Netpbm_format). * **License:** MIT/X11 -* **Documentation:** -* **Mercurial:** -* **Git:** +* **Documentation:** +* **Mercurial:** +* **Git:** diff -r fb0afda02c8a -r 1e155f658715 docs/title --- a/docs/title Mon Dec 24 19:12:09 2018 -0500 +++ b/docs/title Wed Dec 26 23:21:04 2018 -0500 @@ -1,1 +1,1 @@ -trivial-ppm +cl-netpbm diff -r fb0afda02c8a -r 1e155f658715 package.lisp --- a/package.lisp Mon Dec 24 19:12:09 2018 -0500 +++ b/package.lisp Wed Dec 26 23:21:04 2018 -0500 @@ -1,5 +1,5 @@ -(defpackage :trivial-ppm - (:use :cl :trivial-ppm.quickutils) +(defpackage :netpbm + (:use :cl :netpbm.quickutils) (:export :read-from-file :read-from-stream diff -r fb0afda02c8a -r 1e155f658715 package.test.lisp --- a/package.test.lisp Mon Dec 24 19:12:09 2018 -0500 +++ b/package.test.lisp Wed Dec 26 23:21:04 2018 -0500 @@ -1,8 +1,8 @@ -(defpackage :trivial-ppm/test +(defpackage :netpbm/test (:use :cl :1am - :trivial-ppm - :trivial-ppm.quickutils) + :netpbm + :netpbm.quickutils) (:export :run-tests)) diff -r fb0afda02c8a -r 1e155f658715 src/main.lisp --- a/src/main.lisp Mon Dec 24 19:12:09 2018 -0500 +++ b/src/main.lisp Wed Dec 26 23:21:04 2018 -0500 @@ -1,4 +1,4 @@ -(in-package :trivial-ppm) +(in-package :netpbm) ;;;; Peekable Streams --------------------------------------------------------- (defstruct (peekable-stream (:conc-name nil) @@ -6,18 +6,16 @@ (p nil :type (or null (unsigned-byte 8))) (s (error "Required") :type stream)) -(defun actually-read-byte (stream &optional eof-error-p) - (cl:read-byte (s stream) eof-error-p nil)) (defun read-byte (stream &optional (eof-error-p t)) (if (p stream) (prog1 (p stream) (setf (p stream) nil)) - (actually-read-byte stream eof-error-p))) + (cl:read-byte (s stream) eof-error-p nil))) (defun peek-byte (stream) (when (null (p stream)) - (setf (p stream) (actually-read-byte stream))) + (setf (p stream) (cl:read-byte (s stream)))) (p stream)) (defun unread-byte (stream byte) @@ -26,7 +24,7 @@ (values)) -;;;; Utils -------------------------------------------------------------------- +;;;; Implementation ----------------------------------------------------------- ;;; 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. @@ -112,20 +110,23 @@ (defmacro check-number (place maximum-value) `(assert (typep ,place `(integer 0 ,maximum-value)) (,place) - "Cannot write sample value ~D to P*M with maximum value of ~D" + "Cannot write sample value ~D to Netpbm file with maximum value of ~D" ,place ,maximum-value)) -(defun write-number-ascii (maximum-value value stream) +(defun write-number-ascii (value stream maximum-value) "Write `value` to stream as an ASCII-encoded number, with sanity check." (check-number value maximum-value) (format-to-stream stream "~D " value)) -(defun write-number-binary (maximum-value value stream) - "Write `value` to stream as a binary value, with sanity check." +(defun write-number-binary (value stream maximum-value) + "Write `value` to `stream` as a binary value, with sanity check." (check-number value maximum-value) (write-byte value stream)) +(defun write-line-feed (stream) + (write-byte +line-feed+ stream)) + (defun file-format (magic-byte) "Return `(values format binary?)` for the given magic byte character." @@ -158,77 +159,146 @@ (:ppm `(simple-array (integer 0 ,bit-depth) (3))))) -;;;; PPM ---------------------------------------------------------------------- (defun bits (byte) (loop :for i :from 7 :downto 0 :collect (ldb (byte 1 i) byte))) -(defun read% (stream format binary?) - (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 make-color (r g b) + (make-array 3 + :initial-contents (list r g b) + :element-type 'fixnum)) + + +;;;; Reading ------------------------------------------------------------------ +(defun read-bitmap-binary (stream &aux (buffer nil)) + (flet ((read-bit (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)) + (data (make-array (list width height) :element-type 'bit))) + (dotimes (y height) + (dotimes (x width) + (setf (aref data x y) (- 1 (read-bit stream)))) + (flush-buffer)) + (values data :pbm 1)))) + +(defun read-bitmap-ascii (stream) + (flet ((read-bit (stream) + (skip-whitespace stream) + (byte-to-digit (read-byte stream)))) + (let* ((width (read-header-number stream)) + (height (read-header-number stream)) + (data (make-array (list width height) :element-type 'bit))) + (dotimes (y height) + (dotimes (x width) + (setf (aref data x y) (- 1 (read-bit stream))))) + (values data :pbm 1)))) + +(defun read-graymap (stream binary?) + (let* ((width (read-header-number stream)) + (height (read-header-number stream)) + (bit-depth (read-header-number stream)) + (data (make-array (list width height) + :element-type `(integer 0 ,bit-depth))) + (reader (if binary? #'read-byte #'read-raster-number))) + (dotimes (y height) + (dotimes (x width) + (setf (aref data x y) (funcall reader stream)))) + (values data :pgm bit-depth))) + +(defun read-pixmap (stream binary?) + (let* ((width (read-header-number stream)) + (height (read-header-number stream)) + (bit-depth (read-header-number stream)) + (data (make-array (list width height) + :element-type `(simple-array (integer 0 ,bit-depth) (3)))) + (reader (if binary? #'read-byte #'read-raster-number))) + (dotimes (y height) + (dotimes (x width) + (setf (aref data x y) (make-color (funcall reader stream) + (funcall reader stream) + (funcall reader stream))))) + (values data :ppm bit-depth))) + -(defun write% (data stream format binary? maximum-value) - (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)))))))) +(defun read-netpbm (stream format binary?) + (ecase format + (:pbm (if binary? + (read-bitmap-binary stream) + (read-bitmap-ascii stream))) + (:pgm (read-graymap stream binary?)) + (:ppm (read-pixmap stream binary?)))) + + +;;;; Writing ------------------------------------------------------------------ +(defun write-bitmap-binary (data stream &aux (buffer 0) (buffer-length 0)) + (labels ((write-buffer (stream) + (write-byte buffer stream) + (setf buffer 0 buffer-length 0)) + (write-bit (bit stream) + (setf buffer (+ (ash buffer 1) bit)) + (incf buffer-length) + (when (= buffer-length 8) + (write-buffer stream))) + (flush-buffer (stream) + (when (plusp buffer-length) + (setf buffer (ash buffer (- 8 buffer-length))) + (write-buffer stream)))) + (destructuring-bind (width height) (array-dimensions data) + (format-to-stream stream "P~D~%~D ~D~%" (magic-byte :pbm t) width height) + (dotimes (y height) + (dotimes (x width) + (let ((pixel (aref data x y))) + (write-bit (- 1 pixel) stream))) + (flush-buffer stream))))) + +(defun write-bitmap-ascii (data stream) + (destructuring-bind (width height) (array-dimensions data) + (format-to-stream stream "P~D~%~D ~D~%" (magic-byte :pbm nil) width height) + (dotimes (y height) + (dotimes (x width) + (write-number-ascii (- 1 (aref data x y)) stream 1)) + (write-line-feed stream)))) + +(defun write-graymap (data stream binary? maximum-value) + (let ((writer (if binary? + #'write-number-binary + #'write-number-ascii))) + (destructuring-bind (width height) (array-dimensions data) + (format-to-stream stream "P~D~%~D ~D~%~D~%" + (magic-byte :pgm binary?) width height maximum-value) + (dotimes (y height) + (dotimes (x width) + (funcall writer (aref data x y) stream maximum-value)) + (unless binary? (write-line-feed stream)))))) + +(defun write-pixmap (data stream binary? maximum-value) + (let ((writer (if binary? + #'write-number-binary + #'write-number-ascii))) + (destructuring-bind (width height) (array-dimensions data) + (format-to-stream stream "P~D~%~D ~D~%~D~%" + (magic-byte :ppm binary?) width height maximum-value) + (dotimes (y height) + (dotimes (x width) + (let ((pixel (aref data x y))) + (funcall writer (aref pixel 0) stream maximum-value) + (funcall writer (aref pixel 1) stream maximum-value) + (funcall writer (aref pixel 2) stream maximum-value))) + (unless binary? (write-line-feed stream)))))) + + +(defun write-netpbm (data stream format binary? maximum-value) + (ecase format + (:pbm (if binary? + (write-bitmap-binary data stream) + (write-bitmap-ascii data stream))) + (:pgm (write-graymap data stream binary? maximum-value)) + (:ppm (write-pixmap data stream binary? maximum-value)))) ;;;; API ---------------------------------------------------------------------- @@ -273,7 +343,7 @@ "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?))) + (read-netpbm (make-peekable-stream stream) format binary?))) (defun write-to-stream (stream data &key (format :ppm) @@ -309,7 +379,7 @@ (if (eql format :pbm) (check-type maximum-value (eql 1)) (check-type maximum-value (integer 1 *))) - (write% data stream format (eql :binary encoding) maximum-value) + (write-netpbm data stream format (eql :binary encoding) maximum-value) (values)) diff -r fb0afda02c8a -r 1e155f658715 test/run.lisp --- a/test/run.lisp Mon Dec 24 19:12:09 2018 -0500 +++ b/test/run.lisp Wed Dec 26 23:21:04 2018 -0500 @@ -1,5 +1,5 @@ #+ecl (setf compiler:*user-cc-flags* "-Wno-shift-negative-value") -(ql:quickload :trivial-ppm) -(time (asdf:test-system :trivial-ppm)) +(ql:quickload :netpbm) +(time (asdf:test-system :netpbm)) (quit) diff -r fb0afda02c8a -r 1e155f658715 test/tests.lisp --- a/test/tests.lisp Mon Dec 24 19:12:09 2018 -0500 +++ b/test/tests.lisp Wed Dec 26 23:21:04 2018 -0500 @@ -1,4 +1,4 @@ -(in-package :trivial-ppm/test) +(in-package :netpbm/test) ;;;; Utils -------------------------------------------------------------------- @@ -31,25 +31,25 @@ ;;;; Tests -------------------------------------------------------------------- (define-test 1x1-black-ascii-pbm - (check (trivial-ppm:read-from-file "test/data/1x1-black.ascii.pbm") + (check (netpbm: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") + (check (netpbm: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") + (check (netpbm: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") + (check (netpbm:read-from-file "test/data/4x3-rgb.ascii.ppm") `((,r ,r ,r ,r) (,g ,g ,g ,g) (,b ,b ,b ,b)) @@ -58,25 +58,25 @@ (define-test 1x1-black-binary-pbm - (check (trivial-ppm:read-from-file "test/data/1x1-black.binary.pbm") + (check (netpbm: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") + (check (netpbm: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") + (check (netpbm: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") + (check (netpbm:read-from-file "test/data/4x3-rgb.binary.ppm") `((,r ,r ,r ,r) (,g ,g ,g ,g) (,b ,b ,b ,b)) diff -r fb0afda02c8a -r 1e155f658715 trivial-ppm.asd --- a/trivial-ppm.asd Mon Dec 24 19:12:09 2018 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,40 +0,0 @@ -(asdf:defsystem :trivial-ppm - :description - "Common Lisp support for reading/writing the PPM/PGM/PBM image formats." - - :author "Steve Losh " - :homepage "https://sjl.bitbucket.io/trivial-ppm/" - :license "MIT/X11" - :version "0.0.1" - - :depends-on () - - :in-order-to ((asdf:test-op (asdf:test-op :trivial-ppm/test))) - - :serial t - :components ((:module "vendor" :serial t - :components ((:file "quickutils-package") - (:file "quickutils"))) - (:file "package") - (:module "src" :serial t - :components - ((:file "main"))))) - -(asdf:defsystem :trivial-ppm/test - :description - "Test suite for trivial-ppm." - - :author "Steve Losh " - - :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 fb0afda02c8a -r 1e155f658715 vendor/make-quickutils.lisp --- a/vendor/make-quickutils.lisp Mon Dec 24 19:12:09 2018 -0500 +++ b/vendor/make-quickutils.lisp Wed Dec 26 23:21:04 2018 -0500 @@ -10,4 +10,4 @@ :transpose ) - :package "TRIVIAL-PPM.QUICKUTILS") + :package "NETPBM.QUICKUTILS") diff -r fb0afda02c8a -r 1e155f658715 vendor/quickutils-package.lisp --- a/vendor/quickutils-package.lisp Mon Dec 24 19:12:09 2018 -0500 +++ b/vendor/quickutils-package.lisp Wed Dec 26 23:21:04 2018 -0500 @@ -1,10 +1,10 @@ (eval-when (:compile-toplevel :load-toplevel :execute) - (unless (find-package "TRIVIAL-PPM.QUICKUTILS") - (defpackage "TRIVIAL-PPM.QUICKUTILS" + (unless (find-package "NETPBM.QUICKUTILS") + (defpackage "NETPBM.QUICKUTILS" (:documentation "Package that contains Quickutil utility functions.") (:use :cl)))) -(in-package "TRIVIAL-PPM.QUICKUTILS") +(in-package "NETPBM.QUICKUTILS") ;; need to define this here so sbcl will shut the hell up about it being ;; undefined when compiling quickutils.lisp. computers are trash.