├── .gitignore ├── CHANGELOG ├── Makefile ├── README ├── animated-gif.lisp ├── cl-gd-glue.c ├── cl-gd-test.asd ├── cl-gd-test.lisp ├── cl-gd.asd ├── colors-aux.lisp ├── colors.lisp ├── docs ├── anti-aliased-lines.png ├── brushed-arc.png ├── chart.png ├── clipped-tangent.png ├── demooutp.png ├── gddemo.c ├── index.html ├── smallzappa.png ├── strings.png ├── triangle.png ├── zappa-ellipse.png ├── zappa-green.jpg └── zappa.jpg ├── drawing.lisp ├── gd-uffi.lisp ├── images.lisp ├── init.lisp ├── misc.lisp ├── packages.lisp ├── specials.lisp ├── strings.lisp ├── test ├── .gitignore ├── demoin.png ├── orig │ ├── anti-aliased-lines.png │ ├── brushed-arc.png │ ├── chart.png │ ├── circle.png │ ├── clipped-tangent.png │ ├── one-line.jpg │ ├── one-line.png │ ├── one-pixel.jpg │ ├── one-pixel.png │ ├── triangle.png │ ├── zappa-ellipse.png │ └── zappa-green.jpg ├── smallzappa.png └── zappa.jpg ├── transform.lisp └── util.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | cl-gd-glue.so 2 | cl-gd-glue.o 3 | cl-gd-glue.dylib 4 | -------------------------------------------------------------------------------- /CHANGELOG: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/CHANGELOG -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # this should work for FreeBSD and most Linux distros 2 | 3 | cl-gd-glue.so: cl-gd-glue.c 4 | cc -I/usr/local/include -fPIC -c cl-gd-glue.c 5 | ld -shared -lgd -lz -lpng -ljpeg -lfreetype -lm -lc cl-gd-glue.o -o cl-gd-glue.so -L/usr/local/lib 6 | rm cl-gd-glue.o 7 | 8 | # this should work for Mac OS X 9 | 10 | cl-gd-glue.dylib: cl-gd-glue.c 11 | cc -arch x86_64 -lgif -lgd -lpng -lz -lfreetype -ljpeg -dynamiclib cl-gd-glue.c -o cl-gd-glue.dylib -I/usr/local/include -L/usr/local/lib 12 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Complete documentation for CL-GD can be found in the 'doc' 2 | directory. 3 | 4 | CL-GD also supports Nikodemus Siivola's HYPERDOC, see 5 | and 6 | . 7 | 8 | 1. Installation (see doc/index.html for Windows instructions) 9 | 10 | 1.1. Download and install a recent version of GD and its supporting 11 | libraries. Please use your operating system's package manager to 12 | install the "development" version of the GD library. On Ubuntu 13 | Linux, this can be achieved with the command: 14 | 15 | apt-get install libgd2-xpm-dev 16 | 17 | GD depends on several other libraries to handle different 18 | graphics formats. These should be installed by your package 19 | manager automatically. If you cannot use or do not have a 20 | package manager that includes GD, you'll have to follow the GD 21 | installation instructions (http://www.boutell.com/gd/). Note 22 | that you won't be able to compile CL-GD unless you have installed 23 | all supporting libraries. This is different from using GD 24 | directly from C where you only have to install the libraries you 25 | intend to use. 26 | 27 | 1.2. Install cl-gd and its Lisp dependencies using quicklisp 28 | (http://quicklisp.org/). 29 | 30 | 1.3. Compile cl-gd-glue.c into a shared library for your platform. A 31 | simple Makefile is included in the cl-gd source directory. 32 | 33 | For FreeBSD and Linux, just type 34 | 35 | make 36 | 37 | For OSX, type 38 | 39 | make cl-gd-glue.dylib 40 | 41 | 42 | 2. Test 43 | 44 | CL-GD comes with a simple test suite that can be used to check if it's 45 | basically working. Note that this'll only test a subset of CL-GD. To 46 | run the tests load CL-GD and then 47 | 48 | (asdf:oos 'asdf:load-op :cl-gd-test) 49 | (cl-gd-test:test) 50 | 51 | If you have the georgiab.ttf TrueType font from Microsoft you can also 52 | check the FreeType support of CL-GD with 53 | 54 | (cl-gd-test:test #p"/usr/X11R6/lib/X11/fonts/truetype/georgiab.ttf") 55 | 56 | where you should obviously replace the path above with the full path 57 | to the font on your machine. 58 | 59 | (See the note about failed tests in the documentation.) -------------------------------------------------------------------------------- /animated-gif.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- 2 | ;;; $Header: /usr/local/cvsrep/gd/gd-uffi.lisp,v 1.33 2009/11/23 17:05:39 edi Exp $ 3 | 4 | ;;; Copyright (c) 2012, Hans Huebner. All rights reserved. 5 | 6 | ;;; Redistribution and use in source and binary forms, with or without 7 | ;;; modification, are permitted provided that the following conditions 8 | ;;; are met: 9 | 10 | ;;; * Redistributions of source code must retain the above copyright 11 | ;;; notice, this list of conditions and the following disclaimer. 12 | 13 | ;;; * Redistributions in binary form must reproduce the above 14 | ;;; copyright notice, this list of conditions and the following 15 | ;;; disclaimer in the documentation and/or other materials 16 | ;;; provided with the distribution. 17 | 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 19 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 22 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 24 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 25 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 26 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | (in-package :cl-gd) 31 | 32 | ;; GIF animation context, contains plist with animation parameters. 33 | (defvar *current-animation*) 34 | 35 | (defun add-image-to-animation (image 36 | &key 37 | (local-color-map-p nil local-color-map-provided-p) 38 | (left-offset 0) 39 | (top-offset 0) 40 | (delay nil delay-provided-p) 41 | (disposal :none) 42 | last-image 43 | (animation *current-animation*)) 44 | (gd-image-gif-anim-add (img image) 45 | (getf animation :anim-pointer) 46 | (if local-color-map-provided-p 47 | (if local-color-map-p 1 0) 48 | (if (getf animation :global-color-map-p) 0 1)) 49 | left-offset 50 | top-offset 51 | (or (when delay-provided-p 52 | delay) 53 | (getf animation :default-delay) 54 | (error "no delay specified and no default-delay set in animation context")) 55 | (ecase disposal 56 | (:none +gd-disposal-none+) 57 | (:restore-background +gd-disposal-restore-background+) 58 | (:restore-previous +gd-disposal-restore-previous+)) 59 | (when last-image 60 | (img last-image)))) 61 | 62 | (defmacro with-animated-gif ((filename 63 | &key 64 | (background-image '*default-image*) 65 | global-color-map-p 66 | (loop-count -1) 67 | (animation '*current-animation*) 68 | default-delay) 69 | &body body) 70 | `(let ((,animation (list :anim-pointer (gd-image-gif-anim-begin-wrap (img ,background-image) 71 | ,filename 72 | (if ,global-color-map-p 1 0) 73 | ,loop-count) 74 | :global-color-map-p ,global-color-map-p 75 | :default-delay ,default-delay))) 76 | (unwind-protect 77 | (progn ,@body) 78 | (gd-image-gif-anim-end-wrap (getf ,animation :anim-pointer))))) 79 | 80 | -------------------------------------------------------------------------------- /cl-gd-glue.c: -------------------------------------------------------------------------------- 1 | /* Copyright (c) 2003-2009, Dr. Edmund Weitz. 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 | #include 28 | #include 29 | #include "gd.h" 30 | 31 | gdImagePtr gdImageCreateFromJpegFile (char *filename, int *err) { 32 | FILE *in = fopen(filename, "rb"); 33 | gdImagePtr im; 34 | 35 | if (in) { 36 | im = gdImageCreateFromJpeg(in); 37 | if (im == NULL) { 38 | *err = 0; 39 | return NULL; 40 | } 41 | fclose(in); 42 | return im; 43 | } 44 | *err = errno; 45 | return NULL; 46 | } 47 | 48 | #ifndef GD_DONT_USE_GIF 49 | gdImagePtr gdImageCreateFromGifFile (char *filename, int *err) { 50 | FILE *in = fopen(filename, "rb"); 51 | gdImagePtr im; 52 | 53 | if (in) { 54 | im = gdImageCreateFromGif(in); 55 | if (im == NULL) { 56 | *err = 0; 57 | return NULL; 58 | } 59 | fclose(in); 60 | return im; 61 | } 62 | *err = errno; 63 | return NULL; 64 | } 65 | #endif 66 | 67 | gdImagePtr gdImageCreateFromPngFile (char *filename, int *err) { 68 | FILE *in = fopen(filename, "rb"); 69 | gdImagePtr im; 70 | 71 | if (in) { 72 | im = gdImageCreateFromPng(in); 73 | if (im == NULL) { 74 | *err = 0; 75 | return NULL; 76 | } 77 | fclose(in); 78 | return im; 79 | } 80 | *err = errno; 81 | return NULL; 82 | } 83 | 84 | gdImagePtr gdImageCreateFromGdFile (char *filename, int *err) { 85 | FILE *in = fopen(filename, "rb"); 86 | gdImagePtr im; 87 | 88 | if (in) { 89 | im = gdImageCreateFromGd(in); 90 | if (im == NULL) { 91 | *err = 0; 92 | return NULL; 93 | } 94 | fclose(in); 95 | return im; 96 | } 97 | *err = errno; 98 | return NULL; 99 | } 100 | 101 | gdImagePtr gdImageCreateFromGd2File (char *filename, int *err) { 102 | FILE *in = fopen(filename, "rb"); 103 | gdImagePtr im; 104 | 105 | if (in) { 106 | im = gdImageCreateFromGd2(in); 107 | if (im == NULL) { 108 | *err = 0; 109 | return NULL; 110 | } 111 | fclose(in); 112 | return im; 113 | } 114 | *err = errno; 115 | return NULL; 116 | } 117 | 118 | gdImagePtr gdImageCreateFromGd2PartFile (char *filename, int *err, int srcX, int srcY, int w, int h) { 119 | FILE *in = fopen(filename, "rb"); 120 | gdImagePtr im; 121 | 122 | if (in) { 123 | im = gdImageCreateFromGd2Part(in, srcX, srcY, w, h); 124 | if (im == NULL) { 125 | *err = 0; 126 | return NULL; 127 | } 128 | fclose(in); 129 | return im; 130 | } 131 | *err = errno; 132 | return NULL; 133 | } 134 | 135 | gdImagePtr gdImageCreateFromXbmFile (char *filename, int *err) { 136 | FILE *in = fopen(filename, "rb"); 137 | gdImagePtr im; 138 | 139 | if (in) { 140 | im = gdImageCreateFromXbm(in); 141 | if (im == NULL) { 142 | *err = 0; 143 | return NULL; 144 | } 145 | fclose(in); 146 | return im; 147 | } 148 | *err = errno; 149 | return NULL; 150 | } 151 | 152 | int gdImageGetAlpha (gdImagePtr im, int color) { 153 | return gdImageAlpha(im, color); 154 | } 155 | 156 | int gdImageGetRed (gdImagePtr im, int color) { 157 | return gdImageRed(im, color); 158 | } 159 | 160 | int gdImageGetGreen (gdImagePtr im, int color) { 161 | return gdImageGreen(im, color); 162 | } 163 | 164 | int gdImageGetBlue (gdImagePtr im, int color) { 165 | return gdImageBlue(im, color); 166 | } 167 | 168 | int gdImageGetSX (gdImagePtr im) { 169 | return gdImageSX(im); 170 | } 171 | 172 | int gdImageGetSY (gdImagePtr im) { 173 | return gdImageSY(im); 174 | } 175 | 176 | int gdImageGetColorsTotal (gdImagePtr im) { 177 | return gdImageColorsTotal(im); 178 | } 179 | 180 | /* dumb names, I know... */ 181 | int gdImageGetGetInterlaced (gdImagePtr im) { 182 | return gdImageGetInterlaced(im); 183 | } 184 | 185 | int gdImageGetGetTransparent (gdImagePtr im) { 186 | return gdImageGetTransparent(im); 187 | } 188 | 189 | /* GIF animation support */ 190 | 191 | void* 192 | gdImageGifAnimBeginWrap(gdImagePtr im, 193 | char* filename, 194 | int globalCM, 195 | int loops) 196 | { 197 | FILE* out = fopen(filename, "w"); 198 | 199 | if (out) { 200 | gdImageGifAnimBegin(im, out, globalCM, loops); 201 | } 202 | 203 | return out; 204 | } 205 | 206 | void 207 | gdImageGifAnimEndWrap(void* out) 208 | { 209 | gdImageGifAnimEnd(out); 210 | fclose(out); 211 | } 212 | -------------------------------------------------------------------------------- /cl-gd-test.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; $Header: /usr/local/cvsrep/gd/cl-gd-test.asd,v 1.12 2009/11/23 17:05:38 edi Exp $ 3 | 4 | ;;; Copyright (c) 2003-2009, Dr. Edmund Weitz. All rights reserved. 5 | 6 | ;;; Redistribution and use in source and binary forms, with or without 7 | ;;; modification, are permitted provided that the following conditions 8 | ;;; are met: 9 | 10 | ;;; * Redistributions of source code must retain the above copyright 11 | ;;; notice, this list of conditions and the following disclaimer. 12 | 13 | ;;; * Redistributions in binary form must reproduce the above 14 | ;;; copyright notice, this list of conditions and the following 15 | ;;; disclaimer in the documentation and/or other materials 16 | ;;; provided with the distribution. 17 | 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 19 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 22 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 24 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 25 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 26 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | (in-package :cl-user) 31 | 32 | (defpackage :cl-gd-test.system 33 | (:use :cl :asdf)) 34 | 35 | (in-package :cl-gd-test.system) 36 | 37 | (defparameter *cl-gd-test-directory* 38 | (make-pathname :name nil :type nil :version nil 39 | :defaults (parse-namestring *load-truename*))) 40 | 41 | (defsystem :cl-gd-test 42 | :version "0.4.8" 43 | :components ((:file "cl-gd-test")) 44 | :depends-on (:cl-gd)) 45 | 46 | -------------------------------------------------------------------------------- /cl-gd-test.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- 2 | ;;; $Header: /usr/local/cvsrep/gd/cl-gd-test.lisp,v 1.27 2009/11/23 17:05:38 edi Exp $ 3 | 4 | ;;; Copyright (c) 2003-2009, Dr. Edmund Weitz. All rights reserved. 5 | 6 | ;;; Redistribution and use in source and binary forms, with or without 7 | ;;; modification, are permitted provided that the following conditions 8 | ;;; are met: 9 | 10 | ;;; * Redistributions of source code must retain the above copyright 11 | ;;; notice, this list of conditions and the following disclaimer. 12 | 13 | ;;; * Redistributions in binary form must reproduce the above 14 | ;;; copyright notice, this list of conditions and the following 15 | ;;; disclaimer in the documentation and/or other materials 16 | ;;; provided with the distribution. 17 | 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 19 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 22 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 24 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 25 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 26 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | (in-package :cl-user) 31 | 32 | (defpackage #:cl-gd-test 33 | (:use #:cl 34 | #:cl-gd) 35 | (:export #:test)) 36 | 37 | (in-package :cl-gd-test) 38 | 39 | (defparameter *test-directory* 40 | (merge-pathnames (make-pathname :directory '(:relative "test")) 41 | (make-pathname :name nil 42 | :type nil 43 | :version :newest 44 | :defaults cl-gd.system:*cl-gd-directory*)) 45 | 46 | "Where test files are put.") 47 | 48 | (defun test-file-location (name &optional (type :unspecific)) 49 | "Create test file location from NAME and TYPE component." 50 | (make-pathname :name name 51 | :type type 52 | :defaults *test-directory*)) 53 | 54 | (defun compare-files (file &key type expected-result) 55 | "Compare test file FILE to orginal file in subdirectory ORIG." 56 | (with-image-from-file (image file) 57 | (with-image-from-file (orig (merge-pathnames 58 | (make-pathname :type 59 | (or type (pathname-type file)) 60 | :directory 61 | '(:relative "orig")) 62 | file)) 63 | (equal (differentp image orig) 64 | expected-result)))) 65 | 66 | (defun test-001 () 67 | (let ((file (test-file-location "one-pixel" "png"))) 68 | ;; 40x40 image 69 | (with-image* (40 40) 70 | ;; white background 71 | (allocate-color 255 255 255) 72 | ;; black pixel in the middle 73 | (set-pixel 20 20 :color (allocate-color 0 0 0)) 74 | ;; write to PNG target 75 | (write-image-to-file file :if-exists :supersede)) 76 | ;; compare to existing file 77 | (compare-files file))) 78 | 79 | (defun test-002 () 80 | (let ((file (test-file-location "one-pixel" "jpg"))) 81 | ;; 40x40 image 82 | (with-image* (40 40) 83 | ;; white background 84 | (allocate-color 255 255 255) 85 | ;; black pixel in the middle 86 | (set-pixel 20 20 :color (allocate-color 0 0 0)) 87 | ;; write to JPEG target 88 | (write-image-to-file file :if-exists :supersede)) 89 | ;; compare to existing file 90 | (compare-files file))) 91 | 92 | (defun test-003 () 93 | (let ((file (test-file-location "one-line" "png"))) 94 | ;; 40x40 image 95 | (with-image* (40 40) 96 | ;; white background 97 | (allocate-color 255 255 255) 98 | ;; anti-aliased black line 99 | (draw-line 20 20 30 30 100 | :color (make-anti-aliased 101 | (allocate-color 0 0 0))) 102 | ;; write to PNG target 103 | (write-image-to-file file :if-exists :supersede)) 104 | ;; compare to existing file 105 | (compare-files file))) 106 | 107 | (defun test-004 () 108 | (let ((file (test-file-location "one-line" "jpg"))) 109 | ;; 40x40 image 110 | (with-image* (40 40) 111 | ;; white background 112 | (allocate-color 255 255 255) 113 | ;; anti-aliased black line 114 | (draw-line 20 20 30 30 115 | :color (make-anti-aliased 116 | (allocate-color 0 0 0))) 117 | ;; write to JPEG target 118 | (write-image-to-file file :if-exists :supersede)) 119 | ;; compare to existing PNG file 120 | (compare-files file))) 121 | 122 | (defun test-005 () 123 | (with-image-from-file* ((test-file-location "one-pixel" "png")) 124 | (let ((num (number-of-colors))) 125 | (find-color 255 255 255 :resolve t) 126 | (multiple-value-bind (width height) 127 | (image-size) 128 | (and (= width 40) 129 | (= height 40) 130 | ;; FIND-COLOR should not have changed the number of 131 | ;; colors 132 | (= num (number-of-colors))))))) 133 | 134 | (defun test-006 () 135 | (with-image-from-file* ((test-file-location "one-pixel" "png")) 136 | (with-transformation (:x1 0.1 :x2 0.5 :y1 10.8 :y2 20.9) 137 | (multiple-value-bind (width height) 138 | (image-size) 139 | ;; make sure WITH-TRANSFORMATION returns transformed size 140 | (and (>= 0.0001 (abs (- 0.4 width))) 141 | (>= 0.0001 (abs (- 10.1 height)))))))) 142 | 143 | (defun test-007 () 144 | (let ((file (test-file-location "circle" "png"))) 145 | (with-image* (40 40) 146 | (allocate-color 255 255 255) 147 | (let ((black (allocate-color 0 0 0))) 148 | (with-default-color (black) 149 | ;; move origin to center and stretch 150 | (with-transformation (:x1 -100 :width 200 :y1 -100 :height 200) 151 | (draw-filled-circle 0 0 50) 152 | (write-image-to-file file 153 | :if-exists :supersede))))) 154 | (compare-files file))) 155 | 156 | (defun test-008 () 157 | (with-image (image 40 40) 158 | (allocate-color 255 255 255 :image image) 159 | (with-default-color ((allocate-color 0 0 0 :image image)) 160 | ;; no transformation and use more general ellipse function 161 | (draw-filled-ellipse 20 20 20 20 :image image) 162 | (with-image-from-file (other-image 163 | (test-file-location "circle" "png")) 164 | (not (differentp image other-image)))))) 165 | 166 | (defun test-009 () 167 | (let ((file (test-file-location "chart" "png"))) 168 | ;; create 200x200 pixel image 169 | (with-image* (200 200) 170 | ;; background color 171 | (allocate-color 68 70 85) 172 | (let ((beige (allocate-color 222 200 81)) 173 | (brown (allocate-color 206 150 75)) 174 | (green (allocate-color 104 156 84)) 175 | (red (allocate-color 163 83 84)) 176 | (white (allocate-color 255 255 255)) 177 | (two-pi (* 2 pi))) 178 | ;; move origin to center of image 179 | (with-transformation (:x1 -100 :x2 100 :y1 -100 :y2 100 :radians t) 180 | ;; draw some 'pie slices' 181 | (draw-arc 0 0 130 130 0 (* .6 two-pi) 182 | :center-connect t :filled t :color beige) 183 | (draw-arc 0 0 130 130 (* .6 two-pi) (* .8 two-pi) 184 | :center-connect t :filled t :color brown) 185 | (draw-arc 0 0 130 130 (* .8 two-pi) (* .95 two-pi) 186 | :center-connect t :filled t :color green) 187 | (draw-arc 0 0 130 130 (* .95 two-pi) two-pi 188 | :center-connect t :filled t :color red) 189 | ;; use GD fonts 190 | (with-default-color (white) 191 | (with-default-font (:small) 192 | (draw-string -8 -30 "60%") 193 | (draw-string -20 40 "20%") 194 | (draw-string 20 30 "15%")) 195 | (draw-string -90 90 "Global Revenue" 196 | :font :large)) 197 | (write-image-to-file file 198 | :compression-level 6 199 | :if-exists :supersede)))) 200 | (compare-files file))) 201 | 202 | (defun test-010 () 203 | (let ((file (test-file-location "zappa-green" "jpg"))) 204 | ;; get JPEG from disk 205 | (with-image-from-file (old (test-file-location "zappa" "jpg")) 206 | (multiple-value-bind (width height) 207 | (image-size old) 208 | (with-image (new width height) 209 | ;; green color for background 210 | (allocate-color 0 255 0 :image new) 211 | ;; merge with original JPEG 212 | (copy-image old new 0 0 0 0 width height 213 | :merge 50) 214 | (write-image-to-file file 215 | :image new 216 | :if-exists :supersede)))) 217 | (compare-files file))) 218 | 219 | (defun test-011 () 220 | ;; small image 221 | (with-image* (10 10) 222 | (loop for i below +max-colors+ do 223 | ;; allocate enough colors (all gray) to fill the palette 224 | (allocate-color i i i)) 225 | (and (= +max-colors+ (number-of-colors)) 226 | (null (find-color 255 0 0 :exact t)) 227 | (let ((match (find-color 255 0 0))) ; green 228 | (and (= 85 229 | (color-component :red match) 230 | (color-component :green match) 231 | (color-component :blue match))))))) 232 | 233 | (defun test-012 () 234 | (let ((file (test-file-location "triangle" "png"))) 235 | (with-image* (100 100) 236 | (allocate-color 255 255 255) ; white background 237 | (let ((red (allocate-color 255 0 0)) 238 | (yellow (allocate-color 255 255 0)) 239 | (orange (allocate-color 255 165 0))) 240 | ;; thin black border 241 | (draw-rectangle* 0 0 99 99 242 | :color (allocate-color 0 0 0)) 243 | ;; lines are five pixels thick 244 | (with-thickness (5) 245 | ;; colored triangle 246 | (draw-polygon (list 10 10 90 50 50 90) 247 | ;; styled color 248 | :color (list red red red 249 | yellow yellow yellow 250 | nil nil nil 251 | orange orange orange)) 252 | (write-image-to-file file 253 | :compression-level 8 254 | :if-exists :supersede)))) 255 | (compare-files file))) 256 | 257 | (defun test-013 () 258 | (let ((file (test-file-location "brushed-arc" "png"))) 259 | (with-image* (200 100) 260 | (allocate-color 255 165 0) ; orange background 261 | (with-image (brush 6 6) 262 | (let* ((black (allocate-color 0 0 0 :image brush)) ; black background 263 | (red (allocate-color 255 0 0 :image brush)) 264 | (blue (allocate-color 0 0 255 :image brush))) 265 | (setf (transparent-color brush) black) ; make background transparent 266 | ;; now set the pixels in the brush 267 | (set-pixels '(2 2 2 3 3 2 3 3) 268 | :color blue :image brush) 269 | (set-pixels '(1 2 1 3 4 2 4 3 2 1 3 1 2 4 3 4) 270 | :color red :image brush) 271 | ;; then use it to draw an arc 272 | (draw-arc 100 50 180 80 180 300 :color (make-brush brush))) 273 | (write-image-to-file file 274 | :compression-level 7 275 | :if-exists :supersede))) 276 | (compare-files file))) 277 | 278 | (defun test-014 () 279 | (let ((file (test-file-location "anti-aliased-lines" "png"))) 280 | (with-image* (150 50) 281 | (let ((orange (allocate-color 255 165 0)) ; orange background 282 | (white (allocate-color 255 255 255)) 283 | (red (allocate-color 255 0 0))) 284 | ;; white background rectangle in the middle third 285 | (draw-rectangle* 50 0 99 49 286 | :filled t 287 | :color white) 288 | (with-thickness (2) 289 | ;; just a red line 290 | (draw-line 5 10 145 10 :color red) 291 | ;; anti-aliased red line 292 | (draw-line 5 25 145 25 :color (make-anti-aliased red)) 293 | ;; anti-aliased red line which should stand out against 294 | ;; orange background 295 | (draw-line 5 40 145 40 :color (make-anti-aliased red orange)))) 296 | (write-image-to-file file 297 | :compression-level 3 298 | :if-exists :supersede)) 299 | (compare-files file))) 300 | 301 | (defun test-015 () 302 | (let ((file (test-file-location "clipped-tangent" "png"))) 303 | (with-image* (150 150) 304 | (allocate-color 255 255 255) ; white background 305 | ;; transform such that x axis ranges from (- PI) to PI and y 306 | ;; axis ranges from -3 to 3 307 | (with-transformation (:x1 (- pi) :width (* 2 pi) :y1 -3 :y2 3) 308 | (let ((black (allocate-color 0 0 0)) 309 | (red (allocate-color 255 0 0)) 310 | (rectangle (list (- .4 pi) 2.5 (- pi .4) -2.5))) 311 | (with-default-color (black) 312 | ;; draw axes 313 | (draw-line 0 -3 0 3 :color black) 314 | (draw-line (- pi) 0 pi 0)) 315 | ;; show clipping rectangle (styled) 316 | (draw-rectangle rectangle :color (list black black black nil black nil)) 317 | (with-clipping-rectangle (rectangle) 318 | ;; draw tangent function 319 | (loop for x from (- pi) below (* 2 pi) by (/ pi 75) do 320 | (set-pixel x (tan x) :color red))))) 321 | (write-image-to-file file 322 | :if-exists :supersede)) 323 | (compare-files file))) 324 | 325 | (defun gd-demo-picture (file random-state &optional write-file) 326 | (with-image* ((+ 256 384) 384 t) 327 | (let ((white (allocate-color 255 255 255)) 328 | (red (allocate-color 255 0 0)) 329 | (green (allocate-color 0 255 0)) 330 | (blue (allocate-color 0 0 255)) 331 | (vertices (list 64 0 0 128 128 128)) 332 | (image-width (image-width)) 333 | (image-height (image-height))) 334 | (setf (transparent-color) white) 335 | (draw-rectangle* 0 0 image-width image-height :color white) 336 | (with-image-from-file (in-file (test-file-location "demoin" "png")) 337 | (copy-image in-file *default-image* 338 | 0 0 32 32 192 192 339 | :resize t 340 | :dest-width 255 341 | :dest-height 255 342 | :resample t) 343 | (multiple-value-bind (in-width in-height) 344 | (image-size in-file) 345 | (loop for a below 360 by 45 do 346 | (copy-image in-file *default-image* 347 | 0 0 348 | (+ 256 192 (* 128 (cos (* a .0174532925)))) 349 | (- 192 (* 128 (sin (* a .0174532925)))) 350 | in-width in-height 351 | :rotate t 352 | :angle a)) 353 | (with-default-color (green) 354 | (with-thickness (4) 355 | (draw-line 16 16 240 16) 356 | (draw-line 240 16 240 240) 357 | (draw-line 240 240 16 240) 358 | (draw-line 16 240 16 16)) 359 | (draw-polygon vertices :filled t)) 360 | (dotimes (i 3) 361 | (incf (nth (* 2 i) vertices) 128)) 362 | (draw-polygon vertices 363 | :color (make-anti-aliased green) 364 | :filled t) 365 | (with-default-color (blue) 366 | (draw-arc 128 128 60 20 0 720) 367 | (draw-arc 128 128 40 40 90 270) 368 | (fill-image 8 8)) 369 | (with-image (brush 16 16 t) 370 | (copy-image in-file brush 371 | 0 0 0 0 372 | in-width in-height 373 | :resize t 374 | :dest-width (image-width brush) 375 | :dest-height (image-height brush)) 376 | (draw-line 0 255 255 0 377 | :color (cons (make-brush brush) 378 | (list nil nil nil nil nil nil nil t)))))) 379 | (with-default-color (red) 380 | (draw-string 32 32 "hi" :font :giant) 381 | (draw-string 64 64 "hi" :font :small)) 382 | (with-clipping-rectangle* (0 (- image-height 100) 100 image-height) 383 | (with-default-color ((make-anti-aliased white)) 384 | (dotimes (i 100) 385 | (draw-line (random image-width random-state) 386 | (random image-height random-state) 387 | (random image-width random-state) 388 | (random image-height random-state)))))) 389 | (setf (interlacedp) t) 390 | (true-color-to-palette) 391 | (if write-file 392 | (write-image-to-file file 393 | :if-exists :supersede) 394 | (with-image-from-file (demo-file file) 395 | (not (differentp demo-file *default-image*)))))) 396 | 397 | (defun test-016 () 398 | (let* ((file (test-file-location "demooutp" "png")) 399 | (random-state-1 (make-random-state t)) 400 | (random-state-2 (make-random-state random-state-1))) 401 | (gd-demo-picture file random-state-1 t) 402 | (gd-demo-picture file random-state-2))) 403 | 404 | (defun test-017 () 405 | (let ((file (test-file-location "zappa-ellipse" "png"))) 406 | (with-image* (250 150) 407 | (with-image-from-file (zappa (test-file-location "smallzappa" "png")) 408 | (setf (transparent-color) (allocate-color 255 255 255)) 409 | (draw-filled-ellipse 125 75 250 150 410 | :color (make-tile zappa))) 411 | (write-image-to-file file 412 | :if-exists :supersede)) 413 | (compare-files file))) 414 | 415 | (defun test-018 () 416 | (let (result) 417 | (with-image* (3 3) 418 | (allocate-color 255 255 255) 419 | (draw-line 0 0 2 2 :color (allocate-color 0 0 0)) 420 | (do-rows (y) 421 | (let (row) 422 | (do-pixels-in-row (x) 423 | (push (list x y (raw-pixel)) row)) 424 | (push (nreverse row) result)))) 425 | (equal 426 | (nreverse result) 427 | '(((0 0 1) (1 0 0) (2 0 0)) 428 | ((0 1 0) (1 1 1) (2 1 0)) 429 | ((0 2 0) (1 2 0) (2 2 1)))))) 430 | 431 | (defun test-019 () 432 | (let (result) 433 | (with-image* (3 3 t) 434 | (draw-rectangle* 0 0 2 2 :color (allocate-color 0 0 0)) 435 | (draw-line 0 0 2 2 :color (allocate-color 255 255 255)) 436 | (do-pixels () 437 | (unless (zerop (raw-pixel)) 438 | (decf (raw-pixel) #xff))) 439 | (do-rows (y) 440 | (let (row) 441 | (do-pixels-in-row (x) 442 | (push (list x y (raw-pixel)) row)) 443 | (push (nreverse row) result)))) 444 | (equal 445 | (nreverse result) 446 | '(((0 0 #xffff00) (1 0 0) (2 0 0)) 447 | ((0 1 0) (1 1 #xffff00) (2 1 0)) 448 | ((0 2 0) (1 2 0) (2 2 #xffff00)))))) 449 | 450 | (defun test-020 (georgia) 451 | ;; not used for test suite because of dependency on font 452 | (with-image* (200 200) 453 | ;; set background (white) and make it transparent 454 | (setf (transparent-color) 455 | (allocate-color 255 255 255)) 456 | (loop for angle from 0 to (* 2 pi) by (/ pi 6) 457 | for blue downfrom 255 by 20 do 458 | (draw-freetype-string 100 100 "Common Lisp" 459 | :font-name georgia 460 | :angle angle 461 | ;; note that ALLOCATE-COLOR won't work 462 | ;; here because the anti-aliasing uses 463 | ;; up too much colors 464 | :color (find-color 0 0 blue 465 | :resolve t))) 466 | (write-image-to-file (test-file-location "strings" "png") 467 | :if-exists :supersede))) 468 | 469 | (defun test% (georgia) 470 | (loop for i from 1 to (if georgia 20 19) do 471 | (handler-case 472 | (format t "Test ~A ~:[failed~;succeeded~].~%" i 473 | (let ((test-function 474 | (intern (format nil "TEST-~3,'0d" i) 475 | :cl-gd-test))) 476 | (if (= i 20) 477 | (funcall test-function georgia) 478 | (funcall test-function)))) 479 | (error (condition) 480 | (format t "Test ~A failed with the following error: ~A~%" 481 | i condition))) 482 | (force-output)) 483 | (format t "Done.~%")) 484 | 485 | (defun test (&optional georgia) 486 | #-:sbcl 487 | (test% georgia) 488 | #+:sbcl 489 | (handler-bind ((sb-ext:compiler-note #'muffle-warning)) 490 | (test% georgia))) -------------------------------------------------------------------------------- /cl-gd.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- 2 | ;;; $Header: /usr/local/cvsrep/gd/cl-gd.asd,v 1.20 2009/11/23 17:05:38 edi Exp $ 3 | 4 | ;;; Copyright (c) 2003-2009, Dr. Edmund Weitz. All rights reserved. 5 | 6 | ;;; Redistribution and use in source and binary forms, with or without 7 | ;;; modification, are permitted provided that the following conditions 8 | ;;; are met: 9 | 10 | ;;; * Redistributions of source code must retain the above copyright 11 | ;;; notice, this list of conditions and the following disclaimer. 12 | 13 | ;;; * Redistributions in binary form must reproduce the above 14 | ;;; copyright notice, this list of conditions and the following 15 | ;;; disclaimer in the documentation and/or other materials 16 | ;;; provided with the distribution. 17 | 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 19 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 22 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 24 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 25 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 26 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | (in-package :cl-user) 31 | 32 | (defpackage :cl-gd.system 33 | (:use :cl :asdf) 34 | (:export :*cl-gd-directory*)) 35 | 36 | (in-package :cl-gd.system) 37 | 38 | (defparameter *cl-gd-directory* 39 | (make-pathname :name nil :type nil :version nil 40 | :defaults (parse-namestring *load-truename*))) 41 | 42 | (defsystem :cl-gd 43 | :version "0.6.1" 44 | :serial t 45 | :description "Interface to the GD graphics library" 46 | :components ((:file "packages") 47 | (:file "util") 48 | (:file "specials") 49 | (:file "init") 50 | (:file "gd-uffi") 51 | (:file "transform") 52 | (:file "images") 53 | (:file "colors-aux") 54 | (:file "colors") 55 | (:file "drawing") 56 | (:file "strings") 57 | (:file "misc") 58 | (:file "animated-gif")) 59 | :depends-on (#-(or :clisp :openmcl) :uffi 60 | #+(or :clisp :openmcl) :cffi-uffi-compat)) 61 | -------------------------------------------------------------------------------- /colors-aux.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- 2 | ;;; $Header: /usr/local/cvsrep/gd/colors-aux.lisp,v 1.13 2009/11/23 17:05:38 edi Exp $ 3 | 4 | ;;; Copyright (c) 2003-2009, Dr. Edmund Weitz. All rights reserved. 5 | 6 | ;;; Redistribution and use in source and binary forms, with or without 7 | ;;; modification, are permitted provided that the following conditions 8 | ;;; are met: 9 | 10 | ;;; * Redistributions of source code must retain the above copyright 11 | ;;; notice, this list of conditions and the following disclaimer. 12 | 13 | ;;; * Redistributions in binary form must reproduce the above 14 | ;;; copyright notice, this list of conditions and the following 15 | ;;; disclaimer in the documentation and/or other materials 16 | ;;; provided with the distribution. 17 | 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 19 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 22 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 24 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 25 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 26 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | (in-package :cl-gd) 31 | 32 | (defun current-brush (&optional (image *default-image*)) 33 | "Returns the GD image which is the current brush of IMAGE \(or NIL 34 | if there is no current brush)." 35 | (check-type image image) 36 | (let ((brush (get-slot-value (img image) 'gd-image 'brush))) 37 | (if (null-pointer-p brush) 38 | nil 39 | brush))) 40 | 41 | (defun (setf current-brush) (brush &optional (image *default-image*)) 42 | "Sets BRUSH \(which must be a GD image) to be the current brush 43 | for IMAGE." 44 | (check-type brush image) 45 | (check-type image image) 46 | (gd-image-set-brush (img image) (img brush)) 47 | brush) 48 | 49 | (defun current-tile (&optional (image *default-image*)) 50 | "Returns the GD image which is the current tile of IMAGE \(or NIL 51 | if there is no current tile)." 52 | (check-type image image) 53 | (let ((tile (get-slot-value (img image) 'gd-image 'tile))) 54 | (if (null-pointer-p tile) 55 | nil 56 | tile))) 57 | 58 | (defun (setf current-tile) (tile &optional (image *default-image*)) 59 | "Sets TILE \(which must be a GD image) to be the current tile 60 | for IMAGE." 61 | (check-type tile (or image null)) 62 | (check-type image image) 63 | (gd-image-set-tile (img image) (img tile)) 64 | tile) 65 | 66 | (defun current-style (&optional (image *default-image*)) 67 | "Returns the current style of IMAGE as a list." 68 | (check-type image image) 69 | (let ((style-length (get-slot-value (img image) 'gd-image 'style-length)) 70 | (style (get-slot-value (img image) 'gd-image 'style))) 71 | (loop for i below style-length 72 | collect (let ((color (deref-array style '(:array :int) i))) 73 | (if (= color +transparent+) 74 | nil 75 | color))))) 76 | 77 | (defun current-style* (&key (image *default-image*)) 78 | "Returns the current style of IMAGE as an array." 79 | (check-type image image) 80 | (let ((style-length (get-slot-value (img image) 'gd-image 'style-length)) 81 | (style (get-slot-value (img image) 'gd-image 'style))) 82 | (loop with result = (make-array style-length) 83 | for i below style-length 84 | do (setf (aref result i) 85 | (let ((color (deref-array style '(:array :int) i))) 86 | (if (= color +transparent+) 87 | nil 88 | color))) 89 | finally (return result)))) 90 | 91 | (defgeneric (setf current-style) (style &optional image) 92 | (:documentation "Sets STYLE to be the current drawing style for 93 | IMAGE. STYLE can be a LIST or a VECTOR. Each element of STYLE is 94 | either a color or NIL \(for transparent pixels).")) 95 | 96 | (defmethod (setf current-style) ((style list) &optional (image *default-image*)) 97 | (check-type image image) 98 | (let ((length (length style))) 99 | (with-safe-alloc (c-style (allocate-foreign-object :int length) 100 | (free-foreign-object c-style)) 101 | (loop for color in style 102 | for i from 0 103 | do (setf (deref-array c-style '(:array :int) i) 104 | (typecase color 105 | (null +transparent+) 106 | (integer color) 107 | (t 1)))) 108 | (gd-image-set-style (img image) c-style length) 109 | style))) 110 | 111 | (defmethod (setf current-style) ((style vector) &optional (image *default-image*)) 112 | (check-type image image) 113 | (let ((length (length style))) 114 | (with-safe-alloc (c-style (allocate-foreign-object :int length) 115 | (free-foreign-object c-style)) 116 | (loop for color across style 117 | for i from 0 118 | do (setf (deref-array c-style '(:array :int) i) 119 | (typecase color 120 | (null +transparent+) 121 | (integer color) 122 | (t 1)))) 123 | (gd-image-set-style (img image) c-style length) 124 | style))) 125 | 126 | (defun set-anti-aliased (color do-not-blend &optional (image *default-image*)) 127 | "Set COLOR to be the current anti-aliased color of 128 | IMAGE. DO-NOT-BLEND \(if provided) is the background color 129 | anti-aliased lines stand out against clearly." 130 | (check-type color integer) 131 | (check-type do-not-blend (or integer null)) 132 | (check-type image image) 133 | (gd-image-set-anti-aliased-do-not-blend (img image) 134 | color 135 | (or do-not-blend -1))) 136 | 137 | (defun resolve-c-color (color image) 138 | "Accepts a CL-GD 'color' COLOR and returns the corresponding 139 | argument for GD, modifying internal slots of IMAGE if needed." 140 | (etypecase color 141 | (brush 142 | (setf (current-brush image) color) 143 | +brushed+) 144 | (tile 145 | (setf (current-tile image) color) 146 | +tiled+) 147 | ((cons brush (or vector list)) 148 | (setf (current-brush image) (car color) 149 | (current-style image) (cdr color)) 150 | +styled-brushed+) 151 | (anti-aliased-color 152 | (set-anti-aliased (color color) 153 | (do-not-blend color) 154 | image) 155 | +anti-aliased+) 156 | ((or vector list) 157 | (setf (current-style image) color) 158 | +styled+) 159 | (integer 160 | color))) 161 | 162 | (defmacro with-color-argument (&body body) 163 | "Internal macro used to give correct color arguments to enclosed 164 | foreign functions. Assumes fixed names COLOR and IMAGE." 165 | (with-unique-names (c-color-arg) 166 | `(let ((,c-color-arg (resolve-c-color color image))) 167 | ,@(sublis (list (cons 'color c-color-arg)) 168 | body :test #'eq)))) 169 | -------------------------------------------------------------------------------- /colors.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- 2 | ;;; $Header: /usr/local/cvsrep/gd/colors.lisp,v 1.26 2009/11/23 17:05:38 edi Exp $ 3 | 4 | ;;; Copyright (c) 2003-2009, Dr. Edmund Weitz. All rights reserved. 5 | 6 | ;;; Redistribution and use in source and binary forms, with or without 7 | ;;; modification, are permitted provided that the following conditions 8 | ;;; are met: 9 | 10 | ;;; * Redistributions of source code must retain the above copyright 11 | ;;; notice, this list of conditions and the following disclaimer. 12 | 13 | ;;; * Redistributions in binary form must reproduce the above 14 | ;;; copyright notice, this list of conditions and the following 15 | ;;; disclaimer in the documentation and/or other materials 16 | ;;; provided with the distribution. 17 | 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 19 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 22 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 24 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 25 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 26 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | (in-package :cl-gd) 31 | 32 | (defmacro with-default-color ((color) &body body) 33 | "Executes BODY with *DEFAULT-COLOR* bound to COLOR so that you don't 34 | have to provide the COLOR keyword/optional argument to drawing 35 | functions." 36 | `(let ((*default-color* ,color)) 37 | ,@body)) 38 | 39 | (defun allocate-color (red green blue &key alpha (errorp t) (image *default-image*)) 40 | "Finds the first available color index in the image IMAGE specified, 41 | sets its RGB values to those requested \(255 is the maximum for each), 42 | and returns the index of the new color table entry, or an RGBA value 43 | in the case of a true color image. In either case you can then use the 44 | returned value as a COLOR parameter to drawing functions. When 45 | creating a new palette-based image, the first time you invoke this 46 | function you are setting the background color for that image. If ALPHA 47 | \(not greater than 127) is provided, an RGBA color will always be 48 | allocated. If all +GD-MAX-COLORS+ have already been allocated this 49 | function will, depending on the value of ERRORP, either raise an error 50 | or return NIL." 51 | (check-type red integer) 52 | (check-type green integer) 53 | (check-type blue integer) 54 | (check-type alpha (or null integer)) 55 | (check-type image image) 56 | (let ((result 57 | (if alpha 58 | (gd-image-color-allocate-alpha (img image) red green blue alpha) 59 | (gd-image-color-allocate (img image) red green blue)))) 60 | (cond ((and errorp 61 | (= result -1)) 62 | (error "Can't allocate color")) 63 | ((= result -1) 64 | nil) 65 | (t 66 | result)))) 67 | 68 | (defun deallocate-color (color &optional (image *default-image*)) 69 | "Marks the specified color COLOR as being available for reuse. No 70 | attempt will be made to determine whether the color index is still in 71 | use in the image IMAGE." 72 | (check-type color integer) 73 | (check-type image image) 74 | (gd-image-color-deallocate (img image) color)) 75 | 76 | (defun transparent-color (&optional (image *default-image*)) 77 | "Returns the transparent color of IMAGE \(or NIL if there is none)." 78 | (check-type image image) 79 | (gd-image-get-transparent (img image))) 80 | 81 | (defun (setf transparent-color) (color &optional (image *default-image*)) 82 | "Makes COLOR the transparent color of IMAGE. If COLOR is NIL the 83 | image won't have a transparent color. Note that JPEG images don't 84 | support transparency." 85 | (check-type color (or null integer)) 86 | (check-type image image) 87 | (gd-image-color-transparent (img image) (or color -1)) 88 | color) 89 | 90 | (defun true-color-p (&optional (image *default-image*)) 91 | "Returns true iff IMAGE is a true color image." 92 | (check-type image image) 93 | (not (zerop (get-slot-value (img image) 'gd-image 'true-color)))) 94 | 95 | (defun number-of-colors (&key (image *default-image*)) 96 | "Returns the number of color allocated in IMAGE. Returns NIL if 97 | IMAGE is a true color image." 98 | (check-type image image) 99 | (if (true-color-p image) 100 | nil 101 | (get-slot-value (img image) 'gd-image 'colors-total))) 102 | 103 | (defun find-color (red green blue &key alpha exact hwb resolve (image *default-image*)) 104 | "Tries to find and/or allocate a color from IMAGE's color 105 | palette. If EXACT is true, the color will only be returned if it is 106 | already allocated. If EXACT is NIL, a color which is 'close' to the 107 | color specified by RED, GREEN, and BLUE \(and probably ALPHA) might be 108 | returned \(unless there aren't any colors allocated in the image 109 | yet). If HWB is true, the 'closeness' will be determined by hue, 110 | whiteness, and blackness, otherwise by the Euclidian distance of the 111 | RGB values. If RESOLVE is true a color \(probably a new one) will 112 | always be returned, otherwise the result of this function might be 113 | NIL. If ALPHA \(not greater than 127) is provided, an RGBA color (or 114 | NIL) will be returned. 115 | 116 | ALPHA, EXACT, and HWB are mutually exclusive. RESOLVE can't be used 117 | together with EXACT or HWB." 118 | (check-type red integer) 119 | (check-type green integer) 120 | (check-type blue integer) 121 | (check-type alpha (or null integer)) 122 | (check-type image image) 123 | (when (< 1 (count-if #'identity (list alpha exact hwb))) 124 | (error "You can't specify two of ALPHA, EXACT, and HWB at the same 125 | time")) 126 | (when (and hwb resolve) 127 | (error "You can't specify HWB and RESOLVE at the same time")) 128 | (when (and exact resolve) 129 | (error "You can't specify EXACT and RESOLVE at the same time")) 130 | (let ((result 131 | (cond ((and resolve alpha) 132 | (gd-image-color-resolve-alpha (img image) red green blue alpha)) 133 | (resolve 134 | (gd-image-color-resolve (img image) red green blue)) 135 | (alpha 136 | (gd-image-color-closest-alpha (img image) red green blue alpha)) 137 | (exact 138 | (gd-image-color-exact (img image) red green blue)) 139 | (hwb 140 | (gd-image-color-closest-hwb (img image) red green blue)) 141 | (t 142 | (gd-image-color-closest (img image) red green blue))))) 143 | (if (= result -1) 144 | nil 145 | result))) 146 | 147 | (defun thickness (&optional (image *default-image*)) 148 | "Gets the width of lines drawn by the drawing functions. Note that 149 | this is measured in pixels and is NOT affected by 150 | WITH-TRANSFORMATION." 151 | (check-type image image) 152 | (get-slot-value (img image) 'gd-image 'thick)) 153 | 154 | (defun (setf thickness) (thickness &optional (image *default-image*)) 155 | "Sets the width of lines drawn by the drawing functions. Note that 156 | THICKNESS is measured in pixels and is NOT affected by 157 | WITH-TRANSFORMATION." 158 | (check-type thickness integer) 159 | (check-type image image) 160 | (gd-image-set-thickness (img image) thickness) 161 | thickness) 162 | 163 | (defmacro with-thickness ((thickness &key (image '*default-image*)) &body body) 164 | "Executes BODY with the current line width of IMAGE set to 165 | THICKNESS. The image's previous line width is guaranteed to be 166 | restored before the macro exits. Note that the line width is measured 167 | in pixels and is not affected by WITH-TRANSFORMATION." 168 | (with-unique-names (old-thickness) 169 | ;; we rebind everything so we have left-to-right evaluation 170 | (with-rebinding (thickness image) 171 | `(let ((,old-thickness (thickness ,image))) 172 | (unwind-protect 173 | (progn 174 | (setf (thickness ,image) ,thickness)) 175 | ,@body) 176 | (setf (thickness ,image) ,old-thickness))))) 177 | 178 | (defun alpha-blending-p (&optional (image *default-image*)) 179 | "Returns whether pixels drawn on IMAGE will be copied literally 180 | including alpha channel information \(return value is false) or if 181 | their alpha channel information will determine how much of the 182 | underlying color will shine through \(return value is true). This is 183 | only meaningful for true color images." 184 | (check-type image image) 185 | (not (zerop (get-slot-value (img image) 'gd-image 'alpha-blending-flag)))) 186 | 187 | (defun (setf alpha-blending-p) (blending &optional (image *default-image*)) 188 | "Determines whether pixels drawn on IMAGE will be copied literally 189 | including alpha channel information \(if BLENDING is false) or if 190 | their alpha channel information will determine how much of the 191 | underlying color will shine through \(if BLENDING is true). This is 192 | only meaningful for true color images." 193 | (check-type image image) 194 | (gd-image-alpha-blending (img image) (if blending 1 0)) 195 | blending) 196 | 197 | (defun save-alpha-p (&optional (image *default-image*)) 198 | "Returns whether PNG images will be saved with full alpha channel 199 | information." 200 | (check-type image image) 201 | (not (zerop (get-slot-value (img image) 'gd-image 'save-alpha-flag)))) 202 | 203 | (defun (setf save-alpha-p) (save &optional (image *default-image*)) 204 | "Determines whether PNG images will be saved with full alpha channel 205 | information." 206 | (check-type image image) 207 | (gd-image-save-alpha (img image) (if save 1 0)) 208 | save) 209 | 210 | (defun color-component (component color &key (image *default-image*)) 211 | "Returns the specified color component of COLOR. COMPONENT can be 212 | one of :RED, :GREEN, :BLUE, and :ALPHA." 213 | (check-type color integer) 214 | (check-type image image) 215 | (funcall (ecase component 216 | ((:red) #'gd-image-get-red) 217 | ((:green) #'gd-image-get-green) 218 | ((:blue) #'gd-image-get-blue) 219 | ((:alpha) #'gd-image-get-alpha)) 220 | (img image) 221 | color)) 222 | 223 | (defun color-components (color &key (image *default-image*)) 224 | "Returns a list of the color components of COLOR. The 225 | components are in the order red, green, blue, alpha." 226 | (mapcar #'(lambda (c) (color-component c color :image image)) 227 | '(:red :green :blue :alpha))) 228 | 229 | (defun find-color-from-image (color source-image &key alpha exact hwb 230 | resolve (image *default-image*)) 231 | "Returns the color in IMAGE corresponding to COLOR in 232 | SOURCE-IMAGE. The keyword parameters are passed to FIND-COLOR." 233 | (let ((red (color-component :red color 234 | :image source-image)) 235 | (blue (color-component :blue color 236 | :image source-image)) 237 | (green (color-component :green color 238 | :image source-image)) 239 | (alpha (when alpha 240 | (color-component :alpha color 241 | :image source-image)))) 242 | (find-color red green blue 243 | :alpha alpha 244 | :exact exact 245 | :hwb hwb 246 | :resolve resolve 247 | :image image))) 248 | -------------------------------------------------------------------------------- /docs/anti-aliased-lines.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/docs/anti-aliased-lines.png -------------------------------------------------------------------------------- /docs/brushed-arc.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/docs/brushed-arc.png -------------------------------------------------------------------------------- /docs/chart.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/docs/chart.png -------------------------------------------------------------------------------- /docs/clipped-tangent.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/docs/clipped-tangent.png -------------------------------------------------------------------------------- /docs/demooutp.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/docs/demooutp.png -------------------------------------------------------------------------------- /docs/gddemo.c: -------------------------------------------------------------------------------- 1 | 2 | #ifdef HAVE_CONFIG_H 3 | #include "config.h" 4 | #endif 5 | 6 | #include 7 | #include 8 | #include 9 | #include "gd.h" 10 | #include "gdfontg.h" 11 | #include "gdfonts.h" 12 | 13 | int 14 | main (void) 15 | { 16 | #ifdef HAVE_LIBPNG 17 | /* Input and output files */ 18 | FILE *in; 19 | FILE *out; 20 | 21 | /* Input and output images */ 22 | gdImagePtr im_in = 0, im_out = 0; 23 | 24 | /* Brush image */ 25 | gdImagePtr brush; 26 | 27 | /* Color indexes */ 28 | int white; 29 | int blue; 30 | int red; 31 | int green; 32 | 33 | /* Points for polygon */ 34 | gdPoint points[3]; 35 | int i; 36 | 37 | /* Create output image, in true color. */ 38 | im_out = gdImageCreateTrueColor (256 + 384, 384); 39 | /* 2.0.2: first color allocated would automatically be background in a 40 | palette based image. Since this is a truecolor image, with an 41 | automatic background of black, we must fill it explicitly. */ 42 | white = gdImageColorAllocate (im_out, 255, 255, 255); 43 | gdImageFilledRectangle (im_out, 0, 0, gdImageSX (im_out), 44 | gdImageSY (im_out), white); 45 | 46 | /* Set transparent color. */ 47 | gdImageColorTransparent (im_out, white); 48 | 49 | /* Try to load demoin.png and paste part of it into the 50 | output image. */ 51 | in = fopen ("demoin.png", "rb"); 52 | if (!in) 53 | { 54 | fprintf (stderr, "Can't load source image; this demo\n"); 55 | fprintf (stderr, "is much more impressive if demoin.png\n"); 56 | fprintf (stderr, "is available.\n"); 57 | im_in = 0; 58 | } 59 | else 60 | { 61 | int a; 62 | im_in = gdImageCreateFromPng (in); 63 | fclose (in); 64 | /* Now copy, and magnify as we do so */ 65 | gdImageCopyResampled (im_out, im_in, 32, 32, 0, 0, 192, 192, 255, 255); 66 | /* Now display variously rotated space shuttles in a circle of our own */ 67 | for (a = 0; (a < 360); a += 45) 68 | { 69 | int cx = cos (a * .0174532925) * 128; 70 | int cy = -sin (a * .0174532925) * 128; 71 | gdImageCopyRotated (im_out, im_in, 72 | 256 + 192 + cx, 192 + cy, 73 | 0, 0, gdImageSX (im_in), gdImageSY (im_in), a); 74 | } 75 | } 76 | red = gdImageColorAllocate (im_out, 255, 0, 0); 77 | green = gdImageColorAllocate (im_out, 0, 255, 0); 78 | blue = gdImageColorAllocate (im_out, 0, 0, 255); 79 | /* Fat Rectangle */ 80 | gdImageSetThickness (im_out, 4); 81 | gdImageLine (im_out, 16, 16, 240, 16, green); 82 | gdImageLine (im_out, 240, 16, 240, 240, green); 83 | gdImageLine (im_out, 240, 240, 16, 240, green); 84 | gdImageLine (im_out, 16, 240, 16, 16, green); 85 | gdImageSetThickness (im_out, 1); 86 | /* Circle */ 87 | gdImageArc (im_out, 128, 128, 60, 20, 0, 720, blue); 88 | /* Arc */ 89 | gdImageArc (im_out, 128, 128, 40, 40, 90, 270, blue); 90 | /* Flood fill: doesn't do much on a continuously 91 | variable tone jpeg original. */ 92 | gdImageFill (im_out, 8, 8, blue); 93 | /* Polygon */ 94 | points[0].x = 64; 95 | points[0].y = 0; 96 | points[1].x = 0; 97 | points[1].y = 128; 98 | points[2].x = 128; 99 | points[2].y = 128; 100 | gdImageFilledPolygon (im_out, points, 3, green); 101 | /* 2.0.12: Antialiased Polygon */ 102 | gdImageSetAntiAliased (im_out, green); 103 | for (i = 0; (i < 3); i++) 104 | { 105 | points[i].x += 128; 106 | } 107 | gdImageFilledPolygon (im_out, points, 3, gdAntiAliased); 108 | /* Brush. A fairly wild example also involving a line style! */ 109 | if (im_in) 110 | { 111 | int style[8]; 112 | brush = gdImageCreateTrueColor (16, 16); 113 | gdImageCopyResized (brush, im_in, 114 | 0, 0, 0, 0, 115 | gdImageSX (brush), gdImageSY (brush), 116 | gdImageSX (im_in), gdImageSY (im_in)); 117 | gdImageSetBrush (im_out, brush); 118 | /* With a style, so they won't overprint each other. 119 | Normally, they would, yielding a fat-brush effect. */ 120 | style[0] = 0; 121 | style[1] = 0; 122 | style[2] = 0; 123 | style[3] = 0; 124 | style[4] = 0; 125 | style[5] = 0; 126 | style[6] = 0; 127 | style[7] = 1; 128 | gdImageSetStyle (im_out, style, 8); 129 | /* Draw the styled, brushed line */ 130 | gdImageLine (im_out, 0, 255, 255, 0, gdStyledBrushed); 131 | } 132 | /* Text (non-truetype; see gdtestft for a freetype demo) */ 133 | gdImageString (im_out, gdFontGiant, 32, 32, (unsigned char *) "hi", red); 134 | gdImageStringUp (im_out, gdFontSmall, 64, 64, (unsigned char *) "hi", red); 135 | /* Random antialiased lines; coordinates all over the image, 136 | but the output will respect a small clipping rectangle */ 137 | gdImageSetClip(im_out, 0, gdImageSY(im_out) - 100, 138 | 100, gdImageSY(im_out)); 139 | /* Fixed seed for reproducibility of results */ 140 | srand(100); 141 | for (i = 0; (i < 100); i++) { 142 | int x1 = rand() % gdImageSX(im_out); 143 | int y1 = rand() % gdImageSY(im_out); 144 | int x2 = rand() % gdImageSX(im_out); 145 | int y2 = rand() % gdImageSY(im_out); 146 | gdImageSetAntiAliased(im_out, white); 147 | gdImageLine (im_out, x1, y1, x2, y2, gdAntiAliased); 148 | } 149 | /* Make output image interlaced (progressive, in the case of JPEG) */ 150 | gdImageInterlace (im_out, 1); 151 | out = fopen ("demoout.png", "wb"); 152 | /* Write PNG */ 153 | gdImagePng (im_out, out); 154 | fclose (out); 155 | /* 2.0.12: also write a paletteized version */ 156 | out = fopen ("demooutp.png", "wb"); 157 | gdImageTrueColorToPalette (im_out, 0, 256); 158 | gdImagePng (im_out, out); 159 | fclose (out); 160 | gdImageDestroy (im_out); 161 | if (im_in) 162 | { 163 | gdImageDestroy (im_in); 164 | } 165 | #else 166 | fprintf (stderr, "No PNG library support.\n"); 167 | #endif /* HAVE_LIBPNG */ 168 | return 0; 169 | } 170 | -------------------------------------------------------------------------------- /docs/smallzappa.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/docs/smallzappa.png -------------------------------------------------------------------------------- /docs/strings.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/docs/strings.png -------------------------------------------------------------------------------- /docs/triangle.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/docs/triangle.png -------------------------------------------------------------------------------- /docs/zappa-ellipse.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/docs/zappa-ellipse.png -------------------------------------------------------------------------------- /docs/zappa-green.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/docs/zappa-green.jpg -------------------------------------------------------------------------------- /docs/zappa.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/docs/zappa.jpg -------------------------------------------------------------------------------- /drawing.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- 2 | ;;; $Header: /usr/local/cvsrep/gd/drawing.lisp,v 1.29 2009/11/23 17:05:38 edi Exp $ 3 | 4 | ;;; Copyright (c) 2003-2009, Dr. Edmund Weitz. All rights reserved. 5 | 6 | ;;; Redistribution and use in source and binary forms, with or without 7 | ;;; modification, are permitted provided that the following conditions 8 | ;;; are met: 9 | 10 | ;;; * Redistributions of source code must retain the above copyright 11 | ;;; notice, this list of conditions and the following disclaimer. 12 | 13 | ;;; * Redistributions in binary form must reproduce the above 14 | ;;; copyright notice, this list of conditions and the following 15 | ;;; disclaimer in the documentation and/or other materials 16 | ;;; provided with the distribution. 17 | 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 19 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 22 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 24 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 25 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 26 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | (in-package :cl-gd) 31 | 32 | (defun get-pixel (x y &key (image *default-image*)) 33 | "Gets the color associated with point \(X,Y)." 34 | (check-type image image) 35 | (with-transformed-alternative 36 | ((x x-transformer) 37 | (y y-transformer)) 38 | (gd-image-get-pixel (img image) x y))) 39 | 40 | (defun set-pixel (x y &key (color *default-color*) (image *default-image*)) 41 | "Draws a pixel with color COLOR at point \(X,Y)." 42 | (check-type image image) 43 | (with-color-argument 44 | (with-transformed-alternative 45 | ((x x-transformer) 46 | (y y-transformer)) 47 | (gd-image-set-pixel (img image) x y color))) 48 | (values x y)) 49 | 50 | (defgeneric set-pixels (points &key color image) 51 | (:documentation "Draws a list \(X1 Y1 X2 Y2 ...) or vector #\(X1 Y1 52 | X2 Y2 ...) of pixels.")) 53 | 54 | (defmethod set-pixels ((points list) &key (color *default-color*) (image *default-image*)) 55 | (check-type image image) 56 | (unless (evenp (length points)) 57 | (error "List ~S must have an even number of elements" 58 | points)) 59 | (loop with img = (img image) 60 | for (x y) on points by #'cddr do 61 | (check-type x integer) 62 | (check-type y integer) 63 | (with-transformed-alternative 64 | ((x x-transformer) 65 | (y y-transformer)) 66 | (gd-image-set-pixel img x y color)) 67 | finally (return image))) 68 | 69 | (defmethod set-pixels ((points vector) &key (color *default-color*) (image *default-image*)) 70 | (check-type image image) 71 | (let ((length (length points))) 72 | (unless (evenp length) 73 | (error "List ~S must have an even number of elements" 74 | points)) 75 | (loop with img = (img image) 76 | for i below length by 2 do 77 | (check-type (aref points i) integer) 78 | (check-type (aref points (1+ i)) integer) 79 | (with-transformed-alternative 80 | (((aref points i) x-transformer) 81 | ((aref points (1+ i)) y-transformer)) 82 | (gd-image-set-pixel img 83 | (aref points i) 84 | (aref points (1+ i)) 85 | color)) 86 | finally (return image)))) 87 | 88 | (defun draw-line (x1 y1 x2 y2 &key (color *default-color*) (image *default-image*)) 89 | "Draws a line with color COLOR from point \(X1,Y1) to point \(X2,Y2)." 90 | (check-type image image) 91 | (with-color-argument 92 | (with-transformed-alternative 93 | ((x1 x-transformer) 94 | (y1 y-transformer) 95 | (x2 x-transformer) 96 | (y2 y-transformer)) 97 | (gd-image-line (img image) x1 y1 x2 y2 color))) 98 | (values x1 y1 x2 y2)) 99 | 100 | (defun draw-rectangle* (x1 y1 x2 y2 &key filled (color *default-color*) (image *default-image*)) 101 | "Draws a rectangle with upper left corner \(X1,Y1) and lower right 102 | corner \(X2,Y2). If FILLED is true the rectangle will be filled with 103 | COLOR, otherwise it will be outlined." 104 | (check-type image image) 105 | (with-color-argument 106 | (with-transformed-alternative 107 | ((x1 x-transformer) 108 | (y1 y-transformer) 109 | (x2 x-transformer) 110 | (y2 y-transformer)) 111 | (if filled 112 | (gd-image-filled-rectangle (img image) x1 y1 x2 y2 color) 113 | (gd-image-rectangle (img image) x1 y1 x2 y2 color)))) 114 | (values x1 y1 x2 y2)) 115 | 116 | (defun draw-rectangle (rectangle &key filled (color *default-color*) (image *default-image*)) 117 | "Draws a rectangle with upper left corner \(X1,Y1) and lower right 118 | corner \(X2,Y2) where RECTANGLE is the list \(X1 Y1 X2 Y2). If FILLED 119 | is true the rectangle will be filled with COLOR, otherwise it will be 120 | outlined." 121 | (draw-rectangle* (first rectangle) 122 | (second rectangle) 123 | (third rectangle) 124 | (fourth rectangle) 125 | :filled filled 126 | :color color 127 | :image image) 128 | rectangle) 129 | 130 | (defgeneric draw-polygon (vertices &key filled start end color image) 131 | (:documentation "Draws a polygon with the VERTICES \(at least three) 132 | specified as a list \(x1 y1 x2 y2 ...) or as a vector #\(x1 y1 x2 y2 133 | ...). If FILLED is true the polygon will be filled with COLOR, 134 | otherwise it will be outlined. If START and/or END are specified then 135 | only the corresponding part of VERTICES is used as input.")) 136 | 137 | (defmethod draw-polygon ((vertices vector) &key filled (start 0) (end (length vertices)) (color *default-color*) (image *default-image*)) 138 | (check-type start integer) 139 | (check-type end integer) 140 | (check-type image image) 141 | (let ((effective-length (- end start))) 142 | (unless (and (>= effective-length 6) 143 | (evenp effective-length)) 144 | (error "We need an even number of at least six vertices")) 145 | (with-safe-alloc (arr (allocate-foreign-object 'gd-point (/ effective-length 2)) 146 | (free-foreign-object arr)) 147 | (with-color-argument 148 | (with-transformed-alternative 149 | (((aref vertices i) x-transformer) 150 | ((aref vertices (1+ i)) y-transformer)) 151 | (loop for i from start below end by 2 152 | for point-ptr = (deref-array arr '(:array gd-point) (/ (- i start) 2)) 153 | do (setf (get-slot-value point-ptr 'gd-point 'x) 154 | (aref vertices i) 155 | (get-slot-value point-ptr 'gd-point 'y) 156 | (aref vertices (1+ i)))) 157 | (funcall (if filled 158 | #'gd-image-filled-polygon 159 | #'gd-image-polygon) 160 | (img image) arr (/ effective-length 2) color) 161 | vertices))))) 162 | 163 | (defmethod draw-polygon ((vertices list) &key filled (start 0) (end (length vertices)) (color *default-color*) (image *default-image*)) 164 | (check-type start integer) 165 | (check-type end integer) 166 | (check-type image image) 167 | (let ((effective-length (- end start))) 168 | (unless (and (>= effective-length 6) 169 | (evenp effective-length)) 170 | (error "We need an even number of at least six vertices")) 171 | (with-safe-alloc (arr (allocate-foreign-object 'gd-point (/ effective-length 2)) 172 | (free-foreign-object arr)) 173 | (with-color-argument 174 | (with-transformed-alternative 175 | (((first x/y) x-transformer) 176 | ((second x/y) y-transformer)) 177 | (loop for i below (- end start) by 2 178 | ;; we don't use LOOP's destructuring capabilities here 179 | ;; because of your simple WITH-TRANSFORMED-ALTERNATIVE 180 | ;; macro which would get confused 181 | for x/y on (nthcdr start vertices) by #'cddr 182 | for point-ptr = (deref-array arr '(:array gd-point) (/ i 2)) 183 | do (setf (get-slot-value point-ptr 'gd-point 'x) 184 | (first x/y) 185 | (get-slot-value point-ptr 'gd-point 'y) 186 | (second x/y))) 187 | (funcall (if filled 188 | #'gd-image-filled-polygon 189 | #'gd-image-polygon) 190 | (img image) arr (/ effective-length 2) color) 191 | vertices))))) 192 | 193 | (defun draw-filled-ellipse (center-x center-y width height &key (color *default-color*) (image *default-image*)) 194 | "Draws a filled ellipse centered at \(CENTER-X, CENTER-Y) with width 195 | WIDTH and height HEIGHT." 196 | (check-type image image) 197 | (with-color-argument 198 | (with-transformed-alternative 199 | ((center-x x-transformer) 200 | (center-y y-transformer) 201 | (width w-transformer) 202 | (height h-transformer)) 203 | (gd-image-filled-ellipse (img image) center-x center-y width height color))) 204 | (values center-x center-y width height)) 205 | 206 | (defun draw-filled-circle (center-x center-y radius &key (color *default-color*) (image *default-image*)) 207 | "Draws a filled circle centered at \(CENTER-X, CENTER-Y) with radius 208 | RADIUS." 209 | (draw-filled-ellipse center-x center-y (* 2 radius) (* 2 radius) 210 | :color color :image image) 211 | (values center-x center-y radius)) 212 | 213 | (defun draw-arc (center-x center-y width height start end &key straight-line center-connect filled (color *default-color*) (image *default-image*)) 214 | "Draws a partial ellipse centered at \(CENTER-X, CENTER-Y) with 215 | width WIDTH and height HEIGHT. The arc begins at angle START and ends 216 | at angle END. If STRAIGHT-LINE is true the start and end points are 217 | just connected with a straight line. If CENTER-CONNECT is true, they 218 | are connected to the center \(which is useful to create 'pie 219 | slices'). If FILLED is true the arc will be filled with COLOR, 220 | otherwise it will be outlined." 221 | (check-type image image) 222 | (with-color-argument 223 | (with-transformed-alternative 224 | ((center-x x-transformer) 225 | (center-y y-transformer) 226 | (width w-transformer) 227 | (height h-transformer) 228 | (start angle-transformer) 229 | (end angle-transformer)) 230 | (cond ((not (or straight-line filled center-connect)) 231 | (gd-image-arc (img image) center-x center-y width height start end color)) 232 | (t 233 | (gd-image-filled-arc (img image) center-x center-y width height start end color 234 | (logior (if straight-line +gd-chord+ 0) 235 | (if filled 0 +gd-no-fill+) 236 | (if center-connect +gd-edged+ 0))))))) 237 | (values center-x center-y width height start end)) 238 | 239 | (defun fill-image (x y &key border (color *default-color*) (image *default-image*)) 240 | "Floods a portion of the image IMAGE with the color COLOR beginning 241 | at point \(X, Y) and extending into the surrounding region. If BORDER 242 | is true it must be a color and the filling will stop at the specified 243 | border color. Otherwise only points with the same color as the 244 | starting point will be colored." 245 | (check-type border (or null integer)) 246 | (check-type image image) 247 | (with-color-argument 248 | (with-transformed-alternative 249 | ((x x-transformer) 250 | (y y-transformer)) 251 | (if border 252 | (gd-image-fill-to-border (img image) x y border color) 253 | (gd-image-fill (img image) x y color)))) 254 | (values x y)) 255 | 256 | (defun clipping-rectangle (&optional (image *default-image*)) 257 | "Returns the clipping rectangle of IMAGE as a list of four 258 | elements." 259 | (check-type image image) 260 | (with-transformed-alternative 261 | (((deref-pointer x1p) x-inv-transformer) 262 | ((deref-pointer y1p) y-inv-transformer) 263 | ((deref-pointer x2p) x-inv-transformer) 264 | ((deref-pointer y2p) y-inv-transformer)) 265 | (with-foreign-object (x1p :int) 266 | (with-foreign-object (y1p :int) 267 | (with-foreign-object (x2p :int) 268 | (with-foreign-object (y2p :int) 269 | (gd-image-get-clip (img image) x1p y1p x2p y2p) 270 | (list (deref-pointer x1p :int) 271 | (deref-pointer y1p :int) 272 | (deref-pointer x2p :int) 273 | (deref-pointer y2p :int)))))))) 274 | 275 | (defun (setf clipping-rectangle) (rectangle &optional (image *default-image*)) 276 | "Sets the clipping rectangle of IMAGE where rectangle should be a 277 | list \(X1 Y1 X2 Y2)." 278 | (check-type image image) 279 | (with-transformed-alternative 280 | (((first rectangle) x-transformer) 281 | ((second rectangle) y-transformer) 282 | ((third rectangle) x-transformer) 283 | ((fourth rectangle) y-transformer)) 284 | (gd-image-set-clip (img image) 285 | (first rectangle) 286 | (second rectangle) 287 | (third rectangle) 288 | (fourth rectangle))) 289 | rectangle) 290 | 291 | (defun clipping-rectangle* (&optional (image *default-image*)) 292 | "Returns the clipping rectangle of IMAGE as four values." 293 | (check-type image image) 294 | (with-transformed-alternative 295 | (((deref-pointer x1p) x-inv-transformer) 296 | ((deref-pointer y1p) y-inv-transformer) 297 | ((deref-pointer x2p) x-inv-transformer) 298 | ((deref-pointer y2p) y-inv-transformer)) 299 | (with-foreign-object (x1p :int) 300 | (with-foreign-object (y1p :int) 301 | (with-foreign-object (x2p :int) 302 | (with-foreign-object (y2p :int) 303 | (gd-image-get-clip (img image) x1p y1p x2p y2p) 304 | (values (deref-pointer x1p :int) 305 | (deref-pointer y1p :int) 306 | (deref-pointer x2p :int) 307 | (deref-pointer y2p :int)))))))) 308 | 309 | (defun set-clipping-rectangle* (x1 y1 x2 y2 &optional (image *default-image*)) 310 | "Sets the clipping rectangle of IMAGE to be the rectangle with upper 311 | left corner \(X1, Y1) and lower right corner \(X2, Y2)." 312 | (check-type image image) 313 | (with-transformed-alternative 314 | ((x1 x-transformer) 315 | (y1 y-transformer) 316 | (x2 x-transformer) 317 | (y2 y-transformer)) 318 | (gd-image-set-clip (img image) x1 y1 x2 y2)) 319 | (values x1 y1 x2 y2)) 320 | 321 | (defmacro with-clipping-rectangle ((rectangle &key (image '*default-image*)) &body body) 322 | "Executes BODY with the clipping rectangle of IMAGE set to RECTANGLE 323 | which should be a list \(X1 Y1 X2 Y2). The previous clipping rectangle 324 | is guaranteed to be restored before the macro exits." 325 | ;; we rebind everything so we have left-to-right evaluation 326 | (with-rebinding (rectangle image) 327 | (with-unique-names (%x1 %y1 %x2 %y2) 328 | `(multiple-value-bind (,%x1 ,%y1 ,%x2 ,%y2) 329 | (without-transformations 330 | (clipping-rectangle* ,image)) 331 | (unwind-protect 332 | (progn 333 | (setf (clipping-rectangle ,image) ,rectangle) 334 | ,@body) 335 | (without-transformations 336 | (set-clipping-rectangle* ,%x1 ,%y1 ,%x2 ,%y2 ,image))))))) 337 | 338 | (defmacro with-clipping-rectangle* ((x1 y1 x2 y2 &key (image '*default-image*)) &body body) 339 | "Executes BODY with the clipping rectangle of IMAGE set to the 340 | rectangle with upper left corner \(X1, Y1) and lower right corner 341 | \(X2, Y2). The previous clipping rectangle is guaranteed to be 342 | restored before the macro exits." 343 | ;; we rebind everything so we have left-to-right evaluation 344 | (with-rebinding (x1 y1 x2 y2 image) 345 | (with-unique-names (%x1 %y1 %x2 %y2) 346 | `(multiple-value-bind (,%x1 ,%y1 ,%x2 ,%y2) 347 | (without-transformations 348 | (clipping-rectangle* ,image)) 349 | (unwind-protect 350 | (progn 351 | (set-clipping-rectangle* ,x1 ,y1 ,x2 ,y2 ,image) 352 | ,@body) 353 | (without-transformations 354 | (set-clipping-rectangle* ,%x1 ,%y1 ,%x2 ,%y2 ,image))))))) 355 | -------------------------------------------------------------------------------- /gd-uffi.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- 2 | ;;; $Header: /usr/local/cvsrep/gd/gd-uffi.lisp,v 1.33 2009/11/23 17:05:39 edi Exp $ 3 | 4 | ;;; Copyright (c) 2003-2009, Dr. Edmund Weitz. All rights reserved. 5 | 6 | ;;; Redistribution and use in source and binary forms, with or without 7 | ;;; modification, are permitted provided that the following conditions 8 | ;;; are met: 9 | 10 | ;;; * Redistributions of source code must retain the above copyright 11 | ;;; notice, this list of conditions and the following disclaimer. 12 | 13 | ;;; * Redistributions in binary form must reproduce the above 14 | ;;; copyright notice, this list of conditions and the following 15 | ;;; disclaimer in the documentation and/or other materials 16 | ;;; provided with the distribution. 17 | 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 19 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 22 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 24 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 25 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 26 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | (in-package :cl-gd) 31 | 32 | ;; internal representation of an image in GD 33 | (def-struct gd-image 34 | (pixels (* (* :unsigned-char))) 35 | (sx :int) 36 | (sy :int) 37 | (colors-total :int) 38 | (red (:array :int #.+max-colors+)) 39 | (green (:array :int #.+max-colors+)) 40 | (blue (:array :int #.+max-colors+)) 41 | (open (:array :int #.+max-colors+)) 42 | (transparent :int) 43 | (poly-ints (* :int)) 44 | (poly-allocated :int) 45 | (brush :pointer-self) 46 | (tile :pointer-self) 47 | (brush-color-map (:array :int #.+max-colors+)) 48 | (tile-color-map (:array :int #.+max-colors+)) 49 | (style-length :int) 50 | (style-pos :int) 51 | (style (* :int)) 52 | (interface :int) 53 | (thick :int) 54 | (alpha (:array :int #.+max-colors+)) 55 | (true-color :int) 56 | (t-pixels (* (* :int))) 57 | (alpha-blending-flag :int) 58 | (save-alpha-flag :int) 59 | (aa :int) 60 | (aa-color :int) 61 | (aa-do-not-blend :int) 62 | (aa-opacity (* (* :unsigned-char))) 63 | (aa-polygon :int) 64 | (aal-x1 :int) 65 | (aal-y1 :int) 66 | (aal-x2 :int) 67 | (aal-y2 :int) 68 | (aal-bx-ax :int) 69 | (aal-by-ay :int) 70 | (aal-lab-2 :int) 71 | (aal-lab :float) 72 | (cx1 :int) 73 | (cy1 :int) 74 | (cx2 :int) 75 | (cy2 :int)) 76 | 77 | (def-type pixels-array (* (* :unsigned-char))) 78 | (def-type pixels-row (* :unsigned-char)) 79 | (def-type t-pixels-array (* (* :int))) 80 | (def-type t-pixels-row (* :int)) 81 | 82 | (def-foreign-type gd-image-ptr (* gd-image)) 83 | 84 | ;; initialize special variable 85 | (setq *null-image* (make-image (make-null-pointer 'gd-image))) 86 | 87 | ;; internal representation of a point in GD, used by the polygon 88 | ;; functions 89 | (def-struct gd-point 90 | (x :int) 91 | (y :int)) 92 | 93 | (def-foreign-type gd-point-ptr (* gd-point)) 94 | 95 | ;; internal representation of a font in GD, used by the (non-FreeType) 96 | ;; functions which draw characters and strings 97 | (def-struct gd-font 98 | (nchars :int) 99 | (offset :int) 100 | (w :int) 101 | (h :int) 102 | (data (* :char))) 103 | 104 | (def-foreign-type gd-font-ptr (* gd-font)) 105 | 106 | ;; additional info for calls to the FreeType library - currently only 107 | ;; used for line spacing 108 | (def-struct gd-ft-string-extra 109 | (flags :int) 110 | (line-spacing :double) 111 | (charmap :int)) 112 | 113 | (def-foreign-type gd-ft-string-extra-ptr (* gd-ft-string-extra)) 114 | 115 | ;; the GD standard fonts used when drawing characters or strings 116 | ;; without invoking the FreeType library 117 | (def-foreign-var ("gdFontTiny" +gd-font-tiny+) gd-font-ptr "gd") 118 | (def-foreign-var ("gdFontSmall" +gd-font-small+) gd-font-ptr "gd") 119 | (def-foreign-var ("gdFontMediumBold" +gd-font-medium-bold+) gd-font-ptr "gd") 120 | (def-foreign-var ("gdFontLarge" +gd-font-large+) gd-font-ptr "gd") 121 | (def-foreign-var ("gdFontGiant" +gd-font-giant+) gd-font-ptr "gd") 122 | 123 | ;;; all GD functions which are accessed from CL-GD 124 | 125 | (def-function ("gdImageCreate" gd-image-create) 126 | ((sx :int) 127 | (sy :int)) 128 | :returning gd-image-ptr 129 | :module "gd") 130 | 131 | (def-function ("gdImageCreateTrueColor" gd-image-create-true-color) 132 | ((sx :int) 133 | (sy :int)) 134 | :returning gd-image-ptr 135 | :module "gd") 136 | 137 | (def-function ("gdImageCreateFromJpegFile" gd-image-create-from-jpeg-file) 138 | ((filename :cstring) 139 | (err (* :int))) 140 | :returning gd-image-ptr 141 | :module "gd") 142 | 143 | (def-function ("gdImageCreateFromPngFile" gd-image-create-from-png-file) 144 | ((filename :cstring) 145 | (err (* :int))) 146 | :returning gd-image-ptr 147 | :module "gd") 148 | 149 | (def-function ("gdImageCreateFromGdFile" gd-image-create-from-gd-file) 150 | ((filename :cstring) 151 | (err (* :int))) 152 | :returning gd-image-ptr 153 | :module "gd") 154 | 155 | (def-function ("gdImageCreateFromGd2File" gd-image-create-from-gd2-file) 156 | ((filename :cstring) 157 | (err (* :int))) 158 | :returning gd-image-ptr 159 | :module "gd") 160 | 161 | (def-function ("gdImageCreateFromGd2PartFile" gd-image-create-from-gd2-part-file) 162 | ((filename :cstring) 163 | (err (* :int)) 164 | (src-x :int) 165 | (src-y :int) 166 | (w :int) 167 | (h :int)) 168 | :returning gd-image-ptr 169 | :module "gd") 170 | 171 | (def-function ("gdImageCreateFromXbmFile" gd-image-create-from-xbm-file) 172 | ((filename :cstring) 173 | (err (* :int))) 174 | :returning gd-image-ptr 175 | :module "gd") 176 | 177 | #-:win32 178 | (def-function ("gdImageCreateFromXpm" gd-image-create-from-xpm) 179 | ((filename :cstring)) 180 | :returning gd-image-ptr 181 | :module "gd") 182 | 183 | #-:cl-gd-no-gif 184 | (def-function ("gdImageCreateFromGifFile" gd-image-create-from-gif-file) 185 | ((filename :cstring) 186 | (err (* :int))) 187 | :returning gd-image-ptr 188 | :module "gd") 189 | 190 | (def-function ("gdImageJpegPtr" gd-image-jpeg-ptr) 191 | ((im gd-image-ptr) 192 | (size (* :int)) 193 | (quality :int)) 194 | :returning :pointer-void 195 | :module "gd") 196 | 197 | (def-function ("gdImageGdPtr" gd-image-gd-ptr) 198 | ((im gd-image-ptr) 199 | (size (* :int))) 200 | :returning :pointer-void 201 | :module "gd") 202 | 203 | (def-function ("gdImageGd2Ptr" gd-image-gd2-ptr) 204 | ((im gd-image-ptr) 205 | (size (* :int))) 206 | :returning :pointer-void 207 | :module "gd") 208 | 209 | (def-function ("gdImageWBMPPtr" gd-image-wbmp-ptr) 210 | ((im gd-image-ptr) 211 | (size (* :int)) 212 | (fg :int)) 213 | :returning :pointer-void 214 | :module "gd") 215 | 216 | (def-function ("gdImagePngPtr" gd-image-png-ptr) 217 | ((im gd-image-ptr) 218 | (size (* :int))) 219 | :returning :pointer-void 220 | :module "gd") 221 | 222 | (def-function ("gdImagePngPtrEx" gd-image-png-ptr-ex) 223 | ((im gd-image-ptr) 224 | (size (* :int)) 225 | (level :int)) 226 | :returning :pointer-void 227 | :module "gd") 228 | 229 | #-:cl-gd-no-gif 230 | (def-function ("gdImageGifPtr" gd-image-gif-ptr) 231 | ((im gd-image-ptr) 232 | (size (* :int))) 233 | :returning :pointer-void 234 | :module "gd") 235 | 236 | (def-function ("gdImageDestroy" gd-image-destroy) 237 | ((im gd-image-ptr)) 238 | :returning :void 239 | :module "gd") 240 | 241 | (def-function ("gdImageColorAllocate" gd-image-color-allocate) 242 | ((im gd-image-ptr) 243 | (r :int) 244 | (g :int) 245 | (b :int)) 246 | :returning :int 247 | :module "gd") 248 | 249 | (def-function ("gdImageColorAllocateAlpha" gd-image-color-allocate-alpha) 250 | ((im gd-image-ptr) 251 | (r :int) 252 | (g :int) 253 | (b :int) 254 | (a :int)) 255 | :returning :int 256 | :module "gd") 257 | 258 | (def-function ("gdImageColorDeallocate" gd-image-color-deallocate) 259 | ((im gd-image-ptr) 260 | (color :int)) 261 | :returning :void 262 | :module "gd") 263 | 264 | (def-function ("gdImageColorExact" gd-image-color-exact) 265 | ((im gd-image-ptr) 266 | (r :int) 267 | (g :int) 268 | (b :int)) 269 | :returning :int 270 | :module "gd") 271 | 272 | (def-function ("gdImageColorClosest" gd-image-color-closest) 273 | ((im gd-image-ptr) 274 | (r :int) 275 | (g :int) 276 | (b :int)) 277 | :returning :int 278 | :module "gd") 279 | 280 | (def-function ("gdImageColorClosestHWB" gd-image-color-closest-hwb) 281 | ((im gd-image-ptr) 282 | (r :int) 283 | (g :int) 284 | (b :int)) 285 | :returning :int 286 | :module "gd") 287 | 288 | (def-function ("gdImageColorClosestAlpha" gd-image-color-closest-alpha) 289 | ((im gd-image-ptr) 290 | (r :int) 291 | (g :int) 292 | (b :int) 293 | (a :int)) 294 | :returning :int 295 | :module "gd") 296 | 297 | (def-function ("gdImageColorResolve" gd-image-color-resolve) 298 | ((im gd-image-ptr) 299 | (r :int) 300 | (g :int) 301 | (b :int)) 302 | :returning :int 303 | :module "gd") 304 | 305 | (def-function ("gdImageColorResolveAlpha" gd-image-color-resolve-alpha) 306 | ((im gd-image-ptr) 307 | (r :int) 308 | (g :int) 309 | (b :int) 310 | (a :int)) 311 | :returning :int 312 | :module "gd") 313 | 314 | (def-function ("gdImageColorTransparent" gd-image-color-transparent) 315 | ((im gd-image-ptr) 316 | (color :int)) 317 | :returning :void 318 | :module "gd") 319 | 320 | (def-function ("gdImageGetGetTransparent" gd-image-get-transparent) 321 | ((im gd-image-ptr)) 322 | :returning :int 323 | :module "gd") 324 | 325 | (def-function ("gdImageSetAntiAliased" gd-image-set-anti-aliased) 326 | ((im gd-image-ptr) 327 | (c :int)) 328 | :returning :void 329 | :module "gd") 330 | 331 | (def-function ("gdImageSetAntiAliasedDontBlend" gd-image-set-anti-aliased-do-not-blend) 332 | ((im gd-image-ptr) 333 | (c :int) 334 | (dont-blend :int)) 335 | :returning :void 336 | :module "gd") 337 | 338 | (def-function ("gdImageSetBrush" gd-image-set-brush) 339 | ((im gd-image-ptr) 340 | (brush gd-image-ptr)) 341 | :returning :void 342 | :module "gd") 343 | 344 | (def-function ("gdImageSetTile" gd-image-set-tile) 345 | ((im gd-image-ptr) 346 | (tile gd-image-ptr)) 347 | :returning :void 348 | :module "gd") 349 | 350 | (def-function ("gdImageSetStyle" gd-image-set-style) 351 | ((im gd-image-ptr) 352 | (style (* :int)) 353 | (style-length :int)) 354 | :returning :void 355 | :module "gd") 356 | 357 | (def-function ("gdImageSetThickness" gd-image-set-thickness) 358 | ((im gd-image-ptr) 359 | (thickness :int)) 360 | :returning :void 361 | :module "gd") 362 | 363 | (def-function ("gdImageAlphaBlending" gd-image-alpha-blending) 364 | ((im gd-image-ptr) 365 | (blending :int)) 366 | :returning :void 367 | :module "gd") 368 | 369 | (def-function ("gdImageSaveAlpha" gd-image-save-alpha) 370 | ((im gd-image-ptr) 371 | (save-flag :int)) 372 | :returning :void 373 | :module "gd") 374 | 375 | (def-function ("gdImageGetRed" gd-image-get-red) 376 | ((im gd-image-ptr) 377 | (color :int)) 378 | :returning :int 379 | :module "gd") 380 | 381 | (def-function ("gdImageGetGreen" gd-image-get-green) 382 | ((im gd-image-ptr) 383 | (color :int)) 384 | :returning :int 385 | :module "gd") 386 | 387 | (def-function ("gdImageGetBlue" gd-image-get-blue) 388 | ((im gd-image-ptr) 389 | (color :int)) 390 | :returning :int 391 | :module "gd") 392 | 393 | (def-function ("gdImageGetAlpha" gd-image-get-alpha) 394 | ((im gd-image-ptr) 395 | (color :int)) 396 | :returning :int 397 | :module "gd") 398 | 399 | (def-function ("gdImageGetColorsTotal" gd-image-get-colors-total) 400 | ((im gd-image-ptr)) 401 | :returning :int 402 | :module "gd") 403 | 404 | (def-function ("gdImageSetClip" gd-image-set-clip) 405 | ((im gd-image-ptr) 406 | (x1 :int) 407 | (y1 :int) 408 | (x2 :int) 409 | (y2 :int)) 410 | :returning :void 411 | :module "gd") 412 | 413 | (def-function ("gdImageGetClip" gd-image-get-clip) 414 | ((im gd-image-ptr) 415 | (x1p (* :int)) 416 | (y1p (* :int)) 417 | (x2p (* :int)) 418 | (y2p (* :int))) 419 | :returning :void 420 | :module "gd") 421 | 422 | (def-function ("gdImageSetPixel" gd-image-set-pixel) 423 | ((im gd-image-ptr) 424 | (x :int) 425 | (y :int) 426 | (color :int)) 427 | :returning :void 428 | :module "gd") 429 | 430 | (def-function ("gdImageLine" gd-image-line) 431 | ((im gd-image-ptr) 432 | (x1 :int) 433 | (y1 :int) 434 | (x2 :int) 435 | (y2 :int) 436 | (color :int)) 437 | :returning :void 438 | :module "gd") 439 | 440 | (def-function ("gdImagePolygon" gd-image-polygon) 441 | ((im gd-image-ptr) 442 | (points gd-point-ptr) 443 | (points-total :int) 444 | (color :int)) 445 | :returning :void 446 | :module "gd") 447 | 448 | (def-function ("gdImageFilledPolygon" gd-image-filled-polygon) 449 | ((im gd-image-ptr) 450 | (points gd-point-ptr) 451 | (points-total :int) 452 | (color :int)) 453 | :returning :void 454 | :module "gd") 455 | 456 | (def-function ("gdImageRectangle" gd-image-rectangle) 457 | ((im gd-image-ptr) 458 | (x1 :int) 459 | (y1 :int) 460 | (x2 :int) 461 | (y2 :int) 462 | (color :int)) 463 | :returning :void 464 | :module "gd") 465 | 466 | (def-function ("gdImageFilledRectangle" gd-image-filled-rectangle) 467 | ((im gd-image-ptr) 468 | (x1 :int) 469 | (y1 :int) 470 | (x2 :int) 471 | (y2 :int) 472 | (color :int)) 473 | :returning :void 474 | :module "gd") 475 | 476 | (def-function ("gdImageFilledEllipse" gd-image-filled-ellipse) 477 | ((im gd-image-ptr) 478 | (cx :int) 479 | (cy :int) 480 | (w :int) 481 | (h :int) 482 | (color :int)) 483 | :returning :void 484 | :module "gd") 485 | 486 | (def-function ("gdImageArc" gd-image-arc) 487 | ((im gd-image-ptr) 488 | (cx :int) 489 | (cy :int) 490 | (w :int) 491 | (h :int) 492 | (s :int) 493 | (e :int) 494 | (color :int)) 495 | :returning :void 496 | :module "gd") 497 | 498 | (def-function ("gdImageFilledArc" gd-image-filled-arc) 499 | ((im gd-image-ptr) 500 | (cx :int) 501 | (cy :int) 502 | (w :int) 503 | (h :int) 504 | (s :int) 505 | (e :int) 506 | (color :int) 507 | (style :int)) 508 | :returning :void 509 | :module "gd") 510 | 511 | (def-function ("gdImageFill" gd-image-fill) 512 | ((im gd-image-ptr) 513 | (x :int) 514 | (y :int) 515 | (color :int)) 516 | :returning :void 517 | :module "gd") 518 | 519 | (def-function ("gdImageFillToBorder" gd-image-fill-to-border) 520 | ((im gd-image-ptr) 521 | (x :int) 522 | (y :int) 523 | (border :int) 524 | (color :int)) 525 | :returning :void 526 | :module "gd") 527 | 528 | (def-function ("gdImageChar" gd-image-char) 529 | ((im gd-image-ptr) 530 | (f gd-font-ptr) 531 | (x :int) 532 | (y :int) 533 | (c :int) 534 | (color :int)) 535 | :returning :void 536 | :module "gd") 537 | 538 | (def-function ("gdImageCharUp" gd-image-char-up) 539 | ((im gd-image-ptr) 540 | (f gd-font-ptr) 541 | (x :int) 542 | (y :int) 543 | (c :int) 544 | (color :int)) 545 | :returning :void 546 | :module "gd") 547 | 548 | (def-function ("gdImageString" gd-image-string) 549 | ((im gd-image-ptr) 550 | (f gd-font-ptr) 551 | (x :int) 552 | (y :int) 553 | (s :cstring) 554 | (color :int)) 555 | :returning :void 556 | :module "gd") 557 | 558 | (def-function ("gdImageStringUp" gd-image-string-up) 559 | ((im gd-image-ptr) 560 | (f gd-font-ptr) 561 | (x :int) 562 | (y :int) 563 | (s :cstring) 564 | (color :int)) 565 | :returning :void 566 | :module "gd") 567 | 568 | (def-function ("gdImageStringFT" gd-image-string-ft) 569 | ((im gd-image-ptr) 570 | (brect (* :int)) 571 | (fg :int) 572 | (fontname :cstring) 573 | (ptsize :double) 574 | (angle :double) 575 | (x :int) 576 | (y :int) 577 | (string :cstring)) 578 | :returning :cstring 579 | :module "gd") 580 | 581 | (def-function ("gdImageStringFTEx" gd-image-string-ft-ex) 582 | ((im gd-image-ptr) 583 | (brect (* :int)) 584 | (fg :int) 585 | (fontname :cstring) 586 | (ptsize :double) 587 | (angle :double) 588 | (x :int) 589 | (y :int) 590 | (string :cstring) 591 | (strex gd-ft-string-extra-ptr)) 592 | :returning :cstring 593 | :module "gd") 594 | 595 | (def-function ("gdImageGetPixel" gd-image-get-pixel) 596 | ((im gd-image-ptr) 597 | (x :int) 598 | (y :int)) 599 | :returning :int 600 | :module "gd") 601 | 602 | (def-function ("gdImageBoundsSafe" gd-image-bounds-safe) 603 | ((im gd-image-ptr) 604 | (x :int) 605 | (y :int)) 606 | :returning :int 607 | :module "gd") 608 | 609 | (def-function ("gdImageGetSX" gd-image-get-sx) 610 | ((im gd-image-ptr)) 611 | :returning :int 612 | :module "gd") 613 | 614 | (def-function ("gdImageGetSY" gd-image-get-sy) 615 | ((im gd-image-ptr)) 616 | :returning :int 617 | :module "gd") 618 | 619 | (def-function ("gdImageInterlace" gd-image-interlace) 620 | ((im gd-image-ptr) 621 | (interlace :int)) 622 | :returning :void 623 | :module "gd") 624 | 625 | (def-function ("gdImageGetGetInterlaced" gd-image-get-interlaced) 626 | ((im gd-image-ptr)) 627 | :returning :int 628 | :module "gd") 629 | 630 | (def-function ("gdImageCopy" gd-image-copy) 631 | ((dst gd-image-ptr) 632 | (src gd-image-ptr) 633 | (dest-x :int) 634 | (dest-y :int) 635 | (src-x :int) 636 | (src-y :int) 637 | (w :int) 638 | (h :int)) 639 | :returning :void 640 | :module "gd") 641 | 642 | (def-function ("gdImageCopyMerge" gd-image-copy-merge) 643 | ((dst gd-image-ptr) 644 | (src gd-image-ptr) 645 | (dest-x :int) 646 | (dest-y :int) 647 | (src-x :int) 648 | (src-y :int) 649 | (w :int) 650 | (h :int) 651 | (percent :int)) 652 | :returning :void 653 | :module "gd") 654 | 655 | (def-function ("gdImageCopyMergeGray" gd-image-copy-merge-gray) 656 | ((dst gd-image-ptr) 657 | (src gd-image-ptr) 658 | (dest-x :int) 659 | (dest-y :int) 660 | (src-x :int) 661 | (src-y :int) 662 | (w :int) 663 | (h :int) 664 | (percent :int)) 665 | :returning :void 666 | :module "gd") 667 | 668 | (def-function ("gdImageCopyResized" gd-image-copy-resized) 669 | ((dst gd-image-ptr) 670 | (src gd-image-ptr) 671 | (dst-x :int) 672 | (dst-y :int) 673 | (src-x :int) 674 | (src-y :int) 675 | (dest-w :int) 676 | (dest-h :int) 677 | (src-w :int) 678 | (src-h :int)) 679 | :returning :void 680 | :module "gd") 681 | 682 | (def-function ("gdImageCopyResampled" gd-image-copy-resampled) 683 | ((dst gd-image-ptr) 684 | (src gd-image-ptr) 685 | (dst-x :int) 686 | (dst-y :int) 687 | (src-x :int) 688 | (src-y :int) 689 | (dest-w :int) 690 | (dest-h :int) 691 | (src-w :int) 692 | (src-h :int)) 693 | :returning :void 694 | :module "gd") 695 | 696 | (def-function ("gdImageCopyRotated" gd-image-copy-rotated) 697 | ((dst gd-image-ptr) 698 | (src gd-image-ptr) 699 | (dst-x :double) 700 | (dst-y :double) 701 | (src-x :int) 702 | (src-y :int) 703 | (src-w :int) 704 | (src-h :int) 705 | (angle :int)) 706 | :returning :void 707 | :module "gd") 708 | 709 | (def-function ("gdImagePaletteCopy" gd-image-palette-copy) 710 | ((dst gd-image-ptr) 711 | (src gd-image-ptr)) 712 | :returning :void 713 | :module "gd") 714 | 715 | (def-function ("gdImageCompare" gd-image-compare) 716 | ((im1 gd-image-ptr) 717 | (im2 gd-image-ptr)) 718 | :returning :int 719 | :module "gd") 720 | 721 | (def-function ("gdImageTrueColorToPalette" gd-image-true-color-to-palette) 722 | ((im gd-image-ptr) 723 | (dither :int) 724 | (colors-wanted :int)) 725 | :returning :void 726 | :module "gd") 727 | 728 | (def-function ("gdFree" gd-free) 729 | ((ptr :pointer-void)) 730 | :returning :void 731 | :module "gd") 732 | 733 | (def-function ("gdImageGifAnimBeginWrap" gd-image-gif-anim-begin-wrap) 734 | ((im gd-image-ptr) 735 | (filename :cstring) 736 | (global-cm :int) 737 | (loops :int)) 738 | :returning :pointer-void 739 | :module "gd") 740 | 741 | (def-function ("gdImageGifAnimAdd" gd-image-gif-anim-add) 742 | ((im gd-image-ptr) 743 | (out :pointer-void) 744 | (local-cm :int) 745 | (left-ofs :int) 746 | (top-ofs :int) 747 | (delay :int) 748 | (disposal :int) 749 | (previm gd-image-ptr)) 750 | :returning :void 751 | :module "gd") 752 | 753 | (def-function ("gdImageGifAnimEndWrap" gd-image-gif-anim-end-wrap) 754 | ((out :pointer-void)) 755 | :returning :void 756 | :module "gd") -------------------------------------------------------------------------------- /images.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- 2 | ;;; $Header: /usr/local/cvsrep/gd/images.lisp,v 1.34 2009/11/23 17:05:39 edi Exp $ 3 | 4 | ;;; Copyright (c) 2003-2009, Dr. Edmund Weitz. All rights reserved. 5 | 6 | ;;; Redistribution and use in source and binary forms, with or without 7 | ;;; modification, are permitted provided that the following conditions 8 | ;;; are met: 9 | 10 | ;;; * Redistributions of source code must retain the above copyright 11 | ;;; notice, this list of conditions and the following disclaimer. 12 | 13 | ;;; * Redistributions in binary form must reproduce the above 14 | ;;; copyright notice, this list of conditions and the following 15 | ;;; disclaimer in the documentation and/or other materials 16 | ;;; provided with the distribution. 17 | 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 19 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 22 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 24 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 25 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 26 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | (in-package :cl-gd) 31 | 32 | (defmethod print-object ((image image) stream) 33 | (print-unreadable-object (image stream :identity t :type t) 34 | (format stream "ptr ~X size ~D/~D (~:[true color~;~:*~D color~:P~])" 35 | (uffi:pointer-address (img image)) 36 | (image-width image) (image-height image) 37 | (unless (true-color-p image) 38 | (number-of-colors :image image))))) 39 | 40 | (defun create-image (width height &optional true-color) 41 | "Allocates and returns a GD image structure with size WIDTH x 42 | HEIGHT. Creates a true color image if TRUE-COLOR is true. You are 43 | responsible for destroying the image after you're done with it. It is 44 | advisable to use WITH-IMAGE instead." 45 | (check-type width integer) 46 | (check-type height integer) 47 | (let ((image-ptr 48 | (if true-color 49 | (gd-image-create-true-color width height) 50 | (gd-image-create width height)))) 51 | (when (null-pointer-p image-ptr) 52 | (error "Could not allocate image of size ~A x ~A" width height)) 53 | (let ((image (make-image image-ptr))) 54 | image))) 55 | 56 | (defun destroy-image (image) 57 | "Destroys \(deallocates) IMAGE which has been created by 58 | CREATE-IMAGE, CREATE-IMAGE-FROM-FILE, or CREATE-IMAGE-FROM-GD2-PART." 59 | (check-type image image) 60 | (gd-image-destroy (img image)) 61 | nil) 62 | 63 | (defmacro with-default-image ((image) &body body) 64 | "Executes BODY with *DEFAULT-IMAGE* bound to IMAGE so that you don't 65 | have to provide the IMAGE keyword/optional argument to CL-GD 66 | functions." 67 | `(let ((*default-image* ,image)) 68 | ,@body)) 69 | 70 | (defmacro with-image ((name width height &optional true-color) &body body) 71 | "Creates an image with size WIDTH x HEIGHT, and executes BODY with 72 | the image bound to NAME. If TRUE-COLOR is true, creates a true color 73 | image. The image is guaranteed to be destroyed before this macro 74 | exits." 75 | ;; we rebind everything so we have left-to-right evaluation 76 | (with-rebinding (width height true-color) 77 | `(with-safe-alloc (,name 78 | (create-image ,width ,height ,true-color) 79 | (destroy-image ,name)) 80 | ,@body))) 81 | 82 | (defmacro with-image* ((width height &optional true-color) &body body) 83 | "Creates an image with size WIDTH x HEIGHT and executes BODY with 84 | the image bound to *DEFAULT-IMAGE*. If TRUE-COLOR is true, creates a 85 | true color image. The image is guaranteed to be destroyed before this 86 | macro exits." 87 | `(with-image (*default-image* ,width ,height ,true-color) 88 | ,@body)) 89 | 90 | (defun create-image-from-file (file-name &optional type) 91 | "Creates an image from the file specified by FILE-NAME \(which is 92 | either a pathname or a string). The type of the image can be provided 93 | as TYPE or otherwise it will be guessed from the PATHNAME-TYPE of 94 | FILE-NAME. You are responsible for destroying the image after you're 95 | done with it. It is advisable to use WITH-IMAGE-FROM-FILE instead." 96 | (check-type file-name (or pathname string)) 97 | (let* ((pathname-type (pathname-type file-name)) 98 | (%type (or type 99 | (cond ((or (string-equal pathname-type "jpg") 100 | (string-equal pathname-type "jpeg")) 101 | :jpg) 102 | ((string-equal pathname-type "png") 103 | :png) 104 | ((string-equal pathname-type "gd") 105 | :gd) 106 | ((string-equal pathname-type "gd2") 107 | :gd2) 108 | ((string-equal pathname-type "xbm") 109 | :xbm) 110 | #-:win32 111 | ((string-equal pathname-type "xpm") 112 | :xpm) 113 | #-:cl-gd-no-gif 114 | ((string-equal pathname-type "gif") 115 | :gif))))) 116 | (unless %type 117 | (error "No type provided and it couldn't be guessed from filename")) 118 | (unless (probe-file file-name) 119 | (error "File ~S could not be found" file-name)) 120 | (when (pathnamep file-name) 121 | (setq file-name 122 | #+:cmu (ext:unix-namestring file-name) 123 | #-:cmu (namestring file-name))) 124 | (with-foreign-object (err :int) 125 | (with-cstring (c-file-name file-name) 126 | (let ((image (ecase %type 127 | ((:jpg :jpeg) 128 | (gd-image-create-from-jpeg-file c-file-name err)) 129 | ((:png) 130 | (gd-image-create-from-png-file c-file-name err)) 131 | ((:gd) 132 | (gd-image-create-from-gd-file c-file-name err)) 133 | ((:gd2) 134 | (gd-image-create-from-gd2-file c-file-name err)) 135 | ((:xbm) 136 | (gd-image-create-from-xbm-file c-file-name err)) 137 | #-:win32 138 | ((:xpm) 139 | (gd-image-create-from-xpm c-file-name)) 140 | #-:cl-gd-no-gif 141 | ((:gif) 142 | (gd-image-create-from-gif-file c-file-name err))))) 143 | (cond ((null-pointer-p image) 144 | (cond ((or (eq %type :xpm) 145 | (zerop (deref-pointer err :int))) 146 | (error "Could not create image from ~A file ~S" 147 | %type file-name)) 148 | (t 149 | (error "Could not create image from ~A file ~S: errno was ~A" 150 | %type file-name (deref-pointer err :int))))) 151 | (t (let ((image (make-image image))) 152 | image)))))))) 153 | 154 | (defmacro with-image-from-file ((name file-name &optional type) &body body) 155 | "Creates an image from the file specified by FILE-NAME \(which is 156 | either a pathname or a string) and executes BODY with the image bound 157 | to NAME. The type of the image can be provied as TYPE or otherwise it 158 | will be guessed from the PATHNAME-TYPE of FILE-NAME. The image is 159 | guaranteed to be destroyed before this macro exits." 160 | ;; we rebind everything so we have left-to-right evaluation 161 | (with-rebinding (file-name type) 162 | `(with-safe-alloc (,name 163 | (create-image-from-file ,file-name ,type) 164 | (destroy-image ,name)) 165 | ,@body))) 166 | 167 | (defmacro with-image-from-file* ((file-name &optional type) &body body) 168 | "Creates an image from the file specified by FILE-NAME \(which is 169 | either a pathname or a string) and executes BODY with the image bound 170 | to *DEFAULT-IMAGE*. The type of the image can be provied as TYPE or 171 | otherwise it will be guessed from the PATHNAME-TYPE of FILE-NAME. The 172 | image is guaranteed to be destroyed before this macro exits." 173 | `(with-image-from-file (*default-image* ,file-name ,type) 174 | ,@body)) 175 | 176 | (defun create-image-from-gd2-part (file-name src-x src-y width height) 177 | "Creates an image from the part of the GD2 file FILE-NAME \(which is 178 | either a pathname or a string) specified by SRC-X, SRC-Y, WIDTH, and 179 | HEIGHT. You are responsible for destroying the image after you're done 180 | with it. It is advisable to use WITH-IMAGE-FROM-GD2-PART instead." 181 | (check-type file-name (or string pathname)) 182 | (check-type src-x integer) 183 | (check-type src-y integer) 184 | (check-type width integer) 185 | (check-type height integer) 186 | (unless (probe-file file-name) 187 | (error "File ~S could not be found" file-name)) 188 | (when (pathnamep file-name) 189 | (setq file-name 190 | #+:cmu (ext:unix-namestring file-name) 191 | #-:cmu (namestring file-name))) 192 | (with-foreign-object (err :int) 193 | (with-cstring (c-file-name file-name) 194 | (let ((image (gd-image-create-from-gd2-part-file c-file-name err src-x src-y width height))) 195 | (cond ((null-pointer-p image) 196 | (error "Could not create GD2 image from file ~S: errno was ~A" 197 | file-name (deref-pointer err :int))) 198 | (t image)))))) 199 | 200 | (defmacro with-image-from-gd2-part ((name file-name src-x src-y width height) &body body) 201 | "Creates an image from the part of the GD2 file FILE-NAME \(which is 202 | either a pathname or a string) specified SRC-X, SRC-Y, WIDTH, and 203 | HEIGHT and executes BODY with the image bound to NAME. The type of the 204 | image can be provied as TYPE or otherwise it will be guessed from the 205 | PATHNAME-TYPE of FILE-NAME. The image is guaranteed to be destroyed 206 | before this macro exits." 207 | ;; we rebind everything so we have left-to-right evaluation 208 | (with-rebinding (file-name src-x src-y width height) 209 | `(with-safe-alloc (,name 210 | (create-image-from-gd2-part ,file-name ,src-x ,src-y ,width ,height) 211 | (destroy-image ,name)) 212 | ,@body))) 213 | 214 | (defmacro with-image-from-gd2-part* ((file-name src-x src-y width height) &body body) 215 | "Creates an image from the part of the GD2 file FILE-NAME \(which is 216 | either a pathname or a string) specified SRC-X, SRC-Y, WIDTH, and 217 | HEIGHT and executes BODY with the image bound to *DEFAULT-IMAGE*. The 218 | type of the image can be provied as TYPE or otherwise it will be 219 | guessed from the PATHNAME-TYPE of FILE-NAME. The image is guaranteed 220 | to be destroyed before this macro exits." 221 | `(with-image-from-gd2-part (*default-image* ,file-name ,src-x ,src-y ,width ,height) 222 | ,@body)) 223 | 224 | (defmacro make-stream-fn (name signature gd-call type-checks docstring) 225 | "Internal macro used to generate WRITE-JPEG-TO-STREAM and friends." 226 | `(defun ,name ,signature 227 | ,docstring 228 | ,@type-checks 229 | (cond ((or #+(and :allegro :allegro-version>= (version>= 6 0)) 230 | (typep stream 'excl:simple-stream) 231 | #+:lispworks4.3 232 | (subtypep 'base-char (stream-element-type stream)) 233 | (subtypep '(unsigned-byte 8) (stream-element-type stream))) 234 | (with-foreign-object (size :int) 235 | (with-safe-alloc (memory ,gd-call (gd-free memory)) 236 | (let (#+:lispworks4.3 237 | (temp-array (make-array 1 :element-type 238 | '(unsigned-byte 8)))) 239 | (with-cast-pointer (temp memory :unsigned-byte) 240 | (dotimes (i (deref-pointer size :int)) 241 | ;; LispWorks workaround, WRITE-BYTE won't work - see 242 | ;; 243 | #+:lispworks4.3 244 | (setf (aref temp-array 0) 245 | (deref-array temp '(:array :unsigned-byte) i)) 246 | #+:lispworks4.3 247 | (write-sequence temp-array stream) 248 | #-:lispworks4.3 249 | (write-byte (deref-array temp '(:array :unsigned-byte) i) 250 | stream)) 251 | image))))) 252 | ((subtypep 'character (stream-element-type stream)) 253 | (with-foreign-object (size :int) 254 | (with-safe-alloc (memory ,gd-call (gd-free memory)) 255 | (with-cast-pointer (temp memory 256 | #+(or :cmu :scl :sbcl) :unsigned-char 257 | #-(or :cmu :scl :sbcl) :char) 258 | (dotimes (i (deref-pointer size :int)) 259 | (write-char (ensure-char-character 260 | (deref-array temp '(:array :char) i)) 261 | stream)) 262 | image)))) 263 | (t (error "Can't use a stream with element-type ~A" 264 | (stream-element-type stream)))))) 265 | 266 | (make-stream-fn write-jpeg-to-stream (stream &key (quality -1) (image *default-image*)) 267 | (gd-image-jpeg-ptr (img image) size quality) 268 | ((check-type stream stream) 269 | (check-type quality (integer -1 100)) 270 | (check-type image image)) 271 | "Writes image IMAGE to stream STREAM as JPEG. If 272 | QUALITY is not specified, the default IJG JPEG quality value is 273 | used. Otherwise, for practical purposes, quality should be a value in 274 | the range 0-95. STREAM must be a character stream or a binary stream 275 | of element type \(UNSIGNED-BYTE 8). If STREAM is a character stream, 276 | the user of this function has to make sure the external format is 277 | yields faithful output of all 8-bit characters.") 278 | 279 | (make-stream-fn write-png-to-stream (stream &key compression-level (image *default-image*)) 280 | (cond (compression-level 281 | (gd-image-png-ptr-ex (img image) size compression-level)) 282 | (t 283 | (gd-image-png-ptr (img image) size))) 284 | ((check-type stream stream) 285 | (check-type compression-level (or null (integer -1 9))) 286 | (check-type image image)) 287 | "Writes image IMAGE to stream STREAM as PNG. If 288 | COMPRESSION-LEVEL is not specified, the default compression level at 289 | the time zlib was compiled on your system will be used. Otherwise, a 290 | compression level of 0 means 'no compression', a compression level of 291 | 1 means 'compressed, but as quickly as possible', a compression level 292 | of 9 means 'compressed as much as possible to produce the smallest 293 | possible file.' STREAM must be a character stream or a binary stream 294 | of element type \(UNSIGNED-BYTE 8). If STREAM is a character stream, 295 | the user of this function has to make sure the external format yields 296 | faithful output of all 8-bit characters.") 297 | 298 | #-:cl-gd-no-gif 299 | (make-stream-fn write-gif-to-stream (stream &key (image *default-image*)) 300 | (gd-image-gif-ptr (img image) size) 301 | ((check-type stream stream) 302 | (check-type image image)) 303 | "Writes image IMAGE to stream STREAM as GIF. STREAM 304 | must be a character stream or a binary stream of element type 305 | \(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this 306 | function has to make sure the external format yields faithful output 307 | of all 8-bit characters.") 308 | 309 | (make-stream-fn write-wbmp-to-stream (stream &key foreground (image *default-image*)) 310 | (gd-image-wbmp-ptr (img image) size foreground) 311 | ((check-type stream stream) 312 | (check-type foreground integer) 313 | (check-type image image)) 314 | "Writes image IMAGE to stream STREAM as WBMP. STREAM 315 | must be a character stream or a binary stream of element type 316 | \(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this 317 | function has to make sure the external format yields faithful output 318 | of all 8-bit characters. WBMP file support is black and white 319 | only. The color index specified by the FOREGOUND argument is the 320 | \"foreground,\" and only pixels of this color will be set in the WBMP 321 | file") 322 | 323 | (make-stream-fn write-gd-to-stream (stream &key (image *default-image*)) 324 | (gd-image-gd-ptr (img image) size) 325 | ((check-type stream stream) 326 | (check-type image image)) 327 | "Writes image IMAGE to stream STREAM as GD. STREAM 328 | must be a character stream or a binary stream of element type 329 | \(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this 330 | function has to make sure the external format yields faithful output 331 | of all 8-bit characters.") 332 | 333 | (make-stream-fn write-gd2-to-stream (stream &key (image *default-image*)) 334 | (gd-image-gd2-ptr (img image) size) 335 | ((check-type stream stream) 336 | (check-type image image)) 337 | "Writes image IMAGE to stream STREAM as GD2. STREAM 338 | must be a character stream or a binary stream of element type 339 | \(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this 340 | function has to make sure the external format yields faithful output 341 | of all 8-bit characters.") 342 | 343 | (defun write-image-to-stream (stream type &rest rest &key &allow-other-keys) 344 | "Writes image to STREAM. The type of the image is determined by TYPE 345 | which must be one of :JPG, :JPEG, :PNG, :WBMP, :GD, or :GD2. STREAM 346 | must be a character stream or a binary stream of element type 347 | \(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this 348 | function has to make sure the external format yields faithful output 349 | of all 8-bit characters." 350 | (apply (ecase type 351 | ((:jpg :jpeg) 352 | #'write-jpeg-to-stream) 353 | ((:png) 354 | #'write-png-to-stream) 355 | ((:wbmp) 356 | #'write-wbmp-to-stream) 357 | ((:gd) 358 | #'write-gd-to-stream) 359 | ((:gd2) 360 | #'write-gd2-to-stream) 361 | #-:cl-gd-no-gif 362 | ((:gif) 363 | #'write-gif-to-stream)) 364 | stream rest)) 365 | 366 | (defun write-image-to-file (file-name &rest rest &key type (if-exists :error) &allow-other-keys) 367 | "Writes image to the file specified by FILE-NAME \(a pathname or a 368 | string). The TYPE argument is interpreted as in 369 | WRITE-IMAGE-TO-STREAM. If it is not provided it is guessed from the 370 | PATHNAME-TYPE of FILE-NAME. The IF-EXISTS keyword argument is given to 371 | OPEN. Other keyword argument like QUALITY or COMPRESSION-LEVEL can be 372 | provided depending on the images's type." 373 | (with-open-file (stream file-name :direction :output 374 | :if-exists if-exists 375 | :element-type '(unsigned-byte 8)) 376 | (apply #'write-image-to-stream 377 | stream 378 | (or type 379 | (let ((pathname-type (pathname-type (truename file-name)))) 380 | (cond ((or (string-equal pathname-type "jpg") 381 | (string-equal pathname-type "jpeg")) 382 | :jpg) 383 | ((string-equal pathname-type "png") 384 | :png) 385 | ((string-equal pathname-type "wbmp") 386 | :wbmp) 387 | ((string-equal pathname-type "gd") 388 | :gd) 389 | ((string-equal pathname-type "gd2") 390 | :gd2) 391 | #-:cl-gd-no-gif 392 | ((string-equal pathname-type "gif") 393 | :gif) 394 | (t 395 | (error "Can't determine the type of the image"))))) 396 | (sans rest :type :if-exists)))) 397 | 398 | (defun image-width (&optional (image *default-image*)) 399 | "Returns width of IMAGE." 400 | (check-type image image) 401 | (with-transformed-alternative 402 | (((gd-image-get-sx (img image)) w-inv-transformer)) 403 | (gd-image-get-sx (img image)))) 404 | 405 | (defun image-height (&optional (image *default-image*)) 406 | (check-type image image) 407 | "Returns height of IMAGE." 408 | (with-transformed-alternative 409 | (((gd-image-get-sy (img image)) h-inv-transformer)) 410 | (gd-image-get-sy (img image)))) 411 | 412 | (defun image-size (&optional (image *default-image*)) 413 | (check-type image image) 414 | "Returns width and height of IMAGE as two values." 415 | (with-transformed-alternative 416 | (((gd-image-get-sx (img image)) w-inv-transformer) 417 | ((gd-image-get-sy (img image)) h-inv-transformer)) 418 | (values (gd-image-get-sx (img image)) 419 | (gd-image-get-sy (img image))))) 420 | -------------------------------------------------------------------------------- /init.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- 2 | ;;; $Header: /usr/local/cvsrep/gd/init.lisp,v 1.13 2009/11/23 17:05:39 edi Exp $ 3 | 4 | ;;; Copyright (c) 2003-2009, Dr. Edmund Weitz. All rights reserved. 5 | 6 | ;;; Redistribution and use in source and binary forms, with or without 7 | ;;; modification, are permitted provided that the following conditions 8 | ;;; are met: 9 | 10 | ;;; * Redistributions of source code must retain the above copyright 11 | ;;; notice, this list of conditions and the following disclaimer. 12 | 13 | ;;; * Redistributions in binary form must reproduce the above 14 | ;;; copyright notice, this list of conditions and the following 15 | ;;; disclaimer in the documentation and/or other materials 16 | ;;; provided with the distribution. 17 | 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 19 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 22 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 24 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 25 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 26 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | (in-package :cl-gd) 31 | 32 | (defun load-gd-glue () 33 | "Load the little glue library we have to create for the image input 34 | functions." 35 | ;; try to find the library at different places 36 | (let ((filename (find-foreign-library "cl-gd-glue" 37 | *shared-library-directories* 38 | :types *shared-library-types* 39 | :drive-letters *shared-library-drive-letters*))) 40 | (load-foreign-library filename 41 | :module "gd" 42 | :supporting-libraries *gd-supporting-libraries*))) 43 | 44 | ;; invoke the function, i.e. load the library (and thus GD itself) 45 | ;; before gd-uffi.lisp is loaded/compiled 46 | (load-gd-glue) 47 | -------------------------------------------------------------------------------- /misc.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- 2 | ;;; $Header: /usr/local/cvsrep/gd/misc.lisp,v 1.16 2009/11/23 17:05:39 edi Exp $ 3 | 4 | ;;; Copyright (c) 2003-2009, Dr. Edmund Weitz. All rights reserved. 5 | 6 | ;;; Redistribution and use in source and binary forms, with or without 7 | ;;; modification, are permitted provided that the following conditions 8 | ;;; are met: 9 | 10 | ;;; * Redistributions of source code must retain the above copyright 11 | ;;; notice, this list of conditions and the following disclaimer. 12 | 13 | ;;; * Redistributions in binary form must reproduce the above 14 | ;;; copyright notice, this list of conditions and the following 15 | ;;; disclaimer in the documentation and/or other materials 16 | ;;; provided with the distribution. 17 | 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 19 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 22 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 24 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 25 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 26 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | (in-package :cl-gd) 31 | 32 | (defun interlacedp (&optional (image *default-image*)) 33 | "Returns whether IMAGE will be stored in an interlaced fashion." 34 | (check-type image image) 35 | (not (zerop (gd-image-get-interlaced (img image))))) 36 | 37 | (defun (setf interlacedp) (interlaced &optional (image *default-image*)) 38 | "Sets whether IMAGE will be stored in an interlaced fashion." 39 | (check-type image image) 40 | (gd-image-interlace (img image) (if interlaced 1 0)) 41 | interlaced) 42 | 43 | (defun differentp (image1 image2) 44 | "Returns false if the two images won't appear different when 45 | displayed. Otherwise the return value is a list of keywords describing 46 | the differences between the images." 47 | (check-type image1 image) 48 | (check-type image2 image) 49 | (let ((result (gd-image-compare (img image1) (img image2)))) 50 | (cond ((zerop (logand +gd-cmp-image+ result)) 51 | nil) 52 | (t 53 | (loop for (gd-flag keyword) in `((,+gd-cmp-num-colors+ 54 | :different-number-of-colors) 55 | (,+gd-cmp-color+ 56 | :different-colors) 57 | (,+gd-cmp-size-x+ 58 | :different-widths) 59 | (,+gd-cmp-size-y+ 60 | :different-heights) 61 | (,+gd-cmp-transparent+ 62 | :different-transparent-colors) 63 | (,+gd-cmp-background+ 64 | :different-background-colors) 65 | (,+gd-cmp-interlace+ 66 | :different-interlace-settings) 67 | (,+gd-cmp-true-color+ 68 | :true-color-versus-palette-based)) 69 | when (plusp (logand gd-flag result)) 70 | collect keyword))))) 71 | 72 | (defun copy-image (source destination 73 | source-x source-y 74 | dest-x dest-y 75 | width height 76 | &key resample 77 | rotate angle 78 | resize dest-width dest-height 79 | merge merge-gray) 80 | "Copies \(a part of) image SOURCE into image DESTINATION. Copies the 81 | rectangle with the upper left corner \(SOURCE-X,SOURCE-Y) and size 82 | WIDTH x HEIGHT to the rectangle with the upper left corner 83 | \(DEST-X,DEST-Y). 84 | 85 | If RESAMPLE is true pixel colors will be smoothly interpolated. If 86 | RESIZE is true the copied rectangle will be strechted or shrinked so 87 | that its size is DEST-WIDTH x DEST-HEIGHT. If ROTATE is true the image 88 | will be rotated by ANGLE. In this particular case DEST-X and DEST-Y 89 | specify the CENTER of the copied image rather than its upper left 90 | corner! If MERGE is true it has to be an integer in the range 0-100 91 | and the two images will be 'merged' by the amount specified. If MERGE 92 | is 100 then the source image will simply be copied. If instead 93 | MERGE-GRAY is true the hue of the source image is preserved by 94 | converting the destination area to gray pixels before merging. 95 | 96 | The keyword options RESAMPLE, ROTATE, RESIZE, MERGE, and MERGE-GRAY 97 | are mutually exclusive \(with the exception of RESAMPLE and 98 | RESIZE). ANGLE is assumed to be specified in degrees if it's an 99 | integer, and in radians otherwise." 100 | (check-type source image) 101 | (check-type destination image) 102 | (check-type source-x integer) 103 | (check-type source-y integer) 104 | (unless rotate 105 | (check-type dest-x integer) 106 | (check-type dest-y integer)) 107 | (check-type width integer) 108 | (check-type height integer) 109 | (check-type angle (or null number)) 110 | (check-type dest-width (or null integer)) 111 | (check-type dest-height (or null integer)) 112 | (check-type merge (or null (integer 0 100))) 113 | (check-type merge-gray (or null (integer 0 100))) 114 | (when (and merge merge-gray) 115 | (error "You can't specify MERGE and MERGE-GRAY at the same time.")) 116 | (when (and (or merge merge-gray) 117 | (or resample rotate resize)) 118 | (error "MERGE and MERGE-GRAY can't be combined with RESAMPLE, ROTATE, or RESIZE.")) 119 | (when (and (or dest-width dest-height) 120 | (not resize)) 121 | (error "Use RESIZE if you want to specify DEST-WIDTH or DEST-HEIGHT")) 122 | (when (and resize 123 | (not (or dest-width dest-height))) 124 | (error "Please specify DEST-WIDTH and DEST-HEIGHT together with RESIZE.")) 125 | (when (and angle 126 | (not rotate)) 127 | (error "Use ROTATE if you want to specify ANGLE.")) 128 | (when (and rotate 129 | (not angle)) 130 | (error "Please specify ANGLE together with ROTATE.")) 131 | (when (and rotate 132 | (or resample resize)) 133 | (error "ROTATE can't be used together with RESAMPLE or RESIZE.")) 134 | (cond ((and resample resize) 135 | (gd-image-copy-resampled (img destination) (img source) 136 | dest-x dest-y source-x source-y 137 | dest-width dest-height width height)) 138 | (resample 139 | (gd-image-copy-resampled (img destination) (img source) 140 | dest-x dest-y source-x source-y 141 | width height width height)) 142 | ((and rotate (integerp angle)) 143 | (gd-image-copy-rotated (img destination) (img source) 144 | (coerce dest-x 'double-float) 145 | (coerce dest-y 'double-float) 146 | source-x source-y width height angle)) 147 | (rotate 148 | (gd-image-copy-rotated (img destination) (img source) 149 | (coerce dest-x 'double-float) 150 | (coerce dest-y 'double-float) 151 | source-x source-y width height 152 | (round (* angle +radians-to-degree-factor+)))) 153 | (resize 154 | (gd-image-copy-resized (img destination) (img source) 155 | dest-x dest-y source-x source-y 156 | dest-width dest-height width height)) 157 | (merge 158 | (gd-image-copy-merge (img destination) (img source) 159 | dest-x dest-y source-x source-y 160 | width height merge)) 161 | (merge-gray 162 | (gd-image-copy-merge-gray (img destination) (img source) 163 | dest-x dest-y source-x source-y 164 | width height merge-gray)) 165 | (t 166 | (gd-image-copy (img destination) (img source) dest-x dest-y 167 | source-x source-y width height))) 168 | destination) 169 | 170 | (defun copy-palette (source destination) 171 | "Copies palette of image SOURCE to image DESTINATION attempting to 172 | match the colors in the target image to the colors in the source 173 | palette." 174 | (check-type source image) 175 | (check-type destination image) 176 | (gd-image-palette-copy (img destination) (img source)) 177 | destination) 178 | 179 | (defun true-color-to-palette (&key dither (colors-wanted 256) (image *default-image*)) 180 | "Converts the true color image IMAGE to a palette-based image using 181 | a high-quality two-pass quantization routine. If DITHER is true, the 182 | image will be dithered to approximate colors better, at the expense of 183 | some obvious \"speckling.\" COLORS-WANTED can be any positive integer 184 | up to 256 \(which is the default). If the original source image 185 | includes photographic information or anything that came out of a JPEG, 186 | 256 is strongly recommended. 100% transparency of a single transparent 187 | color in the original true color image will be preserved. There is no 188 | other support for preservation of alpha channel or transparency in the 189 | destination image." 190 | (check-type image image) 191 | (check-type colors-wanted (integer 0 256)) 192 | (gd-image-true-color-to-palette (img image) 193 | (if dither 1 0) 194 | colors-wanted) 195 | image) 196 | 197 | (defmacro do-rows ((y-var &optional (image '*default-image*)) &body body) 198 | (with-rebinding (image) 199 | (with-unique-names (img width height true-color-p raw-pixels row x-var inner-body) 200 | `(let* ((,img (img ,image)) 201 | (,width (gd-image-get-sx ,img)) 202 | (,height (gd-image-get-sy ,img)) 203 | (,true-color-p (true-color-p ,image))) 204 | (declare (fixnum ,width ,height)) 205 | (cond (,true-color-p 206 | (let ((,raw-pixels (get-slot-value ,img 'gd-image 't-pixels))) 207 | (declare (type t-pixels-array ,raw-pixels)) 208 | (dotimes (,y-var ,height) 209 | (let ((,row (deref-array ,raw-pixels '(:array (* :int)) ,y-var))) 210 | (declare (type t-pixels-row ,row)) 211 | (macrolet ((do-pixels-in-row ((,x-var) &body ,inner-body) 212 | `(dotimes (,,x-var ,',width) 213 | (macrolet ((raw-pixel () 214 | `(deref-array ,',',row '(:array :int) ,',,x-var))) 215 | (locally 216 | ,@,inner-body))))) 217 | (locally 218 | ,@body)))))) 219 | (t 220 | (let ((,raw-pixels (get-slot-value ,img 'gd-image 'pixels))) 221 | (declare (type pixels-array ,raw-pixels)) 222 | (dotimes (,y-var ,height) 223 | (let ((,row (deref-array ,raw-pixels '(:array (* :unsigned-byte)) ,y-var))) 224 | (declare (type pixels-row ,row)) 225 | (macrolet ((do-pixels-in-row ((,x-var) &body ,inner-body) 226 | `(dotimes (,,x-var ,',width) 227 | (macrolet ((raw-pixel () 228 | `(deref-array ,',',row '(:array :unsigned-byte) ,',,x-var))) 229 | (locally 230 | ,@,inner-body))))) 231 | (locally 232 | ,@body))))))))))) 233 | 234 | (defmacro do-pixels ((&optional (image '*default-image*)) &body body) 235 | (with-unique-names (x y) 236 | `(do-rows (,y ,image) 237 | (do-pixels-in-row (,x) 238 | ,@body)))) -------------------------------------------------------------------------------- /packages.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | 3 | (defpackage #:cl-gd 4 | (:use #:cl #:uffi) 5 | (:export #:*default-image* 6 | #:*default-color* 7 | #:*default-font* 8 | #:+max-colors+ 9 | #:without-transformations 10 | #:with-transformation 11 | #:create-image 12 | #:destroy-image 13 | #:with-image 14 | #:create-image-from-file 15 | #:with-image-from-file 16 | #:create-image-from-gd2-part 17 | #:with-image-from-gd2-part 18 | #:with-default-image 19 | #:with-image* 20 | #:with-image-from-file* 21 | #:with-image-from-gd2-part* 22 | #:write-jpeg-to-stream 23 | #:write-png-to-stream 24 | #:write-wbmp-to-stream 25 | #:write-gd-to-stream 26 | #:write-gd2-to-stream 27 | #-:cl-gd-no-gif #:write-gif-to-stream 28 | #:write-image-to-stream 29 | #:write-image-to-file 30 | #:image-width 31 | #:image-height 32 | #:image-size 33 | #:make-brush 34 | #:make-tile 35 | #:make-anti-aliased 36 | #:with-default-color 37 | #:allocate-color 38 | #:deallocate-color 39 | #:transparent-color 40 | #:true-color-p 41 | #:number-of-colors 42 | #:find-color 43 | #:find-color-from-image 44 | #:thickness 45 | #:with-thickness 46 | #:alpha-blending-p 47 | #:save-alpha-p 48 | #:color-component 49 | #:color-components 50 | #:draw-polygon 51 | #:draw-line 52 | #:get-pixel 53 | #:set-pixel 54 | #:set-pixels 55 | #:draw-rectangle 56 | #:draw-rectangle* 57 | #:draw-arc 58 | #:draw-filled-ellipse 59 | #:draw-filled-circle 60 | #:fill-image 61 | #:clipping-rectangle 62 | #:clipping-rectangle* 63 | #:set-clipping-rectangle* 64 | #:with-clipping-rectangle 65 | #:with-clipping-rectangle* 66 | #:with-default-font 67 | #:draw-character 68 | #:draw-string 69 | #:draw-freetype-string 70 | #:interlacedp 71 | #:differentp 72 | #:copy-image 73 | #:copy-palette 74 | #:true-color-to-palette 75 | #:do-rows 76 | #:do-pixels-in-row 77 | #:do-pixels 78 | #:raw-pixel)) 79 | 80 | (pushnew :cl-gd *features*) 81 | -------------------------------------------------------------------------------- /specials.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- 2 | ;;; $Header: /usr/local/cvsrep/gd/specials.lisp,v 1.30 2009/11/23 17:05:39 edi Exp $ 3 | 4 | ;;; Copyright (c) 2003-2009, Dr. Edmund Weitz. All rights reserved. 5 | 6 | ;;; Redistribution and use in source and binary forms, with or without 7 | ;;; modification, are permitted provided that the following conditions 8 | ;;; are met: 9 | 10 | ;;; * Redistributions of source code must retain the above copyright 11 | ;;; notice, this list of conditions and the following disclaimer. 12 | 13 | ;;; * Redistributions in binary form must reproduce the above 14 | ;;; copyright notice, this list of conditions and the following 15 | ;;; disclaimer in the documentation and/or other materials 16 | ;;; provided with the distribution. 17 | 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 19 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 22 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 24 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 25 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 26 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | (in-package #:cl-gd) 31 | 32 | (defvar *default-image* nil 33 | "The default image. This special variable is usually bound by 34 | WITH-IMAGE or WITH-IMAGE-FROM-FILE.") 35 | 36 | (defvar *default-color* nil 37 | "The default color. This special variable is usually bound by 38 | WITH-COLOR.") 39 | 40 | (defvar *default-font* nil 41 | "The default font. This special variable is usually bound by 42 | WITH-FONT.") 43 | 44 | (defstruct (image 45 | (:conc-name nil) 46 | (:constructor make-image (img)) 47 | (:copier nil)) 48 | img) 49 | 50 | (defstruct (brush 51 | (:include image) 52 | (:constructor %make-brush (img)) 53 | (:copier nil))) 54 | 55 | (defun make-brush (image) 56 | (%make-brush (img image))) 57 | 58 | (defstruct (tile 59 | (:include image) 60 | (:constructor %make-tile (img)) 61 | (:copier nil))) 62 | 63 | (defun make-tile (image) 64 | (%make-tile (img image))) 65 | 66 | (defstruct (anti-aliased-color 67 | (:conc-name nil) 68 | (:constructor %make-anti-aliased (color do-not-blend)) 69 | (:copier nil)) 70 | color do-not-blend) 71 | 72 | (defun make-anti-aliased (color &optional do-not-blend) 73 | (%make-anti-aliased color do-not-blend)) 74 | 75 | ;; the following variable will be initialized in "gd-uffi.lisp" 76 | (defvar *null-image* nil 77 | "A 'null' image which might be useful for DRAW-FREETYPE-STRING.") 78 | 79 | (defconstant +max-colors+ 256 80 | "Maximum number of colors for palette-based images.") 81 | 82 | (defconstant +gd-chord+ 1 83 | "Used internally by GD-FILLED-ARC") 84 | (defconstant +gd-no-fill+ 2 85 | "Used internally by GD-FILLED-ARC") 86 | (defconstant +gd-edged+ 4 87 | "Used internally by GD-FILLED-ARC") 88 | 89 | (defconstant +brushed+ -3 90 | "Special 'color' for lines drawn with brush.") 91 | (defconstant +styled+ -2 92 | "Special 'color' for styled lines.") 93 | (defconstant +styled-brushed+ -4 94 | "Special 'color' for lines drawn with styled brush.") 95 | (defconstant +transparent+ -6 96 | "Special 'color' used in GD function 'gdImageSetStyle' for transparent color.") 97 | (defconstant +tiled+ -5 98 | "Special fill 'color' used for tiles.") 99 | (defconstant +anti-aliased+ -7 100 | "Special 'color' for anti-aliased lines.") 101 | 102 | (defconstant +gd-ftex-linespace+ 1 103 | "Indicate line-spacing for FreeType library.") 104 | 105 | (defconstant +gd-cmp-image+ 1 106 | "Images will appear different when displayed.") 107 | (defconstant +gd-cmp-num-colors+ 2 108 | "Number of colors in palette differ.") 109 | (defconstant +gd-cmp-color+ 4 110 | "Image colors differ.") 111 | (defconstant +gd-cmp-size-x+ 8 112 | "Image widths differ.") 113 | (defconstant +gd-cmp-size-y+ 16 114 | "Image heights differ.") 115 | (defconstant +gd-cmp-transparent+ 32 116 | "Transparent color is different.") 117 | (defconstant +gd-cmp-background+ 64 118 | "Background color is different.") 119 | (defconstant +gd-cmp-interlace+ 128 120 | "Interlace settings are different.") 121 | (defconstant +gd-cmp-true-color+ 256 122 | "One image is a true-color image, the other one is palette-based.") 123 | 124 | (defconstant +gd-disposal-unknown+ 0) 125 | (defconstant +gd-disposal-none+ 1) 126 | (defconstant +gd-disposal-restore-background+ 2) 127 | (defconstant +gd-disposal-restore-previous+ 2) 128 | 129 | (defvar *shared-library-directories* 130 | `(,(namestring (make-pathname :name nil 131 | :type nil 132 | :version :newest 133 | :defaults cl-gd.system:*cl-gd-directory*)) 134 | "/usr/local/lib/" 135 | "/usr/lib/" 136 | "/usr/lib/cl-gd/" 137 | "/cygwin/usr/local/lib/" 138 | "/cygwin/usr/lib/") 139 | "A list of directories where UFFI tries to find cl-gd-glue.so") 140 | (defvar *shared-library-types* '("so" "dll" "dylib") 141 | "The list of types a shared library can have. Used when looking for 142 | cl-gd-glue.so") 143 | (defvar *shared-library-drive-letters* '("C" "D" "E" "F" "G") 144 | "The list of drive letters \(used by Wintendo) used when looking for 145 | cl-gd-glue.dll.") 146 | 147 | (defvar *gd-supporting-libraries* '("c" "gd" "png" "z" "jpeg" "freetype" "iconv" "m") 148 | "The libraries which are needed by cl-gd-glues.so \(and GD 149 | itself). Only needed for Python-based Lisps like CMUCL, SBCL, or 150 | SCL.") 151 | 152 | (defconstant +radians-to-degree-factor+ (/ 360 (* 2 pi)) 153 | "Factor to convert from radians to degrees.") 154 | 155 | (defvar *transformers* nil 156 | "Stack of currently active transformer objects.") 157 | 158 | (defconstant +most-positive-unsigned-byte-32+ 159 | (1- (expt 2 31)) 160 | "Name says it all...") 161 | 162 | ;; stuff for Nikodemus Siivola's HYPERDOC 163 | ;; see 164 | ;; and 165 | 166 | (defvar *hyperdoc-base-uri* "http://weitz.de/cl-gd/") 167 | 168 | (let ((exported-symbols-alist 169 | (loop for symbol being the external-symbols of :cl-gd 170 | collect (cons symbol 171 | (concatenate 'string 172 | "#" 173 | (string-downcase symbol)))))) 174 | (defun hyperdoc-lookup (symbol type) 175 | (declare (ignore type)) 176 | (cdr (assoc symbol 177 | exported-symbols-alist 178 | :test #'eq)))) -------------------------------------------------------------------------------- /strings.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- 2 | ;;; $Header: /usr/local/cvsrep/gd/strings.lisp,v 1.24 2009/11/23 17:05:39 edi Exp $ 3 | 4 | ;;; Copyright (c) 2003-2009, Dr. Edmund Weitz. All rights reserved. 5 | 6 | ;;; Redistribution and use in source and binary forms, with or without 7 | ;;; modification, are permitted provided that the following conditions 8 | ;;; are met: 9 | 10 | ;;; * Redistributions of source code must retain the above copyright 11 | ;;; notice, this list of conditions and the following disclaimer. 12 | 13 | ;;; * Redistributions in binary form must reproduce the above 14 | ;;; copyright notice, this list of conditions and the following 15 | ;;; disclaimer in the documentation and/or other materials 16 | ;;; provided with the distribution. 17 | 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 19 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 22 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 24 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 25 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 26 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | (in-package :cl-gd) 31 | 32 | (defmacro with-default-font ((font) &body body) 33 | "Execute BODY with *DEFAULT-FONT* bound to FONT so that you 34 | don't have to provide the FONT keyword/optional argument to 35 | string functions. But note that the fonts used for 36 | DRAW-STRING/DRAW-CHARACTER and DRAW-FREETYPE-STRING are 37 | incompatible." 38 | `(let ((*default-font* ,font)) 39 | ,@body)) 40 | 41 | (defun draw-character (x y char &key up (font *default-font*) (color *default-color*) (image *default-image*)) 42 | "Draws the character CHAR from font FONT in color COLOR at position 43 | \(X,Y). If UP is true the character will be drawn from bottom to top 44 | \(rotated 90 degrees). FONT must be one of :TINY, :SMALL, :MEDIUM, 45 | :LARGE, :GIANT." 46 | (check-type char character) 47 | (check-type image image) 48 | (with-color-argument 49 | (with-transformed-alternative 50 | ((x x-transformer) 51 | (y y-transformer)) 52 | (if up 53 | (gd-image-char-up (img image) (ecase font 54 | ((:tiny) +gd-font-tiny+) 55 | ((:small) +gd-font-small+) 56 | ((:medium :medium-bold) +gd-font-medium-bold+) 57 | ((:large) +gd-font-large+) 58 | ((:giant) +gd-font-giant+)) 59 | x y (char-code char) color) 60 | (gd-image-char (img image) (ecase font 61 | ((:tiny) +gd-font-tiny+) 62 | ((:small) +gd-font-small+) 63 | ((:medium :medium-bold) +gd-font-medium-bold+) 64 | ((:large) +gd-font-large+) 65 | ((:giant) +gd-font-giant+)) 66 | x y (char-code char) color)))) 67 | char) 68 | 69 | (defun draw-string (x y string &key up (font *default-font*) (color *default-color*) (image *default-image*)) 70 | "Draws the string STRING in color COLOR at position \(X,Y). If UP is 71 | true the character will be drawn from bottom to top \(rotated 90 72 | degrees). FONT must be one of :TINY, :SMALL, :MEDIUM, :LARGE, :GIANT." 73 | (check-type string string) 74 | (check-type image image) 75 | (with-color-argument 76 | (with-transformed-alternative 77 | ((x x-transformer) 78 | (y y-transformer)) 79 | (with-cstring (c-string string) 80 | (if up 81 | (gd-image-string-up (img image) (ecase font 82 | ((:tiny) +gd-font-tiny+) 83 | ((:small) +gd-font-small+) 84 | ((:medium :medium-bold) +gd-font-medium-bold+) 85 | ((:large) +gd-font-large+) 86 | ((:giant) +gd-font-giant+)) 87 | x y c-string color) 88 | (gd-image-string (img image) (ecase font 89 | ((:tiny) +gd-font-tiny+) 90 | ((:small) +gd-font-small+) 91 | ((:medium :medium-bold) +gd-font-medium-bold+) 92 | ((:large) +gd-font-large+) 93 | ((:giant) +gd-font-giant+)) 94 | x y c-string color))))) 95 | string) 96 | 97 | (defun draw-freetype-string (x y string 98 | &key (anti-aliased t) 99 | (point-size 12.0d0) 100 | (angle 0.0d0) 101 | (convert-chars t) 102 | line-spacing 103 | (font-name *default-font*) 104 | do-not-draw 105 | (color *default-color*) 106 | (image *default-image*)) 107 | "Draws the string STRING in color COLOR at position \(X,Y) using the 108 | FreeType library. FONT-NAME is the full path \(a pathname or a string) 109 | to a TrueType font file, or a font face name if the GDFONTPATH 110 | environment variable or FreeType's DEFAULT_FONTPATH variable have been 111 | set intelligently. The string may be arbitrarily scaled \(POINT-SIZE) 112 | and rotated \(ANGLE in radians). The direction of rotation is 113 | counter-clockwise, with 0 radians \(0 degrees) at 3 o'clock and PI/2 114 | radians \(90 degrees) at 12 o'clock. Note that the ANGLE argument is 115 | purposefully _not_ affected by WITH-TRANSFORMATION. If ANTI-ALIASED if 116 | false, anti-aliasing is disabled. It is enabled by default. To output 117 | multiline text with a specific line spacing, provide a value for 118 | LINE-SPACING, expressed as a multiple of the font height. The default 119 | is to use 1.05. The string may contain XML character entity references 120 | like \"À\". If CONVERT-CHARS is true \(which is the default) 121 | characters of STRING with CHAR-CODE greater than 127 are converted 122 | accordingly. This of course pre-supposes that your Lisp's CHAR-CODE 123 | function returns ISO/IEC 10646 (Unicode) character codes. 124 | 125 | The return value is an array containing 8 elements representing the 4 126 | corner coordinates \(lower left, lower right, upper right, upper left) 127 | of the bounding rectangle around the string that was drawn. The points 128 | are relative to the text regardless of the angle, so \"upper left\" 129 | means in the top left-hand corner seeing the text horizontally. Set 130 | DO-NOT-DRAW to true to get the bounding rectangle without 131 | rendering. This is a relatively cheap operation if followed by a 132 | rendering of the same string, because of the caching of the partial 133 | rendering during bounding rectangle calculation." 134 | (check-type string string) 135 | (check-type font-name (or pathname string)) 136 | (unless do-not-draw 137 | (check-type color integer) 138 | (check-type image image)) 139 | (with-transformed-alternative 140 | ((x x-transformer) 141 | (y y-transformer) 142 | ((deref-array c-bounding-rectangle '(:array :int) i) x-inv-transformer) 143 | ((deref-array c-bounding-rectangle '(:array :int) (1+ i)) y-inv-transformer)) 144 | (when do-not-draw 145 | (setq color 0 146 | image *null-image*)) 147 | (when (pathnamep font-name) 148 | (setq font-name (namestring font-name))) 149 | (when convert-chars 150 | (setq string (convert-to-char-references string))) 151 | (with-cstring (c-font-name font-name) 152 | (with-cstring (c-string string) 153 | (with-safe-alloc (c-bounding-rectangle 154 | (allocate-foreign-object :int 8) 155 | (free-foreign-object c-bounding-rectangle)) 156 | (let ((msg (convert-from-cstring 157 | (cond (line-spacing 158 | (with-foreign-object (strex 'gd-ft-string-extra) 159 | (setf (get-slot-value strex 160 | 'gd-ft-string-extra 161 | 'flags) 162 | +gd-ftex-linespace+ 163 | (get-slot-value strex 164 | 'gd-ft-string-extra 165 | 'line-spacing) 166 | (coerce line-spacing 'double-float)) 167 | (gd-image-string-ft-ex (img image) 168 | c-bounding-rectangle 169 | (if anti-aliased color (- color)) 170 | c-font-name 171 | (coerce point-size 'double-float) 172 | (coerce angle 'double-float) 173 | x y 174 | c-string 175 | strex))) 176 | (t 177 | (gd-image-string-ft (img image) 178 | c-bounding-rectangle 179 | (if anti-aliased color (- color)) 180 | c-font-name 181 | (coerce point-size 'double-float) 182 | (coerce angle 'double-float) 183 | x y 184 | c-string)))))) 185 | (when msg 186 | (error "Error in FreeType library: ~A" msg)) 187 | (let ((bounding-rectangle (make-array 8))) 188 | ;; strange iteration due to WITH-TRANSFORMED-ALTERNATIVE 189 | (loop for i below 8 by 2 do 190 | (setf (aref bounding-rectangle i) 191 | (deref-array c-bounding-rectangle '(:array :int) i)) 192 | (setf (aref bounding-rectangle (1+ i)) 193 | (deref-array c-bounding-rectangle '(:array :int) (1+ i)))) 194 | bounding-rectangle))))))) -------------------------------------------------------------------------------- /test/.gitignore: -------------------------------------------------------------------------------- 1 | anti-aliased-lines.png 2 | brushed-arc.png 3 | chart.png 4 | circle.png 5 | clipped-tangent.png 6 | demooutp.png 7 | one-line.jpg 8 | one-line.png 9 | one-pixel.jpg 10 | one-pixel.png 11 | triangle.png 12 | zappa-ellipse.png 13 | zappa-green.jpg 14 | -------------------------------------------------------------------------------- /test/demoin.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/test/demoin.png -------------------------------------------------------------------------------- /test/orig/anti-aliased-lines.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/test/orig/anti-aliased-lines.png -------------------------------------------------------------------------------- /test/orig/brushed-arc.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/test/orig/brushed-arc.png -------------------------------------------------------------------------------- /test/orig/chart.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/test/orig/chart.png -------------------------------------------------------------------------------- /test/orig/circle.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/test/orig/circle.png -------------------------------------------------------------------------------- /test/orig/clipped-tangent.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/test/orig/clipped-tangent.png -------------------------------------------------------------------------------- /test/orig/one-line.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/test/orig/one-line.jpg -------------------------------------------------------------------------------- /test/orig/one-line.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/test/orig/one-line.png -------------------------------------------------------------------------------- /test/orig/one-pixel.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/test/orig/one-pixel.jpg -------------------------------------------------------------------------------- /test/orig/one-pixel.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/test/orig/one-pixel.png -------------------------------------------------------------------------------- /test/orig/triangle.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/test/orig/triangle.png -------------------------------------------------------------------------------- /test/orig/zappa-ellipse.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/test/orig/zappa-ellipse.png -------------------------------------------------------------------------------- /test/orig/zappa-green.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/test/orig/zappa-green.jpg -------------------------------------------------------------------------------- /test/smallzappa.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/test/smallzappa.png -------------------------------------------------------------------------------- /test/zappa.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edicl/cl-gd/0e1812a38f93ece0c3b183a92be6e440cecfd7e6/test/zappa.jpg -------------------------------------------------------------------------------- /transform.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- 2 | ;;; $Header: /usr/local/cvsrep/gd/transform.lisp,v 1.23 2009/11/23 17:05:39 edi Exp $ 3 | 4 | ;;; Copyright (c) 2003-2009, Dr. Edmund Weitz. All rights reserved. 5 | 6 | ;;; Redistribution and use in source and binary forms, with or without 7 | ;;; modification, are permitted provided that the following conditions 8 | ;;; are met: 9 | 10 | ;;; * Redistributions of source code must retain the above copyright 11 | ;;; notice, this list of conditions and the following disclaimer. 12 | 13 | ;;; * Redistributions in binary form must reproduce the above 14 | ;;; copyright notice, this list of conditions and the following 15 | ;;; disclaimer in the documentation and/or other materials 16 | ;;; provided with the distribution. 17 | 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 19 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 22 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 24 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 25 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 26 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | (in-package :cl-gd) 31 | 32 | (defclass transformer () 33 | ((image :initarg :image 34 | :reader image) 35 | (w-transformer :initarg :w-transformer 36 | :reader w-transformer 37 | :type function) 38 | (h-transformer :initarg :h-transformer 39 | :reader h-transformer 40 | :type function) 41 | (x-transformer :initarg :x-transformer 42 | :reader x-transformer 43 | :type function) 44 | (y-transformer :initarg :y-transformer 45 | :reader y-transformer 46 | :type function) 47 | (w-inv-transformer :initarg :w-inv-transformer 48 | :reader w-inv-transformer 49 | :type function) 50 | (h-inv-transformer :initarg :h-inv-transformer 51 | :reader h-inv-transformer 52 | :type function) 53 | (x-inv-transformer :initarg :x-inv-transformer 54 | :reader x-inv-transformer 55 | :type function) 56 | (y-inv-transformer :initarg :y-inv-transformer 57 | :reader y-inv-transformer 58 | :type function) 59 | (angle-transformer :initarg :angle-transformer 60 | :reader angle-transformer 61 | :type function)) 62 | (:documentation "Class used internally for WITH-TRANSFORMATION 63 | macro.")) 64 | 65 | (defmacro without-transformations (&body body) 66 | "Executes BODY without any transformations applied." 67 | `(let (*transformers*) 68 | ,@body)) 69 | 70 | (declaim (inline round-to-c-int)) 71 | (defun round-to-signed-byte-32 (x) 72 | "Like ROUND but make sure result isn't longer than 32 bits." 73 | (mod (round x) +most-positive-unsigned-byte-32+)) 74 | 75 | (defmacro with-transformation ((&key (x1 0 x1set) (x2 0 x2set) (width 0 wset) 76 | (y1 0 y1set) (y2 0 y2set) (height 0 hset) 77 | reverse-x reverse-y (radians t) (image '*default-image*)) 78 | &body body) 79 | "Executes BODY such that all points and width/height data are 80 | subject to a simple affine transformation defined by the keyword 81 | parameters. The new x-axis of IMAGE will start at X1 and end at X2 and 82 | have length WIDTH. The new y-axis of IMAGE will start at Y1 and end at 83 | Y2 and have length HEIGHT. In both cases it suffices to provide two of 84 | the three values - if you provide all three they have to match. If 85 | REVERSE-X is false the x-axis will be oriented as usual in Cartesian 86 | coordinates, otherwise its direction will be reversed. The same 87 | applies to REVERSE-Y, of course. If RADIANS is true angles inside of 88 | BODY will be assumed to be provided in radians, otherwise in degrees." 89 | (with-rebinding (x1 x2 width y1 y2 height reverse-x reverse-y radians image) 90 | (with-unique-names (image-width image-height 91 | stretch-x stretch-y 92 | w-transformer h-transformer 93 | x-transformer y-transformer 94 | w-inv-transformer h-inv-transformer 95 | x-inv-transformer y-inv-transformer 96 | angle-transformer) 97 | ;; rebind for thread safety 98 | `(let ((*transformers* *transformers*)) 99 | (macrolet ((checkargs (a1 a1set a2 a2set aspan aspanset c lbl) 100 | `(progn 101 | (cond ((and ,a1set ,a2set) (setq ,aspan (- ,a2 ,a1))) 102 | ((and ,a1set ,aspanset) (setq ,a2 (+ ,a1 ,aspan))) 103 | ((and ,a2set ,aspanset) (setq ,a1 (- ,a2 ,aspan))) 104 | (t (error "Two of ~c1, ~:*~c2, or ~a must be provided." ,c ,lbl))) 105 | (unless (> ,aspan 0) 106 | (error "~c1 must be smaller than ~:*~c2." ,c)) 107 | (unless (< (abs (/ (- ,a2 (+ ,a1 ,aspan)) ,aspan)) 1.e-5) 108 | (error "~c1, ~:*~c2, and ~a don't match. Try to provide just two of the three arguments." ,c ,lbl))))) 109 | (checkargs ,x1 ,x1set ,x2 ,x2set ,width ,wset #\x "width") 110 | (checkargs ,y1 ,y1set ,y2 ,y2set ,height ,hset #\y "height")) 111 | (multiple-value-bind (,image-width ,image-height) 112 | (without-transformations 113 | (image-size ,image)) 114 | (let* ((,stretch-x (/ ,image-width ,width)) 115 | (,stretch-y (/ ,image-height ,height)) 116 | (,w-transformer (lambda (w) 117 | (round-to-signed-byte-32 118 | (* w ,stretch-x)))) 119 | (,w-inv-transformer (lambda (w) 120 | (/ w ,stretch-x))) 121 | (,h-transformer (lambda (h) 122 | (round-to-signed-byte-32 123 | (* h ,stretch-y)))) 124 | (,h-inv-transformer (lambda (h) 125 | (/ h ,stretch-y))) 126 | (,x-transformer (if ,reverse-x 127 | (lambda (x) 128 | (round-to-signed-byte-32 129 | (* (- ,x2 x) ,stretch-x))) 130 | (lambda (x) 131 | (round-to-signed-byte-32 132 | (* (- x ,x1) ,stretch-x))))) 133 | (,x-inv-transformer (if ,reverse-x 134 | (lambda (x) 135 | (- ,x2 (/ x ,stretch-x))) 136 | (lambda (x) 137 | (+ ,x1 (/ x ,stretch-x))))) 138 | (,y-transformer (if ,reverse-y 139 | (lambda (y) 140 | (round-to-signed-byte-32 141 | (* (- y ,y1) ,stretch-y))) 142 | (lambda (y) 143 | (round-to-signed-byte-32 144 | (* (- ,y2 y) ,stretch-y))))) 145 | (,y-inv-transformer (if ,reverse-y 146 | (lambda (y) 147 | (+ ,y1 (/ y ,stretch-y))) 148 | (lambda (y) 149 | (- ,y2 (/ y ,stretch-y))))) 150 | (,angle-transformer (cond (,radians 151 | (lambda (angle) 152 | (round-to-signed-byte-32 153 | (* angle 154 | +radians-to-degree-factor+)))) 155 | (t 156 | #'identity)))) 157 | (push (make-instance 'transformer 158 | :image ,image 159 | :w-transformer ,w-transformer 160 | :h-transformer ,h-transformer 161 | :x-transformer ,x-transformer 162 | :y-transformer ,y-transformer 163 | :w-inv-transformer ,w-inv-transformer 164 | :h-inv-transformer ,h-inv-transformer 165 | :x-inv-transformer ,x-inv-transformer 166 | :y-inv-transformer ,y-inv-transformer 167 | :angle-transformer ,angle-transformer) 168 | *transformers*) 169 | (unwind-protect 170 | (progn 171 | ,@body) 172 | (pop *transformers*)))))))) 173 | 174 | (defmacro with-transformed-alternative ((&rest transformations) &body body) 175 | "Internal macro used to make functions 176 | transformation-aware. TRANSFORMATION is a list of (EXPR 177 | TRANSFORMATION) pairs where each EXPR will be replaced by the 178 | transformation denoted by TRANSFORMATION." 179 | (with-unique-names (transformer) 180 | (let ((transformations-alist 181 | (loop for (expr transformation) in transformations 182 | collect `(,expr . (funcall (,transformation ,transformer) ,expr))))) 183 | ;; note that we always use the name 'IMAGE' - no problem because 184 | ;; this is a private macro 185 | `(let ((,transformer (find image *transformers* :key #'image))) 186 | (cond (,transformer 187 | ,(sublis transformations-alist 188 | `(progn ,@body) 189 | :test #'equal)) 190 | (t (progn 191 | ,@body))))))) 192 | -------------------------------------------------------------------------------- /util.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- 2 | ;;; $Header: /usr/local/cvsrep/gd/util.lisp,v 1.16 2009/11/23 17:05:39 edi Exp $ 3 | 4 | ;;; Copyright (c) 2003-2009, Dr. Edmund Weitz. All rights reserved. 5 | 6 | ;;; Redistribution and use in source and binary forms, with or without 7 | ;;; modification, are permitted provided that the following conditions 8 | ;;; are met: 9 | 10 | ;;; * Redistributions of source code must retain the above copyright 11 | ;;; notice, this list of conditions and the following disclaimer. 12 | 13 | ;;; * Redistributions in binary form must reproduce the above 14 | ;;; copyright notice, this list of conditions and the following 15 | ;;; disclaimer in the documentation and/or other materials 16 | ;;; provided with the distribution. 17 | 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 19 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 22 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 24 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 25 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 26 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | (in-package :cl-gd) 31 | 32 | #+:lispworks 33 | (import 'lw:with-unique-names) 34 | 35 | #-:lispworks 36 | (defmacro with-unique-names ((&rest bindings) &body body) 37 | "Syntax: WITH-UNIQUE-NAMES ( { var | (var x) }* ) declaration* form* 38 | 39 | Executes a series of forms with each VAR bound to a fresh, 40 | uninterned symbol. The uninterned symbol is as if returned by a call 41 | to GENSYM with the string denoted by X - or, if X is not supplied, the 42 | string denoted by VAR - as argument. 43 | 44 | The variable bindings created are lexical unless special declarations 45 | are specified. The scopes of the name bindings and declarations do not 46 | include the Xs. 47 | 48 | The forms are evaluated in order, and the values of all but the last 49 | are discarded \(that is, the body is an implicit PROGN)." 50 | ;; reference implementation posted to comp.lang.lisp as 51 | ;; by Vebjorn Ljosa - see also 52 | ;; 53 | `(let ,(mapcar #'(lambda (binding) 54 | (check-type binding (or cons symbol)) 55 | (if (consp binding) 56 | (destructuring-bind (var x) binding 57 | (check-type var symbol) 58 | `(,var (gensym ,(etypecase x 59 | (symbol (symbol-name x)) 60 | (character (string x)) 61 | (string x))))) 62 | `(,binding (gensym ,(symbol-name binding))))) 63 | bindings) 64 | ,@body)) 65 | 66 | #+:lispworks 67 | (eval-when (:compile-toplevel :load-toplevel :execute) 68 | (setf (macro-function 'with-rebinding) 69 | (macro-function 'lw:rebinding))) 70 | 71 | #-:lispworks 72 | (defmacro with-rebinding (bindings &body body) 73 | "REBINDING ( { var | (var prefix) }* ) form* 74 | 75 | Evaluates a series of forms in the lexical environment that is 76 | formed by adding the binding of each VAR to a fresh, uninterned 77 | symbol, and the binding of that fresh, uninterned symbol to VAR's 78 | original value, i.e., its value in the current lexical environment. 79 | 80 | The uninterned symbol is created as if by a call to GENSYM with the 81 | string denoted by PREFIX - or, if PREFIX is not supplied, the string 82 | denoted by VAR - as argument. 83 | 84 | The forms are evaluated in order, and the values of all but the last 85 | are discarded \(that is, the body is an implicit PROGN)." 86 | ;; reference implementation posted to comp.lang.lisp as 87 | ;; by Vebjorn Ljosa - see also 88 | ;; 89 | (loop for binding in bindings 90 | for var = (if (consp binding) (car binding) binding) 91 | for name = (gensym) 92 | collect `(,name ,var) into renames 93 | collect ``(,,var ,,name) into temps 94 | finally (return `(let ,renames 95 | (with-unique-names ,bindings 96 | `(let (,,@temps) 97 | ,,@body)))))) 98 | 99 | (defun sans (plist &rest keys) 100 | "Returns PLIST with keyword arguments from KEYS removed." 101 | ;; stolen from Usenet posting <3247672165664225@naggum.no> by Erik 102 | ;; Naggum 103 | (let ((sans ())) 104 | (loop 105 | (let ((tail (nth-value 2 (get-properties plist keys)))) 106 | ;; this is how it ends 107 | (unless tail 108 | (return (nreconc sans plist))) 109 | ;; copy all the unmatched keys 110 | (loop until (eq plist tail) do 111 | (push (pop plist) sans) 112 | (push (pop plist) sans)) 113 | ;; skip the matched key 114 | (setq plist (cddr plist)))))) 115 | 116 | (defun convert-to-char-references (string) 117 | "Returns a string where all characters of STRING with CHAR-CODE 118 | greater than 127 are converted to XML character entities." 119 | (with-output-to-string (s) 120 | (with-standard-io-syntax 121 | (loop for char across string 122 | for char-code = (char-code char) 123 | when (<= char-code 127) do 124 | (write-char char s) 125 | else do 126 | (write-char #\& s) 127 | (write-char #\# s) 128 | (princ char-code s) 129 | (write-char #\; s))))) 130 | 131 | (defmacro with-safe-alloc ((var alloc free) &rest body) 132 | `(let (,var) 133 | (unwind-protect 134 | (progn (setf ,var ,alloc) 135 | ,@body) 136 | (when ,var ,free)))) --------------------------------------------------------------------------------