├── LICENSE ├── README.txt ├── bitstream.lisp ├── canvas.lisp ├── color-table.lisp ├── conditions.lisp ├── data-stream.lisp ├── doc ├── example1.gif ├── example2.gif ├── example3.gif └── index.html ├── example.lisp ├── gif89a.lisp ├── image.lisp ├── load-gif.lisp ├── lzw.lisp ├── package.lisp ├── skippy.asd └── types.lisp /LICENSE: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials 13 | ;;; provided with the distribution. 14 | ;;; 15 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 16 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 18 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 19 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 20 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 21 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 22 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 23 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 24 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 25 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | -------------------------------------------------------------------------------- /README.txt: -------------------------------------------------------------------------------- 1 | Skippy can read and write GIF files. It is available under a BSD-style 2 | license. 3 | 4 | For documentation, see HTML docs in doc/index.html. 5 | 6 | For any questions and comments, please email Zach Beane 7 | . 8 | -------------------------------------------------------------------------------- /bitstream.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials 13 | ;;; provided with the distribution. 14 | ;;; 15 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 16 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 18 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 19 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 20 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 21 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 22 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 23 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 24 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 25 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | ;;; 27 | ;;;; $Id: bitstream.lisp,v 1.6 2007/01/03 22:02:37 xach Exp $ 28 | 29 | (in-package #:skippy) 30 | 31 | (declaim (inline bitstream-buffer)) 32 | (declaim (inline bitstream-offset)) 33 | (declaim (inline bitstream-octet)) 34 | (declaim (inline bitstream-count)) 35 | (declaim (inline bitstream-bits-left)) 36 | (declaim (inline bitstream-stream)) 37 | 38 | (defstruct (bitstream 39 | (:constructor 40 | %make-bitstream (buffer offset count octet bits-left stream))) 41 | (buffer (make-array 255 :element-type 'octet) 42 | :type bitstream-buffer) 43 | (offset 0 :type octet) 44 | (count 0 :type octet) 45 | (octet 0 :type octet) 46 | (bits-left 8 :type (mod 9)) 47 | stream) 48 | 49 | (defun make-bitstream (stream) 50 | (%make-bitstream (make-array 255 :element-type 'octet) 51 | 0 52 | 0 53 | 0 54 | 8 55 | stream)) 56 | 57 | (eval-when (:compile-toplevel :load-toplevel :execute) 58 | (defparameter *bitstream-slot-attributes* 59 | '((buffer 60 | :reader bitstream-buffer 61 | :type bitstream-buffer 62 | :save nil) 63 | (offset 64 | :reader bitstream-offset 65 | :type octet) 66 | (count 67 | :reader bitstream-count 68 | :type octet) 69 | (octet 70 | :reader bitstream-octet 71 | :type octet) 72 | (bits-left 73 | :reader bitstream-bits-left 74 | :type (mod 9)) 75 | (stream 76 | :reader bitstream-stream 77 | :type cl:stream 78 | :save nil)))) 79 | 80 | (defmacro with-bitstream-slots (name-bindings bitstream &body body) 81 | (labels ((binding-var (binding) 82 | (if (consp binding) (first binding) binding)) 83 | (binding-slot (binding) 84 | (if (consp binding) (second binding) binding))) 85 | (let ((type-declarations '()) 86 | (binding-forms '()) 87 | (save-forms '()) 88 | (bitstream-var (gensym))) 89 | (dolist (binding name-bindings) 90 | (let* ((var (binding-var binding)) 91 | (slot (binding-slot binding)) 92 | (attributes (cdr (assoc slot *bitstream-slot-attributes*)))) 93 | (unless attributes 94 | (error "Unknown bitstream slot -- ~S" slot)) 95 | (destructuring-bind (&key reader type (save t)) 96 | attributes 97 | (push `(,var (,reader ,bitstream-var)) binding-forms) 98 | (push `(type ,type ,var) type-declarations) 99 | (when save 100 | (push `(setf (,reader ,bitstream-var) ,var) save-forms))))) 101 | `(let ((,bitstream-var ,bitstream)) 102 | (let ,binding-forms 103 | (declare ,@type-declarations) 104 | ,@body 105 | ,@save-forms))))) 106 | 107 | (defun reset-stream (bitstream) 108 | (declare (optimize speed) 109 | (type bitstream bitstream)) 110 | (with-bitstream-slots (stream buffer offset octet bits-left) 111 | bitstream 112 | (when (plusp bits-left) 113 | (setf (aref buffer offset) octet 114 | offset (1+ offset))) 115 | (write-byte offset stream) 116 | (write-sequence buffer stream :end offset) 117 | (fill buffer 0))) 118 | 119 | (defun write-bits (code length bitstream) 120 | (declare (type (mod 13) length) 121 | (type fixnum code) 122 | (type bitstream bitstream) 123 | (optimize speed)) 124 | (with-bitstream-slots (stream buffer offset octet bits-left) 125 | bitstream 126 | (flet ((merge-bits (len) 127 | (declare (type (mod 13) len)) 128 | (setf octet (logand #xFF 129 | (logior (ash (ldb (byte len 0) code) 130 | (- 8 bits-left)) 131 | octet)) 132 | bits-left (- bits-left len) 133 | code (ash code (- len)) 134 | length (- length len)))) 135 | (declare (inline merge-bits)) 136 | (loop 137 | (when (< length bits-left) 138 | (return)) 139 | (merge-bits bits-left) 140 | (setf bits-left 8 141 | (aref buffer offset) octet 142 | offset (1+ offset) 143 | octet 0) 144 | (when (= offset 255) 145 | (write-byte 255 stream) 146 | (write-sequence buffer stream) 147 | (fill buffer 0) 148 | (setf offset 0))) 149 | (when (plusp length) 150 | (merge-bits length))))) 151 | 152 | (defun make-input-bitstream (stream) 153 | (let ((count (read-byte stream)) 154 | (offset 0) 155 | (buffer (make-array 255 :element-type 'octet)) 156 | (bits-left 0)) 157 | (read-sequence buffer stream :end count) 158 | (%make-bitstream buffer offset count 0 bits-left stream))) 159 | 160 | ;;; 161 | ;;; When entering and leaving read-bits, OFFSET is always <255 and points 162 | ;;; at the NEXT input offset. It is 0 at the start of the process. 163 | ;;; 164 | ;;; BITS-LEFT may be zero when entering. 165 | ;;; 166 | 167 | (defun read-bits (length bitstream) 168 | (declare (type (mod 13) length) 169 | (type bitstream bitstream) 170 | (optimize speed)) 171 | (let ((result 0) 172 | (result-offset 0)) 173 | (declare (type (unsigned-byte 12) result) 174 | (type (mod 13) result-offset)) 175 | (with-bitstream-slots (stream offset count octet buffer bits-left) 176 | bitstream 177 | (loop 178 | (cond ((< length bits-left) 179 | (setf result (logior result 180 | (ash (ldb (byte length 0) octet) 181 | result-offset)) 182 | octet (ash octet (- length)) 183 | bits-left (- bits-left length)) 184 | (return)) 185 | (t 186 | (when (= offset count) 187 | (setf count (read-byte stream) 188 | offset 0) 189 | (read-sequence buffer stream :end count)) 190 | (setf result (logior result (ash octet result-offset)) 191 | result-offset (+ bits-left result-offset) 192 | length (- length bits-left) 193 | octet (aref buffer offset) 194 | offset (+ offset 1) 195 | bits-left 8))))) 196 | result)) 197 | 198 | (defun finish-input (bitstream) 199 | (when (plusp (bitstream-count bitstream)) 200 | (let ((final-block (read-byte (bitstream-stream bitstream)))) 201 | (unless (zerop final-block) 202 | (skippy-warn "Unexpected final block value in stream ~ 203 | (expected ~D, got ~D)" 204 | 0 final-block))))) 205 | 206 | -------------------------------------------------------------------------------- /canvas.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials 13 | ;;; provided with the distribution. 14 | ;;; 15 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 16 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 18 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 19 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 20 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 21 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 22 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 23 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 24 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 25 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | ;;; 27 | ;;;; $Id: canvas.lisp,v 1.15 2006/12/28 16:35:01 xach Exp $ 28 | 29 | (in-package #:skippy) 30 | 31 | (deftype canvas-data () 32 | '(simple-array (unsigned-byte 8) (*))) 33 | 34 | (deftype canvas-index () 35 | `(mod ,most-positive-fixnum)) 36 | 37 | (deftype palette-index () 38 | '(unsigned-byte 8)) 39 | 40 | (defclass canvas () 41 | ((height 42 | :initarg :height 43 | :reader height) 44 | (width 45 | :initarg :width 46 | :reader width) 47 | (image-data 48 | :initarg :image-data 49 | :accessor image-data)) 50 | (:default-initargs 51 | :height (error "~S required" :height) 52 | :width (error "~S required" :width))) 53 | 54 | (defun make-image-data (width height &key 55 | (initial-element 0) 56 | initial-contents) 57 | (if initial-contents 58 | (make-array (* width height) 59 | :element-type 'octet 60 | :initial-contents initial-contents) 61 | (make-array (* width height) 62 | :element-type 'octet 63 | :initial-element initial-element))) 64 | 65 | (defun make-canvas (&key width height 66 | image-data (initial-element 0) initial-contents) 67 | (unless (and height width) 68 | (error "~S and ~S required" :height :width)) 69 | (unless image-data 70 | (setf image-data (make-image-data width height 71 | :initial-element initial-element 72 | :initial-contents initial-contents))) 73 | (make-instance 'canvas 74 | :height height 75 | :width width 76 | :image-data image-data)) 77 | 78 | 79 | (defmethod print-object ((canvas canvas) stream) 80 | (print-unreadable-object (canvas stream :type t :identity t) 81 | (format stream "geometry ~Dx~D" (width canvas) (height canvas)))) 82 | 83 | (defmethod initialize-instance :after ((canvas canvas) &key height width) 84 | (unless (slot-boundp canvas 'image-data) 85 | (setf (image-data canvas) (make-array (* height width) 86 | :initial-element 0 87 | :element-type 'octet)))) 88 | 89 | (defun clip (xmin0 ymin0 xmax0 ymax0 90 | xmin1 ymin1 xmax1 ymax1) 91 | (flet ((clamp (min val max) 92 | (cond ((< val min) min) 93 | ((> val max) max) 94 | (t val)))) 95 | (values (clamp xmin0 xmin1 xmax0) 96 | (clamp ymin0 ymin1 ymax0) 97 | (clamp xmin0 xmax1 xmax0) 98 | (clamp ymin0 ymax1 ymax0)))) 99 | 100 | (defun clip-canvas (source dest &key (sx 0) (sy 0) (dx 0) (dy 0) 101 | (width (width source)) (height (height source))) 102 | "Return new dx,dy and sx,sy and width,height values to use when 103 | clipping SOURCE to fit within the bounds of DEST." 104 | (let* ( ;; destination 105 | (xmin0 0) 106 | (ymin0 0) 107 | (xmax0 (width dest)) 108 | (ymax0 (height dest)) 109 | ;; source 110 | (xmin1 (- dx sx)) 111 | (ymin1 (- dy sy)) 112 | (xmax1 (+ xmin1 (width source))) 113 | (ymax1 (+ ymin1 (height source))) 114 | ;; source offset 115 | (xmin2 dx) 116 | (ymin2 dy) 117 | (xmax2 (+ xmin2 width)) 118 | (ymax2 (+ ymin2 height))) 119 | ;; clip source offset to source 120 | (multiple-value-bind (xmin3 ymin3 xmax3 ymax3) 121 | (clip xmin1 ymin1 xmax1 ymax1 122 | xmin2 ymin2 xmax2 ymax2) 123 | ;; clip that against dest 124 | (multiple-value-bind (xmin4 ymin4 xmax4 ymax4) 125 | (clip xmin0 ymin0 xmax0 ymax0 126 | xmin3 ymin3 xmax3 ymax3) 127 | (values xmin4 ymin4 128 | (- xmin4 xmin1) 129 | (- ymin4 ymin1) 130 | (- xmax4 xmin4) 131 | (- ymax4 ymin4)))))) 132 | 133 | (defun composite (source dest 134 | &key (sx 0) (sy 0) 135 | (dx 0) (dy 0) 136 | (width (width source)) (height (height source))) 137 | (multiple-value-bind (dx* dy* sx* sy* width* height*) 138 | (clip-canvas source dest 139 | :sx sx :sy sy 140 | :dx dx :dy dy 141 | :width width :height height) 142 | (when (or (zerop width*) 143 | (zerop height*)) 144 | (return-from composite)) 145 | (let ((source-data (image-data source)) 146 | (source-width (width source)) 147 | (dest-data (image-data dest)) 148 | (dest-width (width dest))) 149 | (declare (type canvas-data source-data dest-data) 150 | (type canvas-index source-width dest-width)) 151 | (loop repeat height* 152 | for source-start from (+ (* source-width sy*) sx*) by source-width 153 | for dest-start from (+ (* dest-width dy*) dx*) by dest-width 154 | for source-end from (+ source-start width*) by source-width 155 | do (replace dest-data source-data :start1 dest-start 156 | :start2 source-start :end2 source-end)) 157 | dest))) 158 | 159 | 160 | 161 | 162 | 163 | ;;; Save and load canvases 164 | 165 | (defvar *canvas-magic* 166 | (make-array 3 :element-type '(unsigned-byte 8) 167 | :initial-contents (list #x89 #xAD #x17))) 168 | 169 | (defvar *file-format-version* 1) 170 | 171 | (defun write-u32 (i stream) 172 | (write-byte (logand #xFF (ash i -24)) stream) 173 | (write-byte (logand #xFF (ash i -16)) stream) 174 | (write-byte (logand #xFF (ash i -8)) stream) 175 | (write-byte (logand #xFF (ash i 0)) stream)) 176 | 177 | (defun read-u32 (stream) 178 | (logand #xFFFFFFFF 179 | (+ (ash (read-byte stream) 24) 180 | (ash (read-byte stream) 16) 181 | (ash (read-byte stream) 8) 182 | (ash (read-byte stream) 0)))) 183 | 184 | (defun write-canvas (canvas stream) 185 | (write-sequence *canvas-magic* stream) 186 | (write-byte *file-format-version* stream) 187 | (write-u32 (width canvas) stream) 188 | (write-u32 (height canvas) stream) 189 | (write-sequence (image-data canvas) stream) 190 | t) 191 | 192 | (defun read-canvas (stream) 193 | (dotimes (i (length *canvas-magic*)) 194 | (let ((byte (read-byte stream))) 195 | (when (/= byte (aref *canvas-magic* i)) 196 | (error "Bad magic in stream")))) 197 | (let ((version (read-byte stream))) 198 | (when (/= version *file-format-version*) 199 | (error "Unsupported version in stream -- expected ~D, read ~D" 200 | *file-format-version* version))) 201 | (let ((width (read-u32 stream)) 202 | (height (read-u32 stream))) 203 | (when (>= (* width height) array-total-size-limit) 204 | (error "Canvas dimensions (~Dx~D) too large to load" 205 | width height)) 206 | (let ((canvas (make-instance 'canvas :height height :width width))) 207 | (read-sequence (image-data canvas) stream) 208 | canvas))) 209 | 210 | (defun save-canvas (canvas file &key (if-exists :supersede)) 211 | (with-open-file (stream file :element-type '(unsigned-byte 8) 212 | :direction :output 213 | :if-does-not-exist :create 214 | :if-exists if-exists) 215 | (write-canvas canvas stream)) 216 | (probe-file file)) 217 | 218 | (defun load-canvas (file) 219 | (with-open-file (stream file :element-type '(unsigned-byte 8) 220 | :direction :input) 221 | (read-canvas stream))) 222 | 223 | 224 | ;;; Useful operations 225 | 226 | (defun fill-canvas (canvas palette-index) 227 | (declare (type palette-index palette-index) 228 | (optimize (speed 3))) 229 | (let ((data (image-data canvas))) 230 | (declare (type canvas-data data)) 231 | (fill data palette-index) 232 | (values))) 233 | 234 | (defmethod clone ((canvas canvas)) 235 | (make-instance 'canvas 236 | :height (height canvas) 237 | :width (width canvas) 238 | :image-data (copy-seq (image-data canvas)))) 239 | 240 | (defmethod flip-horizontal (canvas) 241 | "Horizontally mirror the image data of CANVAS." 242 | (loop repeat (height canvas) 243 | with data = (image-data canvas) 244 | with width = (width canvas) 245 | for i = 0 then (+ i width) 246 | for j = (1- width) then (+ j width) 247 | do (loop for m from i 248 | for n downfrom j 249 | while (< m n) do 250 | (rotatef (aref data m) (aref data n)))) 251 | canvas) 252 | 253 | (defmethod rotate-180 (canvas) 254 | "Does a 180-degree rotation of the image data of CANVAS." 255 | (setf (image-data canvas) (nreverse (image-data canvas))) 256 | canvas) 257 | 258 | (defmethod flip-vertical (canvas) 259 | "Vertically mirror the image data of CANVAS." 260 | (rotate-180 canvas) 261 | (flip-horizontal canvas)) 262 | 263 | (defmethod scale ((canvas canvas) factor) 264 | "Integer scale CANVAS and return it as a new canvas." 265 | (let* ((width (* (width canvas) factor)) 266 | (height (* (height canvas) factor)) 267 | (new (make-instance 'canvas :width width :height height))) 268 | (dotimes (y (height canvas) new) 269 | (dotimes (x (width canvas)) 270 | (let ((p (pixel-ref canvas x y)) 271 | (xf (* x factor)) 272 | (yf (* y factor))) 273 | (dotimes (i factor) 274 | (dotimes (j factor) 275 | (setf (pixel-ref new (+ xf i) (+ yf j)) p)))))))) 276 | 277 | (defmethod fill-area (canvas palette-index &key 278 | (x 0) 279 | (y 0) 280 | (width (width canvas)) 281 | (height (height canvas))) 282 | (let ((xmin0 x) 283 | (ymin0 y) 284 | (xmax0 (+ x width)) 285 | (ymax0 (+ y height)) 286 | (xmin1 0) 287 | (ymin1 0) 288 | (xmax1 (width canvas)) 289 | (ymax1 (height canvas))) 290 | (multiple-value-bind (xmin2 ymin2 xmax2 ymax2) 291 | (clip xmin0 ymin0 xmax0 ymax0 292 | xmin1 ymin1 xmax1 ymax1) 293 | (let ((w (- xmax2 xmin2)) 294 | (h (- ymax2 ymin2))) 295 | (when (and (plusp w) (plusp h)) 296 | (loop with dest-width = (width canvas) 297 | with data = (image-data canvas) 298 | with start = (+ xmin2 (* ymin2 dest-width)) 299 | for i = start then (+ i dest-width) 300 | for j = (+ start w) then (+ j dest-width) 301 | repeat h 302 | do (fill data palette-index :start i :end j))))))) 303 | 304 | (defmethod pixel-ref (canvas x y) 305 | (aref (image-data canvas) (+ (* y (width canvas)) x))) 306 | 307 | (defmethod (setf pixel-ref) (new-value canvas x y) 308 | (setf (aref (image-data canvas) (+ (* y (width canvas)) x)) new-value)) 309 | 310 | (defun deinterlaced-image-data (canvas) 311 | (let* ((source (image-data canvas)) 312 | (dest (copy-seq source)) 313 | (width (width canvas)) 314 | (height (height canvas))) 315 | (declare (type (simple-array octet (*)) source dest) 316 | (type fixnum width)) 317 | (flet ((copy-row (i j) 318 | (let ((s1 (* i width)) 319 | (s2 (* j width))) 320 | (replace dest source 321 | :start1 s2 :end1 (+ s2 width) 322 | :start2 s1)))) 323 | (let ((j -1)) 324 | (macrolet ((pass (start step) 325 | `(loop for i from ,start below height by ,step 326 | do (copy-row (incf j) i)))) 327 | (pass 0 8) 328 | (pass 4 8) 329 | (pass 2 4) 330 | (pass 1 2)) 331 | dest)))) 332 | 333 | (defun interlaced-image-data (canvas) 334 | (let* ((source (image-data canvas)) 335 | (dest (copy-seq source)) 336 | (width (width canvas)) 337 | (height (height canvas))) 338 | (declare (type (simple-array octet (*)) source dest) 339 | (type fixnum width)) 340 | (flet ((copy-row (i j) 341 | (let ((s1 (* i width)) 342 | (s2 (* j width))) 343 | (replace dest source 344 | :start1 s2 :end1 (+ s2 width) 345 | :start2 s1)))) 346 | (let ((j -1)) 347 | (macrolet ((pass (start step) 348 | `(loop for i from ,start below height by ,step 349 | do (copy-row i (incf j))))) 350 | (pass 0 8) 351 | (pass 4 8) 352 | (pass 2 4) 353 | (pass 1 2)) 354 | dest)))) 355 | -------------------------------------------------------------------------------- /color-table.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials 13 | ;;; provided with the distribution. 14 | ;;; 15 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 16 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 18 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 19 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 20 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 21 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 22 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 23 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 24 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 25 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | ;;; 27 | ;;;; $Id: color-table.lisp,v 1.7 2007/01/05 15:04:11 xach Exp $ 28 | 29 | (in-package #:skippy) 30 | 31 | (deftype color-table-entry () 32 | '(unsigned-byte 24)) 33 | 34 | (defconstant +max-color-table-size+ 35 | 256 36 | "Color tables are restricted by the GIF89a specification to 256 entries.") 37 | 38 | (defun rgb-color (r g b) 39 | (logand #xFFFFFF 40 | (logior (ash (logand #xFF r) 16) 41 | (ash (logand #xFF g) 8) 42 | (ash (logand #xFF b) 0)))) 43 | 44 | (defun color-rgb (color) 45 | (values (ldb (byte 8 16) color) 46 | (ldb (byte 8 8) color) 47 | (ldb (byte 8 0) color))) 48 | 49 | (defclass color-table () 50 | ((entries 51 | :initform (make-array 4 52 | :adjustable t 53 | :element-type 'color-table-entry 54 | :initial-element 0 55 | :fill-pointer 0) 56 | :reader entries))) 57 | 58 | (defmethod print-object ((object color-table) stream) 59 | (print-unreadable-object (object stream :identity t :type t) 60 | (format stream "with ~D entries" (length (entries object))))) 61 | 62 | (defun add-color (color table) 63 | (let ((entries (entries table))) 64 | (if (= (length entries) +max-color-table-size+) 65 | (error 'color-table-full 66 | :color-table table) 67 | (vector-push-extend color entries)))) 68 | 69 | (defun find-color (color table) 70 | (position color (entries table))) 71 | 72 | (defun ensure-color (color table) 73 | (or (find-color color table) 74 | (add-color color table))) 75 | 76 | (defun make-color-table (&key initial-contents) 77 | (let ((table (make-instance 'color-table))) 78 | (dolist (color initial-contents table) 79 | (add-color color table)))) 80 | 81 | (defun color-table-size (table) 82 | (length (entries table))) 83 | 84 | (defun color-table-entry (table index) 85 | (aref (entries table) index)) 86 | 87 | (defun (setf color-table-entry) (new-color table index) 88 | (setf (aref (entries table) index) new-color)) 89 | 90 | (defun color-table-code-size (table) 91 | "The number of bits needed to store the largest index in the color 92 | table. The spec-imposed minimum is 2." 93 | (if table 94 | (max 2 (integer-length (1- (length (entries table))))) 95 | 2)) 96 | 97 | (defun copy-color-table (table) 98 | (let ((new-table (make-color-table))) 99 | (loop for color across (entries table) 100 | do (add-color color new-table)) 101 | new-table)) 102 | -------------------------------------------------------------------------------- /conditions.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials 13 | ;;; provided with the distribution. 14 | ;;; 15 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 16 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 18 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 19 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 20 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 21 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 22 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 23 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 24 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 25 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | ;;; 27 | ;;;; $Id: conditions.lisp,v 1.2 2007/01/04 01:30:40 xach Exp $ 28 | 29 | (in-package #:skippy) 30 | 31 | (define-condition skippy-warning (simple-warning) ()) 32 | 33 | (define-condition skippy-error (error) ()) 34 | 35 | (defun skippy-warn (control &rest args) 36 | (warn 'skippy-warning 37 | :format-control control 38 | :format-arguments args)) 39 | 40 | (define-condition lzw-error (skippy-error) 41 | ((description 42 | :initarg :description 43 | :reader lzw-error-description)) 44 | (:report 45 | (lambda (condition stream) 46 | (write-string (lzw-error-description condition) stream)))) 47 | 48 | (define-condition unexpected-value (skippy-error) 49 | ((description 50 | :initarg :description 51 | :reader unexpected-value-description 52 | :initform nil) 53 | (actual-value 54 | :initarg :actual-value 55 | :reader unexpected-value-actual-value) 56 | (expected-value 57 | :initarg :expected-value 58 | :initform nil 59 | :reader unexpected-value-expected-value) 60 | (source 61 | :initarg :source 62 | :initform nil 63 | :reader unexpected-value-source) 64 | (source-position 65 | :initarg :source-position 66 | :initform nil 67 | :reader unexpected-value-source-position)) 68 | (:report 69 | (lambda (condition stream) 70 | (format stream "Unexpected~@[ ~A~] value ~A~@[ at position ~D~]~ 71 | ~@[ in ~A~]~@[ (expected ~A) ~]" 72 | (unexpected-value-description condition) 73 | (unexpected-value-actual-value condition) 74 | (unexpected-value-source-position condition) 75 | (unexpected-value-source condition) 76 | (unexpected-value-expected-value condition))))) 77 | 78 | (define-condition missing-color-table (skippy-error) 79 | ((image 80 | :initarg :image 81 | :reader missing-color-table-image)) 82 | (:report 83 | (lambda (condition stream) 84 | (format stream "No local or global color table available for ~A" 85 | (missing-color-table-image condition))))) 86 | 87 | (define-condition signature-error (skippy-error) 88 | ((source 89 | :initarg :source 90 | :reader signature-error-source) 91 | (position 92 | :initarg :position 93 | :initform nil 94 | :reader signature-error-position))) 95 | 96 | (define-condition short-signature (signature-error) 97 | () 98 | (:report 99 | (lambda (condition stream) 100 | (format stream "Missing signature~@[ at position ~D~] in ~A" 101 | (signature-error-position condition) 102 | (signature-error-source condition))))) 103 | 104 | (define-condition signature-mismatch (signature-error) 105 | () 106 | (:report 107 | (lambda (condition stream) 108 | (format stream "Signature mismatch~@[ at position ~D~] in ~A" 109 | (signature-error-position condition) 110 | (signature-error-source condition))))) 111 | 112 | (define-condition color-table-full (skippy-error) 113 | ((color-table 114 | :initarg :color-table 115 | :reader color-table-full-color-table)) 116 | (:report 117 | (lambda (condition stream) 118 | (format stream "Color table ~A is full (256 entries)" 119 | (color-table-full-color-table condition))))) 120 | 121 | (define-condition invalid-image-dimensions (skippy-error) 122 | ((width 123 | :initarg :width 124 | :reader invalid-image-dimension-width) 125 | (height 126 | :initarg :height 127 | :reader invalid-image-dimension-height)) 128 | (:report 129 | (lambda (condition stream) 130 | (format stream "Invalid image dimensions ~Ax~A - each dimensions must ~ 131 | be (< 0 dimension 65536)" 132 | (invalid-image-dimension-width condition) 133 | (invalid-image-dimension-height condition))))) 134 | 135 | -------------------------------------------------------------------------------- /data-stream.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials 13 | ;;; provided with the distribution. 14 | ;;; 15 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 16 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 18 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 19 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 20 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 21 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 22 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 23 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 24 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 25 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | ;;; 27 | ;;;; $Id: data-stream.lisp,v 1.11 2007/01/03 22:01:59 xach Exp $ 28 | 29 | (in-package #:skippy) 30 | 31 | (defclass data-stream () 32 | ((height 33 | :initarg :height 34 | :reader height 35 | :documentation "The height of the logical screen") 36 | (width 37 | :initarg :width 38 | :reader width 39 | :documentation "The width of the logical screen") 40 | (color-table 41 | :initarg :color-table 42 | :accessor color-table 43 | :documentation "The global color table for the data stream (optional)") 44 | (loopingp 45 | :initarg :loopingp 46 | :accessor loopingp) 47 | (comment 48 | :initarg :comment 49 | :accessor comment) 50 | (images 51 | :initarg :images 52 | :reader images 53 | :documentation "A vector of the images in the data stream")) 54 | (:default-initargs 55 | :height (error "~A initarg is required" :height) 56 | :width (error "~A initarg is required" :width) 57 | :color-table nil 58 | :loopingp nil 59 | :comment nil 60 | :images (make-array 10 :adjustable t :fill-pointer 0)) 61 | (:documentation 62 | "A DATA-STREAM instance represents a container for GIF image 63 | data. It defines the logical dimensions of the overall image. It may 64 | contain a color table, which is used if an individual image does not 65 | provide its own color table.")) 66 | 67 | (defmethod initialize-instance :after ((data-stream data-stream) 68 | &key color-table 69 | &allow-other-keys) 70 | (when (eql color-table t) 71 | (setf (color-table data-stream) (make-color-table)))) 72 | 73 | (defmethod print-object ((object data-stream) stream) 74 | (print-unreadable-object (object stream :type t :identity t) 75 | (format stream "geometry ~Dx~D, ~D image~:*~P" 76 | (width object) 77 | (height object) 78 | (length (images object))))) 79 | 80 | (defun last-image (data-stream) 81 | (let* ((images (images data-stream)) 82 | (i (fill-pointer images))) 83 | (unless (zerop i) 84 | (aref images (1- i))))) 85 | 86 | (defun add-delay (delay data-stream) 87 | (let ((image (last-image data-stream))) 88 | (when image 89 | (incf (delay-time image) delay)))) 90 | 91 | (defun check-dimensions (data-stream image) 92 | (when (or (< (height data-stream) (height image)) 93 | (< (width data-stream) (width image))) 94 | (skippy-warn "Image ~A is larger than its containing data stream ~A, ~ 95 | output may not display properly" 96 | image data-stream))) 97 | 98 | (defun add-image (image data-stream) 99 | (setf (data-stream image) data-stream) 100 | (check-dimensions data-stream image) 101 | (vector-push-extend image (images data-stream))) 102 | 103 | 104 | (defun make-data-stream (&key height width color-table loopingp comment 105 | initial-images) 106 | (let ((data-stream (make-instance 'data-stream 107 | :height height 108 | :width width 109 | :color-table color-table 110 | :loopingp loopingp 111 | :comment comment))) 112 | (dolist (image initial-images data-stream) 113 | (add-image image data-stream)))) 114 | -------------------------------------------------------------------------------- /doc/example1.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xach/skippy/e456210202ca702c792292c5060a264d45e47090/doc/example1.gif -------------------------------------------------------------------------------- /doc/example2.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xach/skippy/e456210202ca702c792292c5060a264d45e47090/doc/example2.gif -------------------------------------------------------------------------------- /doc/example3.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xach/skippy/e456210202ca702c792292c5060a264d45e47090/doc/example3.gif -------------------------------------------------------------------------------- /doc/index.html: -------------------------------------------------------------------------------- 1 | 2 | SKIPPY - Read and write GIF files with Common Lisp 3 | 20 | 21 | 22 | 23 |
24 | 25 | 26 |

SKIPPY - Read and write GIF files with Common Lisp

27 | 28 |
29 |

Abstract

30 | 31 |

GIF is a widely-supported indexed color image file format. SKIPPY 32 | is a Common Lisp library that supports reading GIF87a and GIF89a files 33 | and writing GIF89a files. SKIPPY supports images with animations, 34 | transparency, comments, and other GIF features. SKIPPY is written 35 | fully in Common Lisp and does not use an external library to read or 36 | write image files. It is available under a BSD-like license. 37 | 38 | The latest version is 1.3.12, released on March 12th, 2015. 39 | 40 |

The canonical location for SKIPPY 41 | is http://www.xach.com/lisp/skippy/. Development 42 | is on github. 43 | 44 |

SKIPPY is used by wigflip. 45 | 46 |

Download shortcut: 47 | http://www.xach.com/lisp/skippy.tgz 49 | 50 | 51 | 52 |

53 | 54 | 55 |

Contents

56 | 57 |
    58 |
  1. Limitations 59 |
  2. Concepts 60 |
  3. Examples 61 |
  4. Dictionary 62 | 63 | 149 | 150 |
  5. Feedback 151 | 152 |
153 | 154 | 155 |

Limitations

 156 | 157 |

158 | 159 |

168 | 169 |

Alternatives: 170 | 171 |

190 | 191 |

Concepts

 192 | 193 |

A GIF89a file consists of a data stream which contains zero 194 | or more 195 | images (although zero images wouldn't be very useful). In 196 | addition to images, the data stream contains metadata such as the 197 | logical dimensions of the overall image and an optional global color 198 | table. Images contain the actual raster data that is displayed in a 199 | graphics viewer, and may also be associated with metadata such as a 200 | transparent color index, a local color table, and animation control 201 | information. 202 | 203 |

For more information about the GIF89a file format, see the GIF89a 205 | Specification. 206 | 207 |

Creating a GIF file with SKIPPY is a three-part process: 208 | 209 |

    210 |
  1. Create a data stream 211 |
  2. Add zero or more images to the data stream 212 |
  3. Write the data stream out to a file 213 |
214 | 215 | 216 |

Examples

 217 | 218 | 
219 | ;;; Create an image filled with horizontal red stripes
221 | 
222 | (use-package '#:skippy)
223 | 
224 | (defun example1 ()
225 |   (let* ((height 100)
226 |          (width 100)
227 |          (data-stream (make-data-stream :height height
228 |                                         :width width
229 |                                         :color-table t))
230 |          (image (make-image :height height :width width))
231 |          (red (ensure-color (rgb-color #xFF #x00 #x00)
232 |                             (color-table data-stream)))
233 |          (white (ensure-color (rgb-color #xFF #xFF #xFF)
234 |                               (color-table data-stream))))
235 |     (add-image image data-stream)
236 |     (fill (image-data image) white)
237 |     (dotimes (i (truncate height 2))
238 |       (let* ((start (* i width 2))
239 |              (end (+ start width)))
240 |         (fill (image-data image) red :start start :end end)))
241 |     (output-data-stream data-stream #p"example1.gif")))
242 |
243 | 244 | 

245 | ;;; Make a small "sprite" move across an image
247 | 
248 | (use-package '#:skippy)
249 | 
250 | (defun example2 ()
251 |   (let* ((height 9)
252 |          (width 99)
253 |          (color-table (make-color-table))
254 |          (data-stream (make-data-stream :height height
255 |                                         :width width
256 |                                         :color-table color-table))
257 |          (gray (ensure-color #xCCCCCC color-table))
258 |          (white (ensure-color #xFFFFFF color-table))
259 |          (black (ensure-color #x000000 color-table))
260 |          (bg (make-image :data-stream data-stream
261 |                          :width width :height height
262 |                          :image-data (make-image-data height width
263 |                                                       :initial-element gray)))
264 |          (sprite-data (make-image-data 3 3)))
265 |     (flet ((hatch-data (data color1 color2)
266 |              (dotimes (i (length data))
267 |                (setf (aref data i) (if (zerop (mod i 2)) color1 color2)))))
268 |       (hatch-data sprite-data white black)
269 |       (hatch-data (image-data bg) white gray)
270 |       (dotimes (i 96)
271 |         (let ((image (make-image :height 3
272 |                                  :width 3
273 |                                  :image-data sprite-data
274 |                                  :delay-time 10
275 |                                  :disposal-method :restore-previous
276 |                                  :transparency-index white
277 |                                  :top-position 3
278 |                                  :left-position i)))
279 |           (add-image image data-stream)))
280 |       (setf (loopingp data-stream) t)
281 |       (output-data-stream data-stream #p"example2.gif"))))
282 |
283 | 284 | 

285 | ;;; Overlapping rectangles of random colors
287 | 
288 | (use-package '#:skippy)
289 | 
290 | (defun example3 ()
291 |   (let* ((height 100)
292 |          (width 100)
293 |          (color-count 256)
294 |          (color-table (make-color-table))
295 |          (data-stream (make-data-stream :color-table color-table
296 |                                         :loopingp t
297 |                                         :height height
298 |                                         :width width)))
299 |     (dotimes (i color-count)
300 |       (add-color (rgb-color (random 256) (random 256) (random 256))
301 |                  color-table))
302 |     (dotimes (i color-count)
303 |       (let* ((top (random height))
304 |              (left (random width))
305 |              (h (1+ (random (- height top))))
306 |              (w (1+ (random (- width left))))
307 |              (image (make-image :height h
308 |                                 :width w
309 |                                 :data-stream data-stream
310 |                                 :top-position top
311 |                                 :left-position left
312 |                                 :image-data (make-image-data w h
313 |                                                              :initial-element (random color-count))
314 |                                 :delay-time 5)))
315 |         (add-image image data-stream)))
316 |     (output-data-stream data-stream #p"example3.gif")))
317 |
318 | 319 | 320 |

Dictionary

 321 | 322 |

The following symbols are exported from the SKIPPY 323 | package. 324 | 325 | 326 | 327 | 328 |

Color Tables

329 | 330 |

Color tables are used to store a mapping between a small (<256) 331 | numerical index and the actual the color used when displaying an 332 | image. There may be one global color table stored in the data 333 | stream. Each image may also have its own local color table. If an 334 | image does not have a local color table, the global color table must 335 | be present for the GIF file to be written. 336 | 337 |

In SKIPPY, colors are designated by 24-bit unsigned integers. The 338 | top 8 bits represent the red component, the middle 8 bits represent 339 | the blue component, and the bottom 8 bits represent the green 340 | component. For example, interpreted as a color, the Lisp literal 341 | #xFFFFFF has a red component of #xFF or 255, a green 343 | component of #xFF, and a blue component of #xFF. Together, these three 344 | components make white. 345 | 346 |

The function RGB-COLOR makes it 347 | easy to construct colors from their individual components. 348 | 349 | 350 |

[Function]
351 | rgb-color red green blue => color 352 | 353 |

354 | Returns a 24-bit number representing the color with the numeric color 355 | components red, green, and blue. 356 |
357 | 358 |

[Function]
359 | color-rgb color => red, green, blue 360 | 361 |

362 | Returns the RGB color components of color as multiple values 363 |
364 | 365 | 366 | 367 |

[Function]
368 | make-color-table &key initial-contents 369 | => color-table 370 | 371 |

372 | Creates and returns a new color table. The colors in the list 373 | initial-contents, if any, are added to the table in order as if 374 | with ADD-COLOR. 375 |
376 | 377 | 378 |

[Function]
379 | add-color color color-table => index 380 | 381 |

382 | Adds color to color-table and returns the new color's 383 | index. Indexes start at 0 and increase sequentially. If the color 384 | table already has the maximum number of entries (256), an error is 385 | signaled. 386 |
387 | 388 |

[Function]
389 | find-color color color-table => index 390 | 391 |

392 | If color is present in color-table, returns its index, 393 | otherwise returns nil. 394 |
395 | 396 | 397 |

[Function]
398 | ensure-color color color-table => index 399 | 400 |

401 | If color is present in color-table, returns its existing 402 | index, otherwise adds color and returns the new 403 | index. Essentially a combination of FIND-COLOR and, if necessary, ADD-COLOR. 406 |
407 | 408 |

[Function]
409 | color-table-size color-table => size 410 | 411 |

412 | Returns the number of entries in color-table. 413 |
414 | 415 | 416 |

[Accessor]
417 | color-table-entry color-table index => 418 | color
419 | (setf (color-table-entry color-table index) 420 | color) => color 421 | 422 |

423 | Gets or sets the color at index in color-table. 424 |
425 | 426 | 427 |

[Function]
428 | copy-color-table color-table => new-color-table 429 | 430 |

431 | Returns a copy of color-table. 432 |
433 | 434 | 435 |

Data Streams

 436 | 437 |

Data streams are the containers for images and other metadata. 438 | 439 |

The height and width of the data stream should be as large as or 440 | larger than the height and width of any image it contains; some 441 | software will not display the resulting images otherwise. 442 | 443 |

[Function]
444 | make-data-stream &key 445 | height width 446 | color-table loopingp 447 | comment initial-images 448 | => data-stream 449 | 450 |

451 | Creates and returns a new data stream object. 452 | 453 |

height and width are required and represent the 454 | logical dimensions of the displayed image. 455 | 456 |

color-table represents the global color table, and may be one 457 | of: NIL, meaning that there is no global color table; T, 458 | designating an automatically created new color table; or an existing 459 | color table object. 460 | 461 |

If loopingp is non-NIL, the frames in the image will 462 | redisplay from the beginning after reaching the end. 463 | 464 |

If comment is non-NIL, it should be a string to be used as 465 | an embedded comment in the output file. 466 | 467 |

All images in the list initial-images are added to the new 468 | data stream as if with ADD-IMAGE. 469 | 470 |

471 | 472 | 473 |

[Function]
474 | add-image image data-stream => | 475 | 476 |

477 | Adds image to data-stream. 478 |
479 | 480 | 481 |

[Function]
482 | output-data-stream data-stream file 483 | &key (if-exists :supersede) => 484 | pathname 485 | 486 |

487 | Writes data-stream in GIF89a format to file and returns 488 | the truename of 489 | file. if-exists may be any of the values accepted by the :IF-EXISTS argument to CL:OPEN. 490 | 491 |
492 | 493 | 494 |

[Function]
495 | write-data-stream data-stream stream => | 496 | 497 |

498 | Writes data-stream in GIF89a format to stream and 499 | returns no value. The stream should accept 500 | (UNSIGNED-BYTE 8) data via CL:WRITE-BYTE and 501 | CL:WRITE-SEQUENCE. 502 |
503 | 504 | 505 |

[Function]
506 | load-data-stream file => data-stream 507 | 508 |

509 | 510 | Reads GIF data from file and returns a SKIPPY data stream 511 | object. Some caveats apply: 512 | 513 |
    514 | 515 |
  • If multiple comments are present in the file, only the last 516 | comment is saved in the resulting data stream 517 | 518 |
  • All GIF Plain Text Extension blocks are silently ignored 519 | (however, no software actually supports the Plain Text Extension 520 | anyway) 521 | 522 |
523 | 524 |

525 | 526 |

527 | 528 | 529 |

[Function]
530 | read-data-stream stream => data-stream 531 | 532 |

533 | Reads a GIF89a or GIF87a data stream from stream and returns it 534 | as a SKIPPY data stream object. The stream should be compatible with 535 | reading (UNSIGNED-BYTE 8) data via CL:READ-BYTE 536 | and CL:READ-SEQUENCE. 537 |
538 | 539 | 540 |

[Function]
541 | images data-stream => image-vector 542 | 543 |

544 | Returns a vector containing the images present in data-stream. 545 |
546 | 547 | 548 |

[Functions]
549 | width data-stream => width
550 | height data-stream => height 551 | 552 | 553 |

554 | Returns the width and height of data-stream, respectively. 555 |
556 | 557 | 558 |

[Accessors]
559 | color-table data-stream => color-table
560 | loopingp data-stream => boolean
561 | comment data-stream => string 562 | 563 |

564 | Accessors; get or set the respective properties of 565 | data-stream. See MAKE-DATA-STREAM for more 567 | details. 568 | 569 |
570 | 571 | 572 |

[Function]
573 | last-image data-stream => image 574 | 575 |

576 | Returns the last image of data-stream, or NIL if the data 577 | stream does not have any images. 578 |
579 | 580 | 581 |

[Function]
582 | add-delay delay data-stream => new-delay 583 | 584 |

585 | Increments the DELAY-TIME of the 586 | last image in data-stream by delay hundredths of a 587 | second, and returns the new value. 588 | 589 |

This has the effect of adding a pause to the current point in the 590 | animation. 591 | 592 |

If there are no images in data-stream, returns NIL and has 593 | no effect. 594 | 595 |

596 | 597 | 598 |

Images

 599 | 600 |

Images contain the actual raster data that is displayed when 601 | viewing a GIF. If there is more than one image in a data stream, they 602 | are displayed in sequence as an animation. 603 | 604 |

Images may be smaller than the logical dimensions of the data 605 | stream. They may also be placed at arbitrary offsets from the top and 606 | left of the logical screen. 607 | 608 |

Image data is stored as a one-dimensional vector of color table 609 | indexes. The first element in the vector corresponds to the upper-left 610 | corner of the image, and the last element in the vector corresponds to 611 | the lower-right corner of the image. The canvas 612 | functions make it easier to treat an image as a two-dimensional 613 | array of pixels. 614 | 615 | 616 |

[Special variable]
617 | *default-delay-time* => 100 618 | 619 |

620 | The default value for the DELAY-TIME of an image, in 622 | hundredths of a second. The initial value is 100. 623 |
624 | 625 | 626 |

[Function]
627 | make-image &key 628 | height width 629 | image-data 630 | data-stream 631 | top-position left-position 632 | color-table 633 | interlacedp 634 | delay-time 635 | transparency-index 636 | disposal-method => image 637 | 638 |

639 | Creates and returns a new image object. 640 | 641 |

height and width represent the dimensions of the 642 | image. 643 | 644 |

image-data, if supplied, should be a vector with (* 645 | width height) elements of type (unsigned-byte 8). If 646 | image-data is not supplied, a new vector of the appropriate 647 | size and type is created for the image automatically. 648 | 649 |

data-stream, if supplied, is the data stream which contains 650 | the image. 651 | 652 |

top-position and left-position, if supplied, are the 653 | offsets from the top and left of the logical screen at which this 654 | image is displayed. If not provided, a default of 0 is used. 655 | 656 |

color-table represents the local color table, and may be one 657 | of: NIL, meaning that there is no local color table; T, 658 | designating an automatically created new color table; or an existing 659 | color table object. 660 | 661 |

If interlacedp is non-NIL, the image data will be written 662 | out with the rows interlaced. See Appendix E of the GIF89a 664 | specification for more information. 665 | 666 |

delay-time is the time, in hundredths of a second, to 667 | display this image before displaying the next image in the data 668 | stream. If not provided, the value of *DEFAULT-DELAY-TIME* is used. 670 | 671 |

If specified, the color at transparency-index will not be 672 | displayed if it is present in the image raster data; instead, any 673 | pixel with that index will be transparent. 674 | 675 |

disposal-method is the way the image is updated when the 676 | next image in the data stream is to be displayed. Possible values are: 677 | 678 |

    679 | 680 |
  • :UNSPECIFIED - Do not erase the image from the display 681 | when displaying the next frame. This is the default value if 682 | disposal-method is not supplied. 683 | 684 |
  • :NONE - Do not erase the image. 685 | 686 |
  • :RESTORE-BACKGROUND - The image is removed and the 687 | background is made visible. 688 | 689 |
  • :RESTORE-PREVIOUS - The image is removed and the 690 | previous state of the logical image is restored. 691 | 692 |
693 | 694 |
695 | 696 | 697 |

[Functions]
698 | width image => width
699 | height image => height 700 | 701 | 702 |

703 | Returns the width and height of image, respectively. 704 |
705 | 706 | 707 |

[Accessors]
708 | image-data image => image-data
709 | top-position image => top-position
710 | left-position image => left-position
711 | color-table image => color-table
712 | interlacedp image => boolean
713 | disposal-method image => disposal-method
714 | delay-time image => delay-time
715 | transparency-index image => index 716 | 717 |

718 | Accessors; get or set the respective properties of image. See 719 | MAKE-IMAGE for more details. 720 |
721 | 722 | 723 |

[Function]
724 | make-image-data width height 725 | &key (initial-element 0) initial-contents 726 | => image-data 727 | 728 |

729 | Returns a vector suitable for use as an image's image-data. 730 |
731 | 732 | 733 |

Canvases

 734 | 735 |

Canvases are similar to images, but they do not have GIF-specific 736 | metadata. They contain only information about their dimensions and a 737 | vector of raster data. 738 | 739 |

Most functions that operate on canvases also operate on images. 740 | 741 | 742 |

[Function]
743 | make-canvas &key height width 744 | image-data => canvas 745 | 746 |

747 | Creates and returns a new canvas object. 748 | 749 |

height and width are required. 750 | 751 |

image-data, if supplied, should be a vector with (* 752 | width height) elements of type (unsigned-byte 8). If 753 | image-data is not supplied, a new vector of the appropriate 754 | size and type is created for the canvas automatically. 755 |

756 | 757 |

[Functions]
758 | width canvas => width
759 | height canvas => height 760 | 761 |

762 | Returns the width and height of canvas, respectively. 763 |
764 | 765 |

[Accessor]
766 | pixel-ref canvas x y => index
767 | (setf (pixel-ref canvas x y) index) => index 768 | 769 |

770 | Gets or sets the color table index at position x,y in 771 | canvas. 772 |
773 | 774 |

[Function]
775 | canvas-image canvas => image 776 | 777 |

778 | Creates an image object that has the same dimensions as canvas 779 | and which shares the canvas's image-data. That is, any updates 780 | to the image-data of image or canvas will operate on the 781 | same data. 782 |
783 | 784 | 785 |

[Function]
786 | composite source dest 787 | &key 788 | (sx 0) (sy 0) 789 | (dx 0) (dy 0) 790 | width height => 791 | 792 |

793 | Copies the region of source starting at position 794 | sx,sy to dest at position dx,dy. 795 | 796 |

If width and height are given, they place a bounds on 797 | the total size of the copied region. They default to the width and 798 | height of the source image. 799 | 800 |

Compositing will do the necessary clipping to ensure that the right 801 | portion of source ends up in dest. This includes 802 | compositing into negative destination positions and from negative 803 | source positions. 804 |

805 | 806 | 807 |

[Function]
808 | fill-canvas canvas index => 809 | 810 |

811 | Fills the entire area of canvas with the color index 812 | index. 813 |
814 | 815 |

[Function]
816 | clone canvas => new-canvas 817 | 818 |

819 | Creates a copy of canvas with the same dimensions and a copy of 820 | the image data. 821 |
822 | 823 | 824 |

[Function]
825 | rotate-180 canvas => canvas 826 | 827 |

828 | Destructively performs a 180-degree rotation of the image data of 829 | canvas. 830 |
831 | 832 | 833 |

[Function]
834 | flip-horizontal canvas => canvas 835 | 836 |

837 | Destructively horizontally mirrors the image data of canvas. 838 |
839 | 840 | 841 |

[Function]
842 | flip-vertical canvas => canvas 843 | 844 |

845 | Destructively vertically mirrors the image data of canvas. 846 |
847 | 848 | 849 |

[Function]
850 | scale canvas scale-factor => new-canvas 851 | 852 |

853 | Scales canvas by the integer scale-factor and returns 854 | the result as a new canvas. 855 | 856 |

Does not work on image objects. 857 |

858 | 859 | 860 |

[Function]
861 | fill-area canvas index 862 | &key 863 | (x 0) (y 0) 864 | width height => 865 | 866 |

867 | Fills an area of canvas starting at position 868 | x,y. 869 |
870 | 871 | 872 |

Warnings and Conditions

 873 | 874 |

[Condition type]
875 | skippy-warning 876 | 877 |

878 | This condition type is a subtype of CL:WARNING. All warnings 879 | signaled by Skippy are a subtype of this type. 880 |
881 | 882 | 883 |

[Condition type]
884 | skippy-error 885 | 886 |

887 | This condition type is a subtype of CL:ERROR. All errors 888 | signaled by Skippy are a subtype of this type. 889 |
890 | 891 | 892 |

[Condition type]
893 | lzw-error 894 | 895 |

896 | An error of this type is signaled from LOAD-DATA-STREAM or READ-DATA-STREAM when the LZW data is 899 | corrupted in some way. 900 |
901 | 902 | 903 |

[Condition type]
904 | unexpected-value 905 | 906 |

907 | An error of this type is signaled from LOAD-DATA-STREAM or READ-DATA-STREAM when an 910 | unexpected value is encountered. 911 |
912 | 913 | 914 |

[Condition type]
915 | missing-color-table 916 | 917 |

918 | An error of this type is signaled from OUTPUT-DATA-STREAM or WRITE-DATA-STREAM when an image 921 | being compressed has neither a local color table nor a global color table. 922 |
923 | 924 |

[Condition type]
925 | color-table-full 926 | 927 |

928 | An error of this type is signaled from ADD-COLOR or ENSURE-COLOR when a new color must be added 931 | but the color table already has the maximum number of entries (256). 932 |
933 | 934 | 935 |

[Condition type]
936 | signature-error 937 | 938 |

939 | All GIF files start with the ASCII strings "GIF87a" or "GIF89a". An 940 | error of type signature-error is signaled from LOAD-DATA-STREAM or READ-DATA-STREAM when no 943 | signature is present or the octets in the input stream do not match 944 | either signature. 945 | 946 |
947 | 948 | 949 | 950 |

Feedback

 951 | 952 | 953 |

Please send bug reports, patches, questions, and any other feedback 954 | to Zachary Beane. 955 | 956 |

Thanks to Eric Marsden for finding and sharing unsupported, bogus, 957 | and corrupted GIFs so I could make Skippy handle them. 958 | 959 |

Thanks to Martin Rydström and Ignas Mikalajunas for reviewing 960 | this documentation and offering helpful advice. 961 | 962 |

963 | -------------------------------------------------------------------------------- /example.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials 13 | ;;; provided with the distribution. 14 | ;;; 15 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 16 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 18 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 19 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 20 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 21 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 22 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 23 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 24 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 25 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | ;;; 27 | ;;;; $Id: example.lisp,v 1.7 2006/12/11 15:49:17 xach Exp $ 28 | 29 | (defpackage #:skippy-example 30 | (:use #:cl #:skippy) 31 | (:export #:example1 #:example2 #:example3)) 32 | 33 | (in-package #:skippy-example) 34 | 35 | (defun example1 () 36 | (let* ((height 100) 37 | (width 100) 38 | (data-stream (make-data-stream :height height 39 | :width width 40 | :color-table t)) 41 | (image (make-image :height height :width width)) 42 | (red (ensure-color (rgb-color #xFF #x00 #x00) 43 | (color-table data-stream))) 44 | (white (ensure-color (rgb-color #xFF #xFF #xFF) 45 | (color-table data-stream)))) 46 | (add-image image data-stream) 47 | (fill (image-data image) white) 48 | (dotimes (i (truncate height 2)) 49 | (let* ((start (* i width 2)) 50 | (end (+ start width))) 51 | (fill (image-data image) red :start start :end end))) 52 | (output-data-stream data-stream #p"example1.gif"))) 53 | 54 | (defun example2 () 55 | (let* ((height 9) 56 | (width 99) 57 | (color-table (make-color-table)) 58 | (data-stream (make-data-stream :height height 59 | :width width 60 | :color-table color-table)) 61 | (gray (ensure-color #xCCCCCC color-table)) 62 | (white (ensure-color #xFFFFFF color-table)) 63 | (black (ensure-color #x000000 color-table)) 64 | (bg (make-image :data-stream data-stream 65 | :width width :height height 66 | :image-data (make-image-data height width 67 | :initial-element gray))) 68 | (sprite-data (make-image-data 3 3))) 69 | (flet ((hatch-data (data a b) 70 | (dotimes (i (length data)) 71 | (setf (aref data i) (if (zerop (mod i 2)) a b))))) 72 | (hatch-data sprite-data white black) 73 | (hatch-data (image-data bg) white gray) 74 | (dotimes (i 128) 75 | (add-color (random #xFFFFF) color-table)) 76 | (dotimes (i 96) 77 | (let ((image (make-image :height 3 78 | :width 3 79 | :image-data sprite-data 80 | :top-position 3 81 | :delay-time 10 82 | :disposal-method :restore-previous 83 | :transparency-index white 84 | :left-position i))) 85 | (add-image image data-stream))) 86 | (setf (loopingp data-stream) t) 87 | (output-data-stream data-stream #p"example2.gif")))) 88 | 89 | (defun example3 () 90 | (let* ((height 100) 91 | (width 100) 92 | (color-count 256) 93 | (color-table (make-color-table)) 94 | (data-stream (make-data-stream :color-table color-table 95 | :loopingp t 96 | :height height 97 | :width width))) 98 | (dotimes (i color-count) 99 | (add-color (rgb-color (random 256) (random 256) (random 256)) 100 | color-table)) 101 | (dotimes (i color-count) 102 | (let* ((top (random height)) 103 | (left (random width)) 104 | (h (1+ (random (- height top)))) 105 | (w (1+ (random (- width left)))) 106 | (image (make-image :height h 107 | :width w 108 | :data-stream data-stream 109 | :top-position top 110 | :left-position left 111 | :image-data (make-image-data w h 112 | :initial-element (random color-count)) 113 | :delay-time 5))) 114 | (add-image image data-stream))) 115 | (output-data-stream data-stream #p"example3.gif"))) 116 | -------------------------------------------------------------------------------- /gif89a.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials 13 | ;;; provided with the distribution. 14 | ;;; 15 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 16 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 18 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 19 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 20 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 21 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 22 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 23 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 24 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 25 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | ;;; 27 | ;;;; $Id: gif89a.lisp,v 1.19 2007/06/26 20:54:24 xach Exp $ 28 | 29 | (in-package #:skippy) 30 | 31 | (defvar *gif-signature* 32 | (make-array 6 33 | :element-type '(unsigned-byte 8) 34 | :initial-contents '(71 73 70 56 57 97)) 35 | "The ASCII codes for the characters of the string \"GIF89a\".") 36 | 37 | (defvar *netscape-signature* 38 | (make-array 11 39 | :element-type '(unsigned-byte 8) 40 | :initial-contents '(78 69 84 83 67 65 80 69 50 46 48)) 41 | "The ASCII codes for the characters of the string \"NETSCAPE2.0\".") 42 | 43 | (defvar *disposal-methods* 44 | '((:unspecified . 0) 45 | (:none . 1) 46 | (:restore-background . 2) 47 | (:restore-previous . 3))) 48 | 49 | (defconstant +pixel-aspect-ratio+ 0 50 | "Pixel aspect ratios are not set.") 51 | 52 | (defconstant +image-separator-code+ #x2C) 53 | 54 | (defconstant +gif-trailer-code+ #x3B 55 | "The end-of-GIF marker.") 56 | 57 | 58 | (defun write-uint16 (number stream) 59 | (write-byte (logand #xFF number) stream) 60 | (write-byte (ash number -8) stream)) 61 | 62 | (defun write-block-terminator (stream) 63 | (write-byte 0 stream)) 64 | 65 | (defun boolean-bit (value) 66 | (if value 1 0)) 67 | 68 | ;;; Spec from http://members.aol.com/royalef/gifabout.htm 69 | (defun write-netscape-looping-block (stream) 70 | (write-byte #x21 stream) 71 | (write-byte #xFF stream) 72 | (write-byte (length *netscape-signature*) stream) 73 | (write-sequence *netscape-signature* stream) 74 | (write-byte 3 stream) 75 | (write-byte 1 stream) 76 | (write-uint16 #xFFFF stream) 77 | (write-byte 0 stream)) 78 | 79 | (defun write-comment (comment stream) 80 | "Write COMMENT to the GIF. Since the characters must be ASCII, 81 | replace any out-of-range character codes with #\\Space." 82 | ;;; Comments must be at least one character long 83 | (when (zerop (length comment)) 84 | (return-from write-comment)) 85 | (when (< 255 (length comment)) 86 | (skippy-warn "Truncating comment from ~D to 255 characters" 87 | (length comment)) 88 | (setf comment (subseq comment 255))) 89 | (flet ((cleaned-char-code (char) 90 | (let ((code (char-code char))) 91 | (if (> code 127) 32 code)))) 92 | (write-byte #x21 stream) 93 | (write-byte #xFE stream) 94 | (write-byte (length comment) stream) 95 | (loop for char across comment do 96 | (write-byte (cleaned-char-code char) stream)) 97 | (write-block-terminator stream))) 98 | 99 | (defun disposal-method-value (keyword) 100 | (let ((method (assoc keyword *disposal-methods*))) 101 | (cond (method (cdr method)) 102 | (t 103 | (skippy-warn "Unknown disposal method ~S ~ 104 | (expected one of ~{~S~^ ~}), using ~S instead" 105 | keyword 106 | (mapcar #'car *disposal-methods*) 107 | :unspecified) 108 | 0)))) 109 | 110 | (defun write-graphic-control-block (image stream) 111 | (let ((extension-introducer #x21) 112 | (graphic-control-label #xF9) 113 | (block-size 4)) 114 | (write-byte extension-introducer stream) 115 | (write-byte graphic-control-label stream) 116 | (write-byte block-size stream) 117 | ;; packed field: RRRDDDUT 118 | ;; RRR = reserved (left as zero) 119 | ;; DDD = disposal method 120 | ;; U = user input (ignored, left as zero), 121 | ;; T = transparent color flag 122 | (let ((flags 123 | (logior 124 | (dpb (disposal-method-value (disposal-method image)) 125 | (byte 3 2) 126 | 0) 127 | (dpb (boolean-bit (transparentp image)) 128 | (byte 1 0) 129 | 0)))) 130 | (write-byte flags stream)) 131 | (write-uint16 (delay-time image) stream) 132 | (write-byte (or (transparency-index image) 0) stream) 133 | (write-block-terminator stream))) 134 | 135 | (defun write-color-table (table stream) 136 | (let ((count (expt 2 (color-table-code-size table)))) 137 | (loop for color across (entries table) 138 | do (multiple-value-bind (r g b) 139 | (color-rgb color) 140 | (write-byte r stream) 141 | (write-byte g stream) 142 | (write-byte b stream)) 143 | (decf count)) 144 | (dotimes (i (* count 3)) 145 | (write-byte 0 stream)))) 146 | 147 | (defun effective-color-table (image) 148 | "Return the color table in effect when writing out IMAGE, or signal 149 | an error if no color table is available." 150 | (let ((color-table (color-table image))) 151 | (cond (color-table) 152 | ((or (not (slot-boundp image 'data-stream)) 153 | (not (data-stream image))) 154 | (error 'missing-color-table :image image)) 155 | ((color-table (data-stream image))) 156 | (t 157 | (error 'missing-color-table :image image))))) 158 | 159 | (defun compression-code-size (image) 160 | "Return the number of bits needed to represent the largest index in 161 | the effective color table of INDEX." 162 | (color-table-code-size (effective-color-table image))) 163 | 164 | (defun write-image (image context stream) 165 | (let* ((color-table (color-table image)) 166 | (code-size (compression-code-size image)) 167 | (width (width image)) 168 | (height (height image))) 169 | (check-image-dimensions width height) 170 | (write-graphic-control-block image stream) 171 | (write-byte +image-separator-code+ stream) 172 | (write-uint16 (left-position image) stream) 173 | (write-uint16 (top-position image) stream) 174 | (write-uint16 (width image) stream) 175 | (write-uint16 (height image) stream) 176 | ;; packed byte: CISRRSSS 177 | ;; C = local color table flag 178 | ;; I = interlaced flag (left as zero) 179 | ;; S = sort flag (left as zero) 180 | ;; RR = reserved (left as zero) 181 | ;; SSS = size (bit depth) of color table, minus one 182 | (let ((flags 183 | (logior 184 | (dpb (boolean-bit color-table) (byte 1 7) 0) 185 | (dpb (boolean-bit (interlacedp image)) (byte 1 6) 0) 186 | (dpb (1- code-size) (byte 3 0) 0)))) 187 | (write-byte flags stream)) 188 | (when color-table 189 | (write-color-table color-table stream)) 190 | (write-byte code-size stream) 191 | (let ((data (if (interlacedp image) 192 | (interlaced-image-data image) 193 | (image-data image)))) 194 | (lzw-compress data code-size context stream)) 195 | (write-block-terminator stream))) 196 | 197 | (defun write-data-stream-header (data-stream stream) 198 | (let* ((color-table (color-table data-stream)) 199 | (code-size (color-table-code-size color-table))) 200 | (write-sequence *gif-signature* stream) 201 | (write-uint16 (width data-stream) stream) 202 | (write-uint16 (height data-stream) stream) 203 | ;; packed byte: GRRRSTTT 204 | ;; G = global color table flag, RRR = color resolution, S = sort flag, 205 | ;; TTT = global color table size 206 | (write-byte (logior (ash (boolean-bit (color-table data-stream)) 7) 207 | (1- code-size)) 208 | stream) 209 | ;; background color index 210 | (write-byte 0 stream) 211 | (write-byte +pixel-aspect-ratio+ stream) 212 | (when color-table 213 | (write-color-table color-table stream)) 214 | (when (comment data-stream) 215 | (write-comment (comment data-stream) stream)) 216 | (when (loopingp data-stream) 217 | (write-netscape-looping-block stream)))) 218 | 219 | (defun write-end-code (data-stream stream) 220 | (declare (ignore data-stream)) 221 | (write-byte +gif-trailer-code+ stream)) 222 | 223 | (defun write-data-stream (data-stream stream) 224 | (write-data-stream-header data-stream stream) 225 | (when (zerop (length (images data-stream))) 226 | (skippy-warn "No images in ~A" data-stream)) 227 | (loop with context = (make-instance 'compression-context) 228 | for image across (images data-stream) do 229 | (check-dimensions data-stream image) 230 | (write-image image context stream)) 231 | (write-end-code data-stream stream) 232 | (values)) 233 | 234 | (defun output-data-stream (data-stream file &key (if-exists :supersede)) 235 | (with-open-file (stream file 236 | :direction :output 237 | :element-type '(unsigned-byte 8) 238 | :if-exists if-exists) 239 | (write-data-stream data-stream stream) 240 | (probe-file file))) 241 | -------------------------------------------------------------------------------- /image.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials 13 | ;;; provided with the distribution. 14 | ;;; 15 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 16 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 18 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 19 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 20 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 21 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 22 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 23 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 24 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 25 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | ;;; 27 | ;;;; $Id: image.lisp,v 1.8 2008/01/31 20:25:40 xach Exp $ 28 | 29 | (in-package #:skippy) 30 | 31 | (defvar *default-delay-time* 100) 32 | 33 | (defun check-image-dimensions (width height) 34 | (unless (and (typep width 'image-dimension) 35 | (typep height 'image-dimension)) 36 | (error 'invalid-image-dimensions 37 | :width width 38 | :height height))) 39 | 40 | (defclass image (canvas) 41 | ((data-stream 42 | :initarg :data-stream 43 | :accessor data-stream 44 | :documentation "The data stream in which this image occurs.") 45 | (height 46 | :initarg :height 47 | :accessor height) 48 | (width 49 | :initarg :width 50 | :accessor width) 51 | (image-data 52 | :initarg :image-data 53 | :accessor image-data) 54 | (top-position 55 | :initarg :top-position 56 | :accessor top-position 57 | :documentation 58 | "The position of the image relative to the top of the logical screen") 59 | (left-position 60 | :initarg :left-position 61 | :accessor left-position 62 | :documentation 63 | "The position of the image relative to the left of the logical screen") 64 | (color-table 65 | :initarg :color-table 66 | :accessor color-table 67 | :documentation "The local color table of the image, if any.") 68 | (interlacedp 69 | :initarg :interlacedp 70 | :accessor interlacedp 71 | :documentation "Is the image interlaced?") 72 | (disposal-method 73 | :initarg :disposal-method 74 | :accessor disposal-method) 75 | (delay-time 76 | :initarg :delay-time 77 | :accessor delay-time 78 | :documentation "The time, in hundredths of a second, to wait after 79 | this image before displaying the next image") 80 | (transparency-index 81 | :initarg :transparency-index 82 | :accessor transparency-index 83 | :documentation "The color table index of the transparent color for 84 | this image. If null, the image has no transparent color.")) 85 | (:default-initargs 86 | :top-position 0 87 | :left-position 0 88 | :color-table nil 89 | :interlacedp nil 90 | :height nil 91 | :width nil 92 | :disposal-method :unspecified 93 | :delay-time *default-delay-time* 94 | :transparency-index nil) 95 | (:documentation 96 | "An IMAGE instance represents a graphic within a GIF data 97 | stream. There may be multiple images in the data stream.")) 98 | 99 | (defmethod print-object ((object image) stream) 100 | (print-unreadable-object (object stream :identity t :type t) 101 | (format stream "geometry ~Dx~D+~D+~D" 102 | (width object) 103 | (height object) 104 | (left-position object) 105 | (top-position object)))) 106 | 107 | (defmethod initialize-instance :after ((image image) 108 | &key data-stream 109 | height width 110 | image-data 111 | color-table 112 | &allow-other-keys) 113 | (when (eql color-table t) 114 | (setf (color-table image) (make-color-table))) 115 | (unless height 116 | (setf (height image) (height data-stream) 117 | height (height data-stream))) 118 | (unless width 119 | (setf (width image) (width data-stream) 120 | width (width data-stream))) 121 | (cond (image-data 122 | (let ((required-type `(array (unsigned-byte 8) 123 | (,(* height width))))) 124 | (unless (typep image-data required-type) 125 | (error "Supplied ~S is not of the required type ~A" 126 | :image-data required-type)))) 127 | (t 128 | (setf (image-data image) (make-image-data height width)))) 129 | (when data-stream 130 | (vector-push-extend image (images data-stream)))) 131 | 132 | 133 | (defmethod (setf data-stream) :after (image (data-stream data-stream)) 134 | (unless (slot-boundp image 'height) 135 | (setf (height image) (height data-stream))) 136 | (unless (slot-boundp image 'width) 137 | (setf (width image) (width data-stream))) 138 | (vector-push-extend image (images data-stream))) 139 | 140 | (defgeneric transparentp (image) 141 | (:method (image) 142 | (not (null (transparency-index image))))) 143 | 144 | (defun canvas-image (canvas) 145 | (make-instance 'image 146 | :height (height canvas) 147 | :width (width canvas) 148 | :image-data (image-data canvas))) 149 | 150 | (defun make-image (&key height width image-data data-stream 151 | (top-position 0) (left-position 0) 152 | color-table 153 | interlacedp 154 | (delay-time *default-delay-time*) 155 | transparency-index 156 | (disposal-method :unspecified)) 157 | (check-image-dimensions width height) 158 | (make-instance 'image 159 | :height height 160 | :width width 161 | :image-data image-data 162 | :data-stream data-stream 163 | :top-position top-position 164 | :left-position left-position 165 | :color-table color-table 166 | :interlacedp interlacedp 167 | :delay-time delay-time 168 | :transparency-index transparency-index 169 | :disposal-method disposal-method)) 170 | 171 | (defmethod clone ((image image)) 172 | (make-instance 'image 173 | :height (height image) 174 | :width (width image) 175 | :image-data (copy-seq (image-data image)) 176 | :data-stream (data-stream image) 177 | :top-position (top-position image) 178 | :left-position (left-position image) 179 | :color-table (copy-color-table (color-table image)) 180 | :delay-time (delay-time image) 181 | :transparency-index (transparency-index image) 182 | :disposal-method (disposal-method image))) 183 | 184 | (defmethod wrap-image (image) 185 | "Return a data stream of the appropriate size that contains IMAGE." 186 | (make-data-stream :height (height image) 187 | :width (width image) 188 | :initial-images (list image))) 189 | -------------------------------------------------------------------------------- /load-gif.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials 13 | ;;; provided with the distribution. 14 | ;;; 15 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 16 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 18 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 19 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 20 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 21 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 22 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 23 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 24 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 25 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | ;;; 27 | 28 | (in-package #:skippy) 29 | 30 | (defvar *effective-graphic-control* nil 31 | "The graphic control extension in effect for the current image.") 32 | 33 | (eval-when (:compile-toplevel :load-toplevel :execute) 34 | (defconstant +extension-introducer+ #x21) 35 | (defconstant +graphic-control-label+ #xF9) 36 | (defconstant +comment-label+ #xFE) 37 | (defconstant +application-label+ #xFF) 38 | (defconstant +plain-text-label+ #x01)) 39 | 40 | (defclass graphic-control-extension () 41 | ((delay-time 42 | :initarg :delay-time 43 | :reader delay-time) 44 | (disposal-method 45 | :initarg :disposal-method 46 | :reader disposal-method) 47 | (transparency-index 48 | :initarg :transparency-index 49 | :reader transparency-index))) 50 | 51 | (defmacro bind-bits ((integer size) bindings &body body) 52 | (let ((value (gensym)) 53 | (names (mapcar #'first bindings)) 54 | (sizes (mapcar #'second bindings))) 55 | (let ((total-size (apply #'+ sizes))) 56 | (when (> total-size size) 57 | (error "Bitfield total size (~D) is larger than provided integer size (~D)" 58 | total-size size)) 59 | `(let* ((,value ,integer) 60 | ,@(loop for offset = size then (- offset field-size) 61 | for name in names 62 | for field-size in sizes 63 | when name 64 | collect (list name 65 | `(ldb (byte ,field-size ,(- offset field-size)) ,value)))) 66 | ,@body)))) 67 | 68 | (defun read-uint16 (stream) 69 | (logand #xFFFF (+ (ash (read-byte stream) 0) 70 | (ash (read-byte stream) 8)))) 71 | 72 | (defun read-color (stream) 73 | (logand #xFFFFFF (+ (ash (read-byte stream) 16) 74 | (ash (read-byte stream) 8) 75 | (ash (read-byte stream) 0)))) 76 | 77 | (defun read-color-table (count stream) 78 | (let ((color-table (make-color-table))) 79 | (dotimes (i count color-table) 80 | (add-color (read-color stream) color-table)))) 81 | 82 | (defun stream-position (stream &key (offset 0)) 83 | "FILE-POSITION may return NIL or may signal an error \(for e.g. Gray 84 | streams); wrap it." 85 | (let ((pos (ignore-errors (file-position stream)))) 86 | (when pos 87 | (+ pos offset)))) 88 | 89 | (defun advance-stream-position (stream count) 90 | "Skip past COUNT bytes of input in STREAM." 91 | (let ((pos (stream-position stream :offset count))) 92 | (if pos 93 | (file-position stream pos) 94 | (dotimes (i count) 95 | (read-byte stream))))) 96 | 97 | (defun merge-graphic-control (image) 98 | (when *effective-graphic-control* 99 | (setf (delay-time image) 100 | (delay-time *effective-graphic-control*) 101 | (disposal-method image) 102 | (disposal-method *effective-graphic-control*) 103 | (transparency-index image) 104 | (transparency-index *effective-graphic-control*) 105 | *effective-graphic-control* nil))) 106 | 107 | (defun read-image (context stream) 108 | (let ((left-position (read-uint16 stream)) 109 | (top-position (read-uint16 stream)) 110 | (width (read-uint16 stream)) 111 | (height (read-uint16 stream)) 112 | (flags (read-byte stream)) 113 | (color-table nil)) 114 | (bind-bits (flags 8) 115 | ((local-color-table-flag 1) 116 | (interlaced-flag 1) 117 | (sort-flag 1) 118 | (reserved 2) 119 | (color-table-size 3)) 120 | (declare (ignore sort-flag reserved)) 121 | (when (plusp local-color-table-flag) 122 | (let ((color-table-entry-count (expt 2 (1+ color-table-size)))) 123 | (setf color-table (read-color-table color-table-entry-count 124 | stream)))) 125 | (let* ((code-size (read-byte stream)) 126 | (image-data (make-image-data width height))) 127 | (lzw-decompress image-data code-size context stream) 128 | (let ((image 129 | (make-image :left-position left-position 130 | :top-position top-position 131 | :width width 132 | :height height 133 | :image-data image-data 134 | :color-table color-table 135 | :interlacedp (plusp interlaced-flag)))) 136 | (when (plusp interlaced-flag) 137 | (replace image-data (deinterlaced-image-data image))) 138 | (merge-graphic-control image) 139 | image))))) 140 | 141 | (defun disposal-method-keyword (method) 142 | (or (car (rassoc method *disposal-methods*)) 143 | :unspecified)) 144 | 145 | (defun read-graphic-control-extension (stream) 146 | ;; STREAM is positioned just after the Graphic Control Label 147 | (let ((block-size (read-byte stream))) 148 | (when (/= block-size 4) 149 | (error 'unexpected-value 150 | :description "block-size" 151 | :expected-value 4 152 | :actual-value block-size 153 | :source stream 154 | :source-position (stream-position stream :offset -1))) 155 | (let ((fields (read-byte stream)) 156 | (delay-time (read-uint16 stream)) 157 | (transparency-index (read-byte stream)) 158 | (block-terminator (read-byte stream))) 159 | (when (/= block-terminator 0) 160 | (error 'unexpected-value 161 | :description "block-terminator" 162 | :actual-value block-terminator 163 | :expected-value 0 164 | :source stream 165 | :source-position (stream-position stream :offset -1))) 166 | (bind-bits (fields 8) 167 | ((reserved 3) 168 | (disposal-method 3) 169 | (user-input-flag 1) 170 | (transparent-color-flag 1)) 171 | (declare (ignore reserved user-input-flag)) 172 | (when (zerop transparent-color-flag) 173 | (setf transparency-index nil)) 174 | (make-instance 'graphic-control-extension 175 | :delay-time delay-time 176 | :disposal-method (disposal-method-keyword disposal-method) 177 | :transparency-index transparency-index))))) 178 | 179 | 180 | 181 | (defun skip-data-blocks (stream) 182 | ;; Data blocks take the form of a series of ( s of data>) sequences. A size octet of zero 184 | ;; terminates a data block. 185 | (loop 186 | (let ((size (read-byte stream))) 187 | (when (zerop size) 188 | (return)) 189 | (advance-stream-position stream size)))) 190 | 191 | (defun read-application-extension (stream data-stream) 192 | (let ((block-size (read-byte stream))) 193 | (let ((block (make-array block-size :element-type 'octet))) 194 | (read-sequence block stream) 195 | ;;; XXX If skippy ever supports more application extensions, it 196 | ;;; would make sense to put them in a table instead of 197 | ;;; hardcoding specific extension identifiers here. 198 | (when (equalp block *netscape-signature*) 199 | (setf (loopingp data-stream) t))) 200 | (skip-data-blocks stream))) 201 | 202 | (defun read-comment-extension (stream) 203 | (flet ((ascii-char (code) 204 | ;;; FIXME: This assumes ASCII code-char mapping; could keep a table 205 | ;;; instead. 206 | (code-char (min code 127)))) 207 | (with-output-to-string (output) 208 | (let ((block (make-array 255 :element-type 'octet))) 209 | (loop 210 | (let ((count (read-byte stream))) 211 | (when (zerop count) 212 | (return)) 213 | (read-sequence block stream :end count) 214 | (loop for i below count 215 | for octet across block 216 | do (write-char (ascii-char octet) output)))))))) 217 | 218 | (defun read-extension-object (stream data-stream) 219 | (let ((label (read-byte stream))) 220 | (case label 221 | (#.+plain-text-label+ 222 | (skip-data-blocks stream)) 223 | (#.+graphic-control-label+ 224 | (setf *effective-graphic-control* 225 | (read-graphic-control-extension stream))) 226 | (#.+application-label+ 227 | (read-application-extension stream data-stream)) 228 | (#.+comment-label+ 229 | (when (comment data-stream) 230 | (skippy-warn "Multiple comments found; only the final comment ~ 231 | will be loaded")) 232 | (setf (comment data-stream) (read-comment-extension stream))) 233 | (t 234 | (skippy-warn "Skipping unrecognized extension with label #x~2,'0X" label) 235 | (skip-data-blocks stream))))) 236 | 237 | (defun process-objects (data-stream stream) 238 | (let ((context (make-instance 'decompression-context))) 239 | (loop 240 | (let ((tag (read-byte stream nil))) 241 | (case tag 242 | ((nil) 243 | (return)) 244 | (#.+gif-trailer-code+ 245 | (return)) 246 | (#.+image-separator-code+ 247 | (add-image (read-image context stream) data-stream)) 248 | (#.+extension-introducer+ 249 | (read-extension-object stream data-stream)) 250 | (t 251 | (skippy-warn "Unknown tag ~D in ~A~:[~; at position ~:*~D~]" 252 | tag stream (stream-position stream :offset -1)))))))) 253 | 254 | (defvar *gif87a-signature* 255 | ;; The ASCII for string "GIF87a" 256 | (make-array 6 :element-type 'octet 257 | :initial-contents #(71 73 70 56 55 97))) 258 | 259 | (defvar *gif89a-signature* 260 | ;; The ASCII for string "GIF89a" 261 | (make-array 6 :element-type 'octet 262 | :initial-contents #(71 73 70 56 57 97))) 263 | 264 | (defun check-gif-signature (stream) 265 | "Check that STREAM starts with the ASCII string \"GIF89a\" or \"GIF87a\"." 266 | (let* ((pos (stream-position stream)) 267 | (signature (make-array 6 :element-type 'octet)) 268 | (count (read-sequence signature stream))) 269 | (when (/= count 6) 270 | (error 'short-signature 271 | :source stream 272 | :position pos)) 273 | (when (and (mismatch signature *gif89a-signature*) 274 | (mismatch signature *gif87a-signature*)) 275 | (error 'signature-mismatch 276 | :source stream 277 | :position pos)))) 278 | 279 | (defun read-data-stream (stream) 280 | (check-gif-signature stream) 281 | (let ((width (read-uint16 stream)) 282 | (height (read-uint16 stream)) 283 | (flags (read-byte stream)) 284 | (background-color-index (read-byte stream)) 285 | (pixel-aspect-ratio (read-byte stream)) 286 | (color-table nil) 287 | (*effective-graphic-control* nil)) 288 | (declare (ignore background-color-index pixel-aspect-ratio)) 289 | (bind-bits (flags 8) 290 | ((global-color-table-flag 1) 291 | (color-resolution 3) 292 | (sorted-flag 1) 293 | (global-color-table-size 3)) 294 | (declare (ignore color-resolution sorted-flag)) 295 | (when (plusp global-color-table-flag) 296 | (let ((color-table-entry-count (expt 2 (1+ global-color-table-size)))) 297 | (setf color-table (read-color-table color-table-entry-count 298 | stream)))) 299 | (let ((data-stream (make-data-stream :height height 300 | :width width 301 | :color-table color-table))) 302 | (process-objects data-stream stream) 303 | data-stream)))) 304 | 305 | (defun load-data-stream (file) 306 | (with-open-file (stream file :direction :input :element-type 'octet) 307 | (read-data-stream stream))) 308 | -------------------------------------------------------------------------------- /lzw.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials 13 | ;;; provided with the distribution. 14 | ;;; 15 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 16 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 18 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 19 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 20 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 21 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 22 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 23 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 24 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 25 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | ;;; 27 | ;;;; $Id: lzw.lisp,v 1.11 2007/01/03 22:01:10 xach Exp $ 28 | 29 | (in-package #:skippy) 30 | 31 | (defconstant +maximum-code-bits+ 12 32 | "The maximum bits per code, as defined by the specification.") 33 | 34 | (defclass compression-context () 35 | ((table 36 | :initform (make-hash-table) 37 | :reader table)) 38 | (:documentation 39 | "Store data structures that may be re-used when writing out 40 | multiple images in a GIF animation.")) 41 | 42 | ;;; 43 | ;;; The basic LZW compression algorithm is: 44 | ;;; 45 | ;;; prefix <- first character 46 | ;;; while pending data: 47 | ;;; char <- next character 48 | ;;; if prefix . char in table: 49 | ;;; prefix <- prefix . char 50 | ;;; else: 51 | ;;; output code for prefix 52 | ;;; add prefix . char to table 53 | ;;; prefix <- char 54 | ;;; output code for prefix 55 | ;;; 56 | 57 | (defun lzw-compress (vector code-size context stream) 58 | (declare (type (simple-array octet (*)) vector) 59 | (type (mod 13) code-size)) 60 | (let ((iv 0) 61 | (data-stream (make-bitstream stream))) 62 | (declare (fixnum iv)) 63 | (flet ((next-input () 64 | (when (< iv (length vector)) 65 | (prog1 66 | (aref vector iv) 67 | (incf iv))))) 68 | (let* ((string-table (table context)) 69 | (clear-code (expt 2 code-size)) 70 | (end-of-input-code (1+ clear-code)) 71 | (index (+ 2 clear-code)) 72 | (compression-size (1+ code-size)) 73 | (max-index (1- (expt 2 compression-size))) 74 | (prefix (next-input)) 75 | (next-char nil)) 76 | (clrhash string-table) 77 | (flet ((output-code (code) 78 | (write-bits code compression-size data-stream))) 79 | (output-code clear-code) 80 | (loop 81 | (setf next-char (next-input)) 82 | (when (null next-char) 83 | (output-code prefix) 84 | (output-code end-of-input-code) 85 | (reset-stream data-stream) 86 | (return)) 87 | (let* ((key (logior (ash prefix 8) next-char)) 88 | (entry (gethash key string-table))) 89 | (cond (entry 90 | (setf prefix entry)) 91 | (t 92 | (output-code prefix) 93 | (setf (gethash key string-table) index) 94 | (when (> index max-index) 95 | (setf max-index (1- (expt 2 (incf compression-size))))) 96 | (incf index) 97 | (setf prefix next-char)))) 98 | (when (= index #xFFF) 99 | ;; The index isn't allowed to be this big, so the string 100 | ;; table must be cleared out and restarted 101 | (output-code clear-code) 102 | (setf compression-size (1+ code-size)) 103 | (setf max-index (1- (expt 2 compression-size))) 104 | (clrhash string-table) 105 | (setf index (+ 2 clear-code))))))))) 106 | 107 | 108 | (deftype string-table-vector () 109 | '(simple-array (signed-byte 16) (4096))) 110 | 111 | (deftype string-table-entry () 112 | '(signed-byte 16)) 113 | 114 | (defclass decompression-context () 115 | ((entries 116 | :initform (make-array (expt 2 +maximum-code-bits+) 117 | :element-type 'string-table-entry 118 | :initial-element -1) 119 | :reader entries) 120 | (preds 121 | :initform (make-array (expt 2 +maximum-code-bits+) 122 | :element-type 'string-table-entry 123 | :initial-element -1) 124 | :reader preds)) 125 | (:documentation 126 | "A decompression context is used to hold data structures that may 127 | be re-used for repeated calls to lzw-decompress, so they don't have to 128 | be allocated fresh each time.")) 129 | 130 | (defun lzw-decompress (vector code-size context stream) 131 | "Decompress the GIF LZW data from STREAM into VECTOR." 132 | (declare (type (simple-array octet (*)) vector) 133 | (type (mod 9) code-size) 134 | (type stream stream) 135 | (optimize speed)) 136 | (let* ((entries (entries context)) 137 | (preds (preds context)) 138 | (clear-code (expt 2 code-size)) 139 | (end-of-input (+ clear-code 1)) 140 | (next-entry-index (+ clear-code 2)) 141 | (compression-size (1+ code-size)) 142 | (compression-threshold (* clear-code 2)) 143 | (last-code -1) 144 | (pos 0) 145 | (bitstream (make-input-bitstream stream))) 146 | (declare (type string-table-vector entries preds) 147 | (type fixnum clear-code end-of-input next-entry-index 148 | compression-size compression-threshold 149 | last-code pos) 150 | (type bitstream bitstream)) 151 | (fill entries -1 :start clear-code) 152 | (fill preds -1) 153 | (dotimes (i clear-code) 154 | (setf (aref entries i) i)) 155 | (labels ((reset-table () 156 | (when (/= last-code -1) 157 | (fill preds -1) 158 | (fill entries -1 :start clear-code) 159 | (setf last-code -1 160 | next-entry-index (+ clear-code 2) 161 | compression-size (1+ code-size) 162 | compression-threshold (* clear-code 2)))) 163 | (root-value (code) 164 | (loop 165 | (let ((pred (aref preds code))) 166 | (when (minusp pred) 167 | (return (aref entries code))) 168 | (setf code pred)))) 169 | (increase-compression-size () 170 | (setf compression-size (min +maximum-code-bits+ 171 | (+ compression-size 1)) 172 | compression-threshold (* compression-threshold 2))) 173 | (add-entry (entry pred) 174 | (when (> compression-threshold (expt 2 +maximum-code-bits+)) 175 | (return-from add-entry next-entry-index)) 176 | (when (>= pred next-entry-index) 177 | (error 'lzw-error 178 | :description "Corrupt data in LZW stream")) 179 | (let ((result 180 | (setf (aref preds next-entry-index) pred 181 | (aref entries next-entry-index) entry 182 | next-entry-index (1+ next-entry-index)))) 183 | (when (>= result compression-threshold) 184 | (increase-compression-size)) 185 | (1- result))) 186 | (code-depth (code) 187 | (let ((depth 0)) 188 | (declare (fixnum depth)) 189 | (loop 190 | (let ((pred (aref preds code))) 191 | (when (minusp pred) 192 | (return depth)) 193 | (setf depth (1+ depth) 194 | code pred))))) 195 | (output-code-string (code) 196 | (let ((i (+ pos (code-depth code))) 197 | (j pos)) 198 | (setf pos (1+ i)) 199 | (when (>= i (length vector)) 200 | (skippy-warn "Too much input data for image, ~ 201 | ignoring extra") 202 | (finish-input bitstream) 203 | (return-from lzw-decompress)) 204 | (loop 205 | (setf (aref vector i) (aref entries code) 206 | code (aref preds code) 207 | i (- i 1)) 208 | (when (< i j) 209 | (return)))))) 210 | (loop 211 | (let ((code (read-bits compression-size bitstream))) 212 | (declare (type fixnum code)) 213 | (cond ((= code clear-code) 214 | (reset-table)) 215 | ((= code end-of-input) 216 | (finish-input bitstream) 217 | (return-from lzw-decompress)) 218 | ((= last-code -1) 219 | (output-code-string code) 220 | (setf last-code code)) 221 | (t 222 | (let ((entry (aref entries code))) 223 | (if (minusp entry) 224 | (let ((root (root-value last-code))) 225 | (output-code-string (add-entry root last-code)) 226 | (setf last-code code)) 227 | (let ((root (root-value code))) 228 | (add-entry root last-code) 229 | (setf last-code code) 230 | (output-code-string code))))))))))) 231 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials 13 | ;;; provided with the distribution. 14 | ;;; 15 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 16 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 18 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 19 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 20 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 21 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 22 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 23 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 24 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 25 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | ;;; 27 | ;;;; $Id: package.lisp,v 1.15 2007/01/05 14:51:36 xach Exp $ 28 | 29 | (defpackage #:skippy 30 | (:use #:cl) 31 | (:export 32 | ;; data-stream 33 | #:data-stream 34 | #:make-data-stream 35 | #:height 36 | #:width 37 | #:color-table 38 | #:loopingp 39 | #:comment 40 | #:images 41 | ;; image 42 | #:image 43 | #:*default-delay-time* 44 | #:make-image 45 | #:image-data 46 | #:top-position 47 | #:left-position 48 | #:disposal-method 49 | #:delay-time 50 | #:transparency-index 51 | #:make-image-data 52 | ;; color tables 53 | #:color-table 54 | #:make-color-table 55 | #:add-color 56 | #:find-color 57 | #:ensure-color 58 | #:rgb-color 59 | #:color-rgb 60 | #:color-table-size 61 | #:color-table-entry 62 | #:copy-color-table 63 | ;; canvas 64 | #:canvas 65 | #:make-canvas 66 | #:composite 67 | #:fill-area 68 | #:write-canvas 69 | #:read-canvas 70 | #:save-canvas 71 | #:load-canvas 72 | #:fill-canvas 73 | #:clip-canvas 74 | #:clone 75 | #:flip-horizontal 76 | #:flip-vertical 77 | #:rotate-180 78 | #:scale 79 | #:pixel-ref 80 | ;; util 81 | #:canvas-image 82 | #:last-image 83 | #:add-delay 84 | #:add-image 85 | #:write-data-stream 86 | #:output-data-stream 87 | #:read-data-stream 88 | #:load-data-stream 89 | ;; warnings & conditions 90 | #:skippy-warning 91 | #:skippy-error 92 | #:lzw-error 93 | #:unexpected-value 94 | #:missing-color-table 95 | #:color-table-full 96 | #:signature-error 97 | )) 98 | -------------------------------------------------------------------------------- /skippy.asd: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials 13 | ;;; provided with the distribution. 14 | ;;; 15 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 16 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 18 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 19 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 20 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 21 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 22 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 23 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 24 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 25 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | ;;; 27 | 28 | (defpackage #:skippy-system 29 | (:use :cl #:asdf)) 30 | 31 | (in-package #:skippy-system) 32 | 33 | (defsystem #:skippy 34 | :version "1.3.12" 35 | :author "Zachary Beane " 36 | :description "Read and write GIF files" 37 | :license "BSD" 38 | :components ((:file "package") 39 | (:file "conditions" 40 | :depends-on ("package")) 41 | (:file "types" 42 | :depends-on ("package")) 43 | (:file "bitstream" 44 | :depends-on ("package" 45 | "types")) 46 | (:file "lzw" 47 | :depends-on ("package" 48 | "conditions" 49 | "bitstream")) 50 | (:file "color-table" 51 | :depends-on ("package" 52 | "conditions")) 53 | (:file "canvas" 54 | :depends-on ("package" 55 | "color-table")) 56 | (:file "data-stream" 57 | :depends-on ("package")) 58 | (:file "image" 59 | :depends-on ("data-stream" 60 | "color-table" 61 | "canvas")) 62 | (:file "gif89a" 63 | :depends-on ("package" 64 | "conditions" 65 | "types" 66 | "lzw" 67 | "data-stream" 68 | "image")) 69 | (:file "load-gif" 70 | :depends-on ("package" 71 | "conditions" 72 | "types" 73 | "lzw" 74 | "data-stream" 75 | "image" 76 | "gif89a")))) 77 | 78 | 79 | -------------------------------------------------------------------------------- /types.lisp: -------------------------------------------------------------------------------- 1 | ;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved 2 | ;;; 3 | ;;; Redistribution and use in source and binary forms, with or without 4 | ;;; modification, are permitted provided that the following conditions 5 | ;;; are met: 6 | ;;; 7 | ;;; * Redistributions of source code must retain the above copyright 8 | ;;; notice, this list of conditions and the following disclaimer. 9 | ;;; 10 | ;;; * Redistributions in binary form must reproduce the above 11 | ;;; copyright notice, this list of conditions and the following 12 | ;;; disclaimer in the documentation and/or other materials 13 | ;;; provided with the distribution. 14 | ;;; 15 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 16 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 18 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 19 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 20 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 21 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 22 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 23 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 24 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 25 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | ;;; 27 | 28 | (in-package #:skippy) 29 | 30 | (deftype octet () 31 | '(unsigned-byte 8)) 32 | 33 | (deftype buffer-offset () 34 | `(mod ,most-positive-fixnum)) 35 | 36 | (deftype bitstream-buffer () 37 | `(simple-array octet (255))) 38 | 39 | (deftype image-dimension () 40 | `(integer 1 #xFFFF)) 41 | --------------------------------------------------------------------------------