From eweitz at common-lisp.net Wed Apr 30 08:35:01 2008 From: eweitz at common-lisp.net (eweitz at common-lisp.net) Date: Wed, 30 Apr 2008 04:35:01 -0400 (EDT) Subject: [cl-gd-cvs] r1 - branches Message-ID: <20080430083501.A66B5620A4@common-lisp.net> Author: eweitz Date: Wed Apr 30 04:35:01 2008 New Revision: 1 Added: branches/ Log: Branches dir From eweitz at common-lisp.net Wed Apr 30 08:35:10 2008 From: eweitz at common-lisp.net (eweitz at common-lisp.net) Date: Wed, 30 Apr 2008 04:35:10 -0400 (EDT) Subject: [cl-gd-cvs] r2 - tags Message-ID: <20080430083510.5ACC7662DE@common-lisp.net> Author: eweitz Date: Wed Apr 30 04:35:10 2008 New Revision: 2 Added: tags/ Log: Tags dir From eweitz at common-lisp.net Wed Apr 30 08:35:19 2008 From: eweitz at common-lisp.net (eweitz at common-lisp.net) Date: Wed, 30 Apr 2008 04:35:19 -0400 (EDT) Subject: [cl-gd-cvs] r3 - trunk Message-ID: <20080430083519.0476D662DE@common-lisp.net> Author: eweitz Date: Wed Apr 30 04:35:18 2008 New Revision: 3 Added: trunk/ Log: Trunk dir From eweitz at common-lisp.net Wed Apr 30 08:35:28 2008 From: eweitz at common-lisp.net (eweitz at common-lisp.net) Date: Wed, 30 Apr 2008 04:35:28 -0400 (EDT) Subject: [cl-gd-cvs] r4 - trunk/cl-gd Message-ID: <20080430083528.56284671CC@common-lisp.net> Author: eweitz Date: Wed Apr 30 04:35:28 2008 New Revision: 4 Added: trunk/cl-gd/ Log: CL-GD dir From eweitz at common-lisp.net Wed Apr 30 08:38:55 2008 From: eweitz at common-lisp.net (eweitz at common-lisp.net) Date: Wed, 30 Apr 2008 04:38:55 -0400 (EDT) Subject: [cl-gd-cvs] r5 - in trunk/cl-gd: . doc test test/orig Message-ID: <20080430083855.612FC1A0E5@common-lisp.net> Author: eweitz Date: Wed Apr 30 04:38:52 2008 New Revision: 5 Added: trunk/cl-gd/CHANGELOG trunk/cl-gd/Makefile trunk/cl-gd/README trunk/cl-gd/cl-gd-glue.c trunk/cl-gd/cl-gd-test.asd trunk/cl-gd/cl-gd-test.lisp trunk/cl-gd/cl-gd.asd trunk/cl-gd/colors-aux.lisp trunk/cl-gd/colors.lisp trunk/cl-gd/doc/ trunk/cl-gd/doc/anti-aliased-lines.png (contents, props changed) trunk/cl-gd/doc/brushed-arc.png (contents, props changed) trunk/cl-gd/doc/chart.png (contents, props changed) trunk/cl-gd/doc/clipped-tangent.png (contents, props changed) trunk/cl-gd/doc/demooutp.png (contents, props changed) trunk/cl-gd/doc/gddemo.c trunk/cl-gd/doc/index.html trunk/cl-gd/doc/smallzappa.png (contents, props changed) trunk/cl-gd/doc/strings.png (contents, props changed) trunk/cl-gd/doc/triangle.png (contents, props changed) trunk/cl-gd/doc/zappa-ellipse.png (contents, props changed) trunk/cl-gd/doc/zappa-green.jpg (contents, props changed) trunk/cl-gd/doc/zappa.jpg (contents, props changed) trunk/cl-gd/drawing.lisp trunk/cl-gd/gd-uffi.lisp trunk/cl-gd/images.lisp trunk/cl-gd/init.lisp trunk/cl-gd/misc.lisp trunk/cl-gd/packages.lisp trunk/cl-gd/specials.lisp trunk/cl-gd/strings.lisp trunk/cl-gd/svn-commit.2.tmp trunk/cl-gd/svn-commit.tmp trunk/cl-gd/test/ trunk/cl-gd/test/demoin.png (contents, props changed) trunk/cl-gd/test/orig/ trunk/cl-gd/test/orig/anti-aliased-lines.png (contents, props changed) trunk/cl-gd/test/orig/brushed-arc.png (contents, props changed) trunk/cl-gd/test/orig/chart.png (contents, props changed) trunk/cl-gd/test/orig/circle.png (contents, props changed) trunk/cl-gd/test/orig/clipped-tangent.png (contents, props changed) trunk/cl-gd/test/orig/one-line.jpg (contents, props changed) trunk/cl-gd/test/orig/one-line.png (contents, props changed) trunk/cl-gd/test/orig/one-pixel.jpg (contents, props changed) trunk/cl-gd/test/orig/one-pixel.png (contents, props changed) trunk/cl-gd/test/orig/triangle.png (contents, props changed) trunk/cl-gd/test/orig/zappa-ellipse.png (contents, props changed) trunk/cl-gd/test/orig/zappa-green.jpg (contents, props changed) trunk/cl-gd/test/smallzappa.png (contents, props changed) trunk/cl-gd/test/zappa.jpg (contents, props changed) trunk/cl-gd/transform.lisp trunk/cl-gd/util.lisp Log: Import current version Added: trunk/cl-gd/CHANGELOG ============================================================================== --- (empty file) +++ trunk/cl-gd/CHANGELOG Wed Apr 30 04:38:52 2008 @@ -0,0 +1,102 @@ +Version 0.5.6 +2007-07-29 +Make WITH-TRANSFORMATIONS thread-safe (thanks to Alain Picard) + +Version 0.5.5 +2007-04-24 +Ugh, fix the fix once more (again thanks to Jong-won Choi) + +Version 0.5.4 +2007-04-06 +Trying to fix the 0.5.3 fix... (bug reported by Jong-won Choi) + +Version 0.5.3 +2007-03-19 +Fixed bug in DRAW-FREETYPE-STRING (reported by Andrei Stebakov) + +Version 0.5.2 +2007-02-28 +Fix CONVERT-TO-CHAR-REFERENCES (bug caught by Luo Yong) +Documentation fixes (thanks to Yoni Rabkin Katzenell) + +Version 0.5.1 +2005-10-04 +Support for OpenMCL via CFFI (thanks to Bryan O'Connor) + +Version 0.5.0 +2005-09-26 +Experimental CLISP/CFFI support (thanks to Luis Oliveira) +Don't redefine what's already there (for LispWorks) + +Version 0.4.8 +2005-05-17 +Re-enabled the ability to build without GIF support + +Version 0.4.7 +2005-05-07 +Added GET-PIXEL (provided by Alan Shields) + +Version 0.4.6 +2005-03-31 +Fixed typo in WITH-IMAGE* (thanks to Peter Barabas) +Handle CMUCL search lists correctly (thanks to Hans H?bner) +Added -lc option to linker call and included makefile (thanks to Hans H?bner) + +Version 0.4.5 +2005-03-16 +Fixed type check in MAKE-STREAM-FN (thanks to Walter C. Pelissero) + +Version 0.4.4 +2005-03-09 +More bug fixes (thanks to Carlos Ungil) + +Version 0.4.3 +2005-03-09 +Some bug fixes (thanks to Carlos Ungil) + +Version 0.4.2 +2004-11-26 +Build GIF support by default +Added link to cl-gd-glue.dll for Windows and corresponding documentation +Updated files in test/orig + +Version 0.4.1 +2004-05-21 +Replaced WRITE-BYTE with WRITE-SEQUENCE for LispWorks - see + +Version 0.3.1 +2004-04-25 +Two separate C source files (with and without GIF support) +Added note about failed tests +Added hyperdoc support +Added :CL-GD to *FEATURES* + +Version 0.3.0 +2004-03-29 +Added GIF support (thanks to Hans H?bner) +Added Gentoo link + +Version 0.2.0 +2003-10-26 +Added DO-PIXELS and friends (proposed by Kevin Rosenberg) +Added Debian link + +Version 0.1.4 +2003-08-29 +Added library path for Debian compatibility (thanks to Kevin Rosenberg) + +Version 0.1.3 +2003-08-29 +Make CL-GD-TEST output less verbose for SBCL (thanks to Christophe Rhodes) + +Version 0.1.2 +2003-08-28 +Changed WITH-TRANSFORMATION macro to keep SBCL from complaining (thanks to Christophe Rhodes) + +Version 0.1.1 +2003-08-28 +Fixed *NULL-IMAGE* bug in DRAW-FREETYPE-STRING + +Version 0.1.0 +2003-08-26 +Initial release Added: trunk/cl-gd/Makefile ============================================================================== --- (empty file) +++ trunk/cl-gd/Makefile Wed Apr 30 04:38:52 2008 @@ -0,0 +1,11 @@ +# this should work for FreeBSD and most Linux distros + +cl-gd-glue.so: + gcc -I/usr/local/include -fPIC -c cl-gd-glue.c + ld -shared -lgd -lz -lpng -ljpeg -lfreetype -liconv -lm -lc cl-gd-glue.o -o cl-gd-glue.so -L/usr/local/lib + rm cl-gd-glue.o + +# this should work for Mac OS X + +cl-gd-glue.dylib: + gcc -lgd -ljpeg -dynamiclib cl-gd-glue.c -o cl-gd-glue.dylib Added: trunk/cl-gd/README ============================================================================== --- (empty file) +++ trunk/cl-gd/README Wed Apr 30 04:38:52 2008 @@ -0,0 +1,69 @@ +Complete documentation for CL-GD can be found in the 'doc' +directory. + +CL-GD also supports Nikodemus Siivola's HYPERDOC, see + and +. + +1. Installation (see doc/index.html for Windows instructions) + +1.1. Download and install a recent version of asdf. + +1.2. Download and install UFFI. CL-GD needs at least version 1.3.4 of + UFFI to work properly. However, as of August 2003, only + AllegroCL, CMUCL, LispWorks, SBCL, and SCL are fully supported + because CL-GD needs the new UFFI macros WITH-CAST-POINTER and + DEF-FOREIGN-VAR which haven't yet been ported to all UFFI + platforms. + +1.3. Download and install a recent version of GD and its supporting + libraries libpng, zlib, libjpeg, libiconv, and libfreetype. CL-GD has + been tested with GD 2.0.33, versions older than 2.0.28 won't + work. Note that you won't be able to compile CL-GD unless you have + installed all supporting libraries. This is different from using + GD directly from C where you only have to install the libraries + you intend to use. + +1.4. Unzip and untar the file cl-gd.tgz and put the resulting + directory wherever you want, then cd into this directory. + +1.5. Compile cl-gd-glue.c into a shared library for your platform. On + Linux this would be + + gcc -fPIC -c cl-gd-glue.c + ld -lgd -lz -lpng -ljpeg -lfreetype -lm -liconv -shared cl-gd-glue.o -o cl-gd-glue.so + rm cl-gd-glue.o + + For Mac OS X, use + + gcc -lgd -ljpeg -dynamiclib cl-gd-glue.c -o cl-gd-glue.dylib + +1.6. Make sure that cl-gd.asd can be seen from asdf (this is usually + achieved by a symbolic link), start your favorite Lisp, and compile + CL-GD: + + (asdf:oos 'asdf:compile-op :cl-gd) + + From now on you can simply load CL-GD into a running Lisp image + with + + (asdf:oos 'asdf:load-op :cl-gd) + +2. Test + +CL-GD comes with a simple test suite that can be used to check if it's +basically working. Note that this'll only test a subset of CL-GD. To +run the tests load CL-GD and then + + (asdf:oos 'asdf:load-op :cl-gd-test) + (cl-gd-test:test) + +If you have the georgiab.ttf TrueType font from Microsoft you can also +check the FreeType support of CL-GD with + + (cl-gd-test:test #p"/usr/X11R6/lib/X11/fonts/truetype/georgiab.ttf") + +where you should obviously replace the path above with the full path +to the font on your machine. + +(See the note about failed tests in the documentation.) \ No newline at end of file Added: trunk/cl-gd/cl-gd-glue.c ============================================================================== --- (empty file) +++ trunk/cl-gd/cl-gd-glue.c Wed Apr 30 04:38:52 2008 @@ -0,0 +1,187 @@ +/* Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials + provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED + OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY + DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE + GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, + WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ + +#include +#include +#include "gd.h" + +gdImagePtr gdImageCreateFromJpegFile (char *filename, int *err) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromJpeg(in); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} + +#ifndef GD_DONT_USE_GIF +gdImagePtr gdImageCreateFromGifFile (char *filename, int *err) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromGif(in); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} +#endif + +gdImagePtr gdImageCreateFromPngFile (char *filename, int *err) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromPng(in); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} + +gdImagePtr gdImageCreateFromGdFile (char *filename, int *err) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromGd(in); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} + +gdImagePtr gdImageCreateFromGd2File (char *filename, int *err) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromGd2(in); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} + +gdImagePtr gdImageCreateFromGd2PartFile (char *filename, int *err, int srcX, int srcY, int w, int h) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromGd2Part(in, srcX, srcY, w, h); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} + +gdImagePtr gdImageCreateFromXbmFile (char *filename, int *err) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromXbm(in); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} + +int gdImageGetAlpha (gdImagePtr im, int color) { + return gdImageAlpha(im, color); +} + +int gdImageGetRed (gdImagePtr im, int color) { + return gdImageRed(im, color); +} + +int gdImageGetGreen (gdImagePtr im, int color) { + return gdImageGreen(im, color); +} + +int gdImageGetBlue (gdImagePtr im, int color) { + return gdImageBlue(im, color); +} + +int gdImageGetSX (gdImagePtr im) { + return gdImageSX(im); +} + +int gdImageGetSY (gdImagePtr im) { + return gdImageSY(im); +} + +int gdImageGetColorsTotal (gdImagePtr im) { + return gdImageColorsTotal(im); +} + +/* dumb names, I know... */ +int gdImageGetGetInterlaced (gdImagePtr im) { + return gdImageGetInterlaced(im); +} + +int gdImageGetGetTransparent (gdImagePtr im) { + return gdImageGetTransparent(im); +} Added: trunk/cl-gd/cl-gd-test.asd ============================================================================== --- (empty file) +++ trunk/cl-gd/cl-gd-test.asd Wed Apr 30 04:38:52 2008 @@ -0,0 +1,45 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/cl-gd-test.asd,v 1.11 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-user) + +(defpackage :cl-gd-test.system + (:use :cl :asdf)) + +(in-package :cl-gd-test.system) + +(defparameter *cl-gd-test-directory* + (make-pathname :name nil :type nil :version nil + :defaults (parse-namestring *load-truename*))) + +(defsystem :cl-gd-test + :version "0.4.8" + :components ((:file "cl-gd-test")) + :depends-on (:cl-gd)) + Added: trunk/cl-gd/cl-gd-test.lisp ============================================================================== --- (empty file) +++ trunk/cl-gd/cl-gd-test.lisp Wed Apr 30 04:38:52 2008 @@ -0,0 +1,490 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/cl-gd-test.lisp,v 1.26 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-user) + +(defpackage #:cl-gd-test + (:use #:cl + #:cl-gd) + (:export #:test)) + +(in-package :cl-gd-test) + +(defparameter *test-directory* + (merge-pathnames (make-pathname :directory '(:relative "test")) + (make-pathname :name nil + :type nil + :version :newest + :defaults cl-gd.system:*cl-gd-directory*)) + + "Where test files are put.") + +(defun test-file-location (name &optional (type :unspecific)) + "Create test file location from NAME and TYPE component." + (make-pathname :name name + :type type + :defaults *test-directory*)) + +(defun compare-files (file &key type expected-result) + "Compare test file FILE to orginal file in subdirectory ORIG." + (with-image-from-file (image file) + (with-image-from-file (orig (merge-pathnames + (make-pathname :type + (or type (pathname-type file)) + :directory + '(:relative "orig")) + file)) + (equal (differentp image orig) + expected-result)))) + +(defun test-001 () + (let ((file (test-file-location "one-pixel" "png"))) + ;; 40x40 image + (with-image* (40 40) + ;; white background + (allocate-color 255 255 255) + ;; black pixel in the middle + (set-pixel 20 20 :color (allocate-color 0 0 0)) + ;; write to PNG target + (write-image-to-file file :if-exists :supersede)) + ;; compare to existing file + (compare-files file))) + +(defun test-002 () + (let ((file (test-file-location "one-pixel" "jpg"))) + ;; 40x40 image + (with-image* (40 40) + ;; white background + (allocate-color 255 255 255) + ;; black pixel in the middle + (set-pixel 20 20 :color (allocate-color 0 0 0)) + ;; write to JPEG target + (write-image-to-file file :if-exists :supersede)) + ;; compare to existing file + (compare-files file))) + +(defun test-003 () + (let ((file (test-file-location "one-line" "png"))) + ;; 40x40 image + (with-image* (40 40) + ;; white background + (allocate-color 255 255 255) + ;; anti-aliased black line + (draw-line 20 20 30 30 + :color (make-anti-aliased + (allocate-color 0 0 0))) + ;; write to PNG target + (write-image-to-file file :if-exists :supersede)) + ;; compare to existing file + (compare-files file))) + +(defun test-004 () + (let ((file (test-file-location "one-line" "jpg"))) + ;; 40x40 image + (with-image* (40 40) + ;; white background + (allocate-color 255 255 255) + ;; anti-aliased black line + (draw-line 20 20 30 30 + :color (make-anti-aliased + (allocate-color 0 0 0))) + ;; write to JPEG target + (write-image-to-file file :if-exists :supersede)) + ;; compare to existing PNG file + (compare-files file))) + +(defun test-005 () + (with-image-from-file* ((test-file-location "one-pixel" "png")) + (let ((num (number-of-colors))) + (find-color 255 255 255 :resolve t) + (multiple-value-bind (width height) + (image-size) + (and (= width 40) + (= height 40) + ;; FIND-COLOR should not have changed the number of + ;; colors + (= num (number-of-colors))))))) + +(defun test-006 () + (with-image-from-file* ((test-file-location "one-pixel" "png")) + (with-transformation (:x1 0.1 :x2 0.5 :y1 10.8 :y2 20.9) + (multiple-value-bind (width height) + (image-size) + ;; make sure WITH-TRANSFORMATION returns transformed size + (and (>= 0.0001 (abs (- 0.4 width))) + (>= 0.0001 (abs (- 10.1 height)))))))) + +(defun test-007 () + (let ((file (test-file-location "circle" "png"))) + (with-image* (40 40) + (allocate-color 255 255 255) + (let ((black (allocate-color 0 0 0))) + (with-default-color (black) + ;; move origin to center and stretch + (with-transformation (:x1 -100 :width 200 :y1 -100 :height 200) + (draw-filled-circle 0 0 50) + (write-image-to-file file + :if-exists :supersede))))) + (compare-files file))) + +(defun test-008 () + (with-image (image 40 40) + (allocate-color 255 255 255 :image image) + (with-default-color ((allocate-color 0 0 0 :image image)) + ;; no transformation and use more general ellipse function + (draw-filled-ellipse 20 20 20 20 :image image) + (with-image-from-file (other-image + (test-file-location "circle" "png")) + (not (differentp image other-image)))))) + +(defun test-009 () + (let ((file (test-file-location "chart" "png"))) + ;; create 200x200 pixel image + (with-image* (200 200) + ;; background color + (allocate-color 68 70 85) + (let ((beige (allocate-color 222 200 81)) + (brown (allocate-color 206 150 75)) + (green (allocate-color 104 156 84)) + (red (allocate-color 163 83 84)) + (white (allocate-color 255 255 255)) + (two-pi (* 2 pi))) + ;; move origin to center of image + (with-transformation (:x1 -100 :x2 100 :y1 -100 :y2 100 :radians t) + ;; draw some 'pie slices' + (draw-arc 0 0 130 130 0 (* .6 two-pi) + :center-connect t :filled t :color beige) + (draw-arc 0 0 130 130 (* .6 two-pi) (* .8 two-pi) + :center-connect t :filled t :color brown) + (draw-arc 0 0 130 130 (* .8 two-pi) (* .95 two-pi) + :center-connect t :filled t :color green) + (draw-arc 0 0 130 130 (* .95 two-pi) two-pi + :center-connect t :filled t :color red) + ;; use GD fonts + (with-default-color (white) + (with-default-font (:small) + (draw-string -8 -30 "60%") + (draw-string -20 40 "20%") + (draw-string 20 30 "15%")) + (draw-string -90 90 "Global Revenue" + :font :large)) + (write-image-to-file file + :compression-level 6 + :if-exists :supersede)))) + (compare-files file))) + +(defun test-010 () + (let ((file (test-file-location "zappa-green" "jpg"))) + ;; get JPEG from disk + (with-image-from-file (old (test-file-location "zappa" "jpg")) + (multiple-value-bind (width height) + (image-size old) + (with-image (new width height) + ;; green color for background + (allocate-color 0 255 0 :image new) + ;; merge with original JPEG + (copy-image old new 0 0 0 0 width height + :merge 50) + (write-image-to-file file + :image new + :if-exists :supersede)))) + (compare-files file))) + +(defun test-011 () + ;; small image + (with-image* (10 10) + (loop for i below +max-colors+ do + ;; allocate enough colors (all gray) to fill the palette + (allocate-color i i i)) + (and (= +max-colors+ (number-of-colors)) + (null (find-color 255 0 0 :exact t)) + (let ((match (find-color 255 0 0))) ; green + (and (= 85 + (color-component :red match) + (color-component :green match) + (color-component :blue match))))))) + +(defun test-012 () + (let ((file (test-file-location "triangle" "png"))) + (with-image* (100 100) + (allocate-color 255 255 255) ; white background + (let ((red (allocate-color 255 0 0)) + (yellow (allocate-color 255 255 0)) + (orange (allocate-color 255 165 0))) + ;; thin black border + (draw-rectangle* 0 0 99 99 + :color (allocate-color 0 0 0)) + ;; lines are five pixels thick + (with-thickness (5) + ;; colored triangle + (draw-polygon (list 10 10 90 50 50 90) + ;; styled color + :color (list red red red + yellow yellow yellow + nil nil nil + orange orange orange)) + (write-image-to-file file + :compression-level 8 + :if-exists :supersede)))) + (compare-files file))) + +(defun test-013 () + (let ((file (test-file-location "brushed-arc" "png"))) + (with-image* (200 100) + (allocate-color 255 165 0) ; orange background + (with-image (brush 6 6) + (let* ((black (allocate-color 0 0 0 :image brush)) ; black background + (red (allocate-color 255 0 0 :image brush)) + (blue (allocate-color 0 0 255 :image brush))) + (setf (transparent-color brush) black) ; make background transparent + ;; now set the pixels in the brush + (set-pixels '(2 2 2 3 3 2 3 3) + :color blue :image brush) + (set-pixels '(1 2 1 3 4 2 4 3 2 1 3 1 2 4 3 4) + :color red :image brush) + ;; then use it to draw an arc + (draw-arc 100 50 180 80 180 300 :color (make-brush brush))) + (write-image-to-file file + :compression-level 7 + :if-exists :supersede))) + (compare-files file))) + +(defun test-014 () + (let ((file (test-file-location "anti-aliased-lines" "png"))) + (with-image* (150 50) + (let ((orange (allocate-color 255 165 0)) ; orange background + (white (allocate-color 255 255 255)) + (red (allocate-color 255 0 0))) + ;; white background rectangle in the middle third + (draw-rectangle* 50 0 99 49 + :filled t + :color white) + (with-thickness (2) + ;; just a red line + (draw-line 5 10 145 10 :color red) + ;; anti-aliased red line + (draw-line 5 25 145 25 :color (make-anti-aliased red)) + ;; anti-aliased red line which should stand out against + ;; orange background + (draw-line 5 40 145 40 :color (make-anti-aliased red orange)))) + (write-image-to-file file + :compression-level 3 + :if-exists :supersede)) + (compare-files file))) + +(defun test-015 () + (let ((file (test-file-location "clipped-tangent" "png"))) + (with-image* (150 150) + (allocate-color 255 255 255) ; white background + ;; transform such that x axis ranges from (- PI) to PI and y + ;; axis ranges from -3 to 3 + (with-transformation (:x1 (- pi) :width (* 2 pi) :y1 -3 :y2 3) + (let ((black (allocate-color 0 0 0)) + (red (allocate-color 255 0 0)) + (rectangle (list (- .4 pi) 2.5 (- pi .4) -2.5))) + (with-default-color (black) + ;; draw axes + (draw-line 0 -3 0 3 :color black) + (draw-line (- pi) 0 pi 0)) + ;; show clipping rectangle (styled) + (draw-rectangle rectangle :color (list black black black nil black nil)) + (with-clipping-rectangle (rectangle) + ;; draw tangent function + (loop for x from (- pi) below (* 2 pi) by (/ pi 75) do + (set-pixel x (tan x) :color red))))) + (write-image-to-file file + :if-exists :supersede)) + (compare-files file))) + +(defun gd-demo-picture (file random-state &optional write-file) + (with-image* ((+ 256 384) 384 t) + (let ((white (allocate-color 255 255 255)) + (red (allocate-color 255 0 0)) + (green (allocate-color 0 255 0)) + (blue (allocate-color 0 0 255)) + (vertices (list 64 0 0 128 128 128)) + (image-width (image-width)) + (image-height (image-height))) + (setf (transparent-color) white) + (draw-rectangle* 0 0 image-width image-height :color white) + (with-image-from-file (in-file (test-file-location "demoin" "png")) + (copy-image in-file *default-image* + 0 0 32 32 192 192 + :resize t + :dest-width 255 + :dest-height 255 + :resample t) + (multiple-value-bind (in-width in-height) + (image-size in-file) + (loop for a below 360 by 45 do + (copy-image in-file *default-image* + 0 0 + (+ 256 192 (* 128 (cos (* a .0174532925)))) + (- 192 (* 128 (sin (* a .0174532925)))) + in-width in-height + :rotate t + :angle a)) + (with-default-color (green) + (with-thickness (4) + (draw-line 16 16 240 16) + (draw-line 240 16 240 240) + (draw-line 240 240 16 240) + (draw-line 16 240 16 16)) + (draw-polygon vertices :filled t)) + (dotimes (i 3) + (incf (nth (* 2 i) vertices) 128)) + (draw-polygon vertices + :color (make-anti-aliased green) + :filled t) + (with-default-color (blue) + (draw-arc 128 128 60 20 0 720) + (draw-arc 128 128 40 40 90 270) + (fill-image 8 8)) + (with-image (brush 16 16 t) + (copy-image in-file brush + 0 0 0 0 + in-width in-height + :resize t + :dest-width (image-width brush) + :dest-height (image-height brush)) + (draw-line 0 255 255 0 + :color (cons (make-brush brush) + (list nil nil nil nil nil nil nil t)))))) + (with-default-color (red) + (draw-string 32 32 "hi" :font :giant) + (draw-string 64 64 "hi" :font :small)) + (with-clipping-rectangle* (0 (- image-height 100) 100 image-height) + (with-default-color ((make-anti-aliased white)) + (dotimes (i 100) + (draw-line (random image-width random-state) + (random image-height random-state) + (random image-width random-state) + (random image-height random-state)))))) + (setf (interlacedp) t) + (true-color-to-palette) + (if write-file + (write-image-to-file file + :if-exists :supersede) + (with-image-from-file (demo-file file) + (not (differentp demo-file *default-image*)))))) + +(defun test-016 () + (let* ((file (test-file-location "demooutp" "png")) + (random-state-1 (make-random-state t)) + (random-state-2 (make-random-state random-state-1))) + (gd-demo-picture file random-state-1 t) + (gd-demo-picture file random-state-2))) + +(defun test-017 () + (let ((file (test-file-location "zappa-ellipse" "png"))) + (with-image* (250 150) + (with-image-from-file (zappa (test-file-location "smallzappa" "png")) + (setf (transparent-color) (allocate-color 255 255 255)) + (draw-filled-ellipse 125 75 250 150 + :color (make-tile zappa))) + (write-image-to-file file + :if-exists :supersede)) + (compare-files file))) + +(defun test-018 () + (let (result) + (with-image* (3 3) + (allocate-color 255 255 255) + (draw-line 0 0 2 2 :color (allocate-color 0 0 0)) + (do-rows (y) + (let (row) + (do-pixels-in-row (x) + (push (list x y (raw-pixel)) row)) + (push (nreverse row) result)))) + (equal + (nreverse result) + '(((0 0 1) (1 0 0) (2 0 0)) + ((0 1 0) (1 1 1) (2 1 0)) + ((0 2 0) (1 2 0) (2 2 1)))))) + +(defun test-019 () + (let (result) + (with-image* (3 3 t) + (draw-rectangle* 0 0 2 2 :color (allocate-color 0 0 0)) + (draw-line 0 0 2 2 :color (allocate-color 255 255 255)) + (do-pixels () + (unless (zerop (raw-pixel)) + (decf (raw-pixel) #xff))) + (do-rows (y) + (let (row) + (do-pixels-in-row (x) + (push (list x y (raw-pixel)) row)) + (push (nreverse row) result)))) + (equal + (nreverse result) + '(((0 0 #xffff00) (1 0 0) (2 0 0)) + ((0 1 0) (1 1 #xffff00) (2 1 0)) + ((0 2 0) (1 2 0) (2 2 #xffff00)))))) + +(defun test-020 (georgia) + ;; not used for test suite because of dependency on font + (with-image* (200 200) + ;; set background (white) and make it transparent + (setf (transparent-color) + (allocate-color 255 255 255)) + (loop for angle from 0 to (* 2 pi) by (/ pi 6) + for blue downfrom 255 by 20 do + (draw-freetype-string 100 100 "Common Lisp" + :font-name georgia + :angle angle + ;; note that ALLOCATE-COLOR won't work + ;; here because the anti-aliasing uses + ;; up too much colors + :color (find-color 0 0 blue + :resolve t))) + (write-image-to-file (test-file-location "strings" "png") + :if-exists :supersede))) + +(defun test% (georgia) + (loop for i from 1 to (if georgia 20 19) do + (handler-case + (format t "Test ~A ~:[failed~;succeeded~].~%" i + (let ((test-function + (intern (format nil "TEST-~3,'0d" i) + :cl-gd-test))) + (if (= i 20) + (funcall test-function georgia) + (funcall test-function)))) + (error (condition) + (format t "Test ~A failed with the following error: ~A~%" + i condition))) + (force-output)) + (format t "Done.~%")) + +(defun test (&optional georgia) + #-:sbcl + (test% georgia) + #+:sbcl + (handler-bind ((sb-ext:compiler-note #'muffle-warning)) + (test% georgia))) \ No newline at end of file Added: trunk/cl-gd/cl-gd.asd ============================================================================== --- (empty file) +++ trunk/cl-gd/cl-gd.asd Wed Apr 30 04:38:52 2008 @@ -0,0 +1,58 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/cl-gd.asd,v 1.18 2007/07/29 16:37:13 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-user) + +(defpackage :cl-gd.system + (:use :cl :asdf) + (:export :*cl-gd-directory*)) + +(in-package :cl-gd.system) + +(defparameter *cl-gd-directory* + (make-pathname :name nil :type nil :version nil + :defaults (parse-namestring *load-truename*))) + +(defsystem :cl-gd + :version "0.5.6" + :serial t + :components ((:file "packages") + (:file "util") + (:file "specials") + (:file "init") + (:file "gd-uffi") + (:file "transform") + (:file "images") + (:file "colors-aux") + (:file "colors") + (:file "drawing") + (:file "strings") + (:file "misc")) + :depends-on (#-(or :clisp :openmcl) :uffi + #+(or :clisp :openmcl) :cffi-uffi-compat)) Added: trunk/cl-gd/colors-aux.lisp ============================================================================== --- (empty file) +++ trunk/cl-gd/colors-aux.lisp Wed Apr 30 04:38:52 2008 @@ -0,0 +1,168 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/colors-aux.lisp,v 1.12 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defun current-brush (&optional (image *default-image*)) + "Returns the GD image which is the current brush of IMAGE \(or NIL +if there is no current brush)." + (check-type image image) + (let ((brush (get-slot-value (img image) 'gd-image 'brush))) + (if (null-pointer-p brush) + nil + brush))) + +(defun (setf current-brush) (brush &optional (image *default-image*)) + "Sets BRUSH \(which must be a GD image) to be the current brush +for IMAGE." + (check-type brush image) + (check-type image image) + (gd-image-set-brush (img image) (img brush)) + brush) + +(defun current-tile (&optional (image *default-image*)) + "Returns the GD image which is the current tile of IMAGE \(or NIL +if there is no current tile)." + (check-type image image) + (let ((tile (get-slot-value (img image) 'gd-image 'tile))) + (if (null-pointer-p tile) + nil + tile))) + +(defun (setf current-tile) (tile &optional (image *default-image*)) + "Sets TILE \(which must be a GD image) to be the current tile +for IMAGE." + (check-type tile (or image null)) + (check-type image image) + (gd-image-set-tile (img image) (img tile)) + tile) + +(defun current-style (&optional (image *default-image*)) + "Returns the current style of IMAGE as a list." + (check-type image image) + (let ((style-length (get-slot-value (img image) 'gd-image 'style-length)) + (style (get-slot-value (img image) 'gd-image 'style))) + (loop for i below style-length + collect (let ((color (deref-array style '(:array :int) i))) + (if (= color +transparent+) + nil + color))))) + +(defun current-style* (&key (image *default-image*)) + "Returns the current style of IMAGE as an array." + (check-type image image) + (let ((style-length (get-slot-value (img image) 'gd-image 'style-length)) + (style (get-slot-value (img image) 'gd-image 'style))) + (loop with result = (make-array style-length) + for i below style-length + do (setf (aref result i) + (let ((color (deref-array style '(:array :int) i))) + (if (= color +transparent+) + nil + color))) + finally (return result)))) + +(defgeneric (setf current-style) (style &optional image) + (:documentation "Sets STYLE to be the current drawing style for +IMAGE. STYLE can be a LIST or a VECTOR. Each element of STYLE is +either a color or NIL \(for transparent pixels).")) + +(defmethod (setf current-style) ((style list) &optional (image *default-image*)) + (check-type image image) + (let ((length (length style))) + (with-safe-alloc (c-style (allocate-foreign-object :int length) + (free-foreign-object c-style)) + (loop for color in style + for i from 0 + do (setf (deref-array c-style '(:array :int) i) + (typecase color + (null +transparent+) + (integer color) + (t 1)))) + (gd-image-set-style (img image) c-style length) + style))) + +(defmethod (setf current-style) ((style vector) &optional (image *default-image*)) + (check-type image image) + (let ((length (length style))) + (with-safe-alloc (c-style (allocate-foreign-object :int length) + (free-foreign-object c-style)) + (loop for color across style + for i from 0 + do (setf (deref-array c-style '(:array :int) i) + (typecase color + (null +transparent+) + (integer color) + (t 1)))) + (gd-image-set-style (img image) c-style length) + style))) + +(defun set-anti-aliased (color do-not-blend &optional (image *default-image*)) + "Set COLOR to be the current anti-aliased color of +IMAGE. DO-NOT-BLEND \(if provided) is the background color +anti-aliased lines stand out against clearly." + (check-type color integer) + (check-type do-not-blend (or integer null)) + (check-type image image) + (gd-image-set-anti-aliased-do-not-blend (img image) + color + (or do-not-blend -1))) + +(defun resolve-c-color (color image) + "Accepts a CL-GD 'color' COLOR and returns the corresponding +argument for GD, modifying internal slots of IMAGE if needed." + (etypecase color + (brush + (setf (current-brush image) color) + +brushed+) + (tile + (setf (current-tile image) color) + +tiled+) + ((cons brush (or vector list)) + (setf (current-brush image) (car color) + (current-style image) (cdr color)) + +styled-brushed+) + (anti-aliased-color + (set-anti-aliased (color color) + (do-not-blend color) + image) + +anti-aliased+) + ((or vector list) + (setf (current-style image) color) + +styled+) + (integer + color))) + +(defmacro with-color-argument (&body body) + "Internal macro used to give correct color arguments to enclosed +foreign functions. Assumes fixed names COLOR and IMAGE." + (with-unique-names (c-color-arg) + `(let ((,c-color-arg (resolve-c-color color image))) + ,@(sublis (list (cons 'color c-color-arg)) + body :test #'eq)))) Added: trunk/cl-gd/colors.lisp ============================================================================== --- (empty file) +++ trunk/cl-gd/colors.lisp Wed Apr 30 04:38:52 2008 @@ -0,0 +1,247 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/colors.lisp,v 1.25 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defmacro with-default-color ((color) &body body) + "Executes BODY with *DEFAULT-COLOR* bound to COLOR so that you don't +have to provide the COLOR keyword/optional argument to drawing +functions." + `(let ((*default-color* ,color)) + , at body)) + +(defun allocate-color (red green blue &key alpha (errorp t) (image *default-image*)) + "Finds the first available color index in the image IMAGE specified, +sets its RGB values to those requested \(255 is the maximum for each), +and returns the index of the new color table entry, or an RGBA value +in the case of a true color image. In either case you can then use the +returned value as a COLOR parameter to drawing functions. When +creating a new palette-based image, the first time you invoke this +function you are setting the background color for that image. If ALPHA +\(not greater than 127) is provided, an RGBA color will always be +allocated. If all +GD-MAX-COLORS+ have already been allocated this +function will, depending on the value of ERRORP, either raise an error +or return NIL." + (check-type red integer) + (check-type green integer) + (check-type blue integer) + (check-type alpha (or null integer)) + (check-type image image) + (let ((result + (if alpha + (gd-image-color-allocate-alpha (img image) red green blue alpha) + (gd-image-color-allocate (img image) red green blue)))) + (cond ((and errorp + (= result -1)) + (error "Can't allocate color")) + ((= result -1) + nil) + (t + result)))) + +(defun deallocate-color (color &optional (image *default-image*)) + "Marks the specified color COLOR as being available for reuse. No +attempt will be made to determine whether the color index is still in +use in the image IMAGE." + (check-type color integer) + (check-type image image) + (gd-image-color-deallocate (img image) color)) + +(defun transparent-color (&optional (image *default-image*)) + "Returns the transparent color of IMAGE \(or NIL if there is none)." + (check-type image image) + (gd-image-get-transparent (img image))) + +(defun (setf transparent-color) (color &optional (image *default-image*)) + "Makes COLOR the transparent color of IMAGE. If COLOR is NIL the +image won't have a transparent color. Note that JPEG images don't +support transparency." + (check-type color (or null integer)) + (check-type image image) + (gd-image-color-transparent (img image) (or color -1)) + color) + +(defun true-color-p (&optional (image *default-image*)) + "Returns true iff IMAGE is a true color image." + (check-type image image) + (not (zerop (get-slot-value (img image) 'gd-image 'true-color)))) + +(defun number-of-colors (&key (image *default-image*)) + "Returns the number of color allocated in IMAGE. Returns NIL if +IMAGE is a true color image." + (check-type image image) + (if (true-color-p image) + nil + (get-slot-value (img image) 'gd-image 'colors-total))) + +(defun find-color (red green blue &key alpha exact hwb resolve (image *default-image*)) + "Tries to find and/or allocate a color from IMAGE's color +palette. If EXACT is true, the color will only be returned if it is +already allocated. If EXACT is NIL, a color which is 'close' to the +color specified by RED, GREEN, and BLUE \(and probably ALPHA) might be +returned \(unless there aren't any colors allocated in the image +yet). If HWB is true, the 'closeness' will be determined by hue, +whiteness, and blackness, otherwise by the Euclidian distance of the +RGB values. If RESOLVE is true a color \(probably a new one) will +always be returned, otherwise the result of this function might be +NIL. If ALPHA \(not greater than 127) is provided, an RGBA color (or +NIL) will be returned. + +ALPHA, EXACT, and HWB are mutually exclusive. RESOLVE can't be used +together with EXACT or HWB." + (check-type red integer) + (check-type green integer) + (check-type blue integer) + (check-type alpha (or null integer)) + (check-type image image) + (when (< 1 (count-if #'identity (list alpha exact hwb))) + (error "You can't specify two of ALPHA, EXACT, and HWB at the same +time")) + (when (and hwb resolve) + (error "You can't specify HWB and RESOLVE at the same time")) + (when (and exact resolve) + (error "You can't specify EXACT and RESOLVE at the same time")) + (let ((result + (cond ((and resolve alpha) + (gd-image-color-resolve-alpha (img image) red green blue alpha)) + (resolve + (gd-image-color-resolve (img image) red green blue)) + (alpha + (gd-image-color-closest-alpha (img image) red green blue alpha)) + (exact + (gd-image-color-exact (img image) red green blue)) + (hwb + (gd-image-color-closest-hwb (img image) red green blue)) + (t + (gd-image-color-closest (img image) red green blue))))) + (if (= result -1) + nil + result))) + +(defun thickness (&optional (image *default-image*)) + "Gets the width of lines drawn by the drawing functions. Note that +this is measured in pixels and is NOT affected by +WITH-TRANSFORMATION." + (check-type image image) + (get-slot-value (img image) 'gd-image 'thick)) + +(defun (setf thickness) (thickness &optional (image *default-image*)) + "Sets the width of lines drawn by the drawing functions. Note that +THICKNESS is measured in pixels and is NOT affected by +WITH-TRANSFORMATION." + (check-type thickness integer) + (check-type image image) + (gd-image-set-thickness (img image) thickness) + thickness) + +(defmacro with-thickness ((thickness &key (image '*default-image*)) &body body) + "Executes BODY with the current line width of IMAGE set to +THICKNESS. The image's previous line width is guaranteed to be +restored before the macro exits. Note that the line width is measured +in pixels and is not affected by WITH-TRANSFORMATION." + (with-unique-names (old-thickness) + ;; we rebind everything so we have left-to-right evaluation + (with-rebinding (thickness image) + `(let ((,old-thickness (thickness ,image))) + (unwind-protect + (progn + (setf (thickness ,image) ,thickness)) + , at body) + (setf (thickness ,image) ,old-thickness))))) + +(defun alpha-blending-p (&optional (image *default-image*)) + "Returns whether pixels drawn on IMAGE will be copied literally +including alpha channel information \(return value is false) or if +their alpha channel information will determine how much of the +underlying color will shine through \(return value is true). This is +only meaningful for true color images." + (check-type image image) + (not (zerop (get-slot-value (img image) 'gd-image 'alpha-blending-flag)))) + +(defun (setf alpha-blending-p) (blending &optional (image *default-image*)) + "Determines whether pixels drawn on IMAGE will be copied literally +including alpha channel information \(if BLENDING is false) or if +their alpha channel information will determine how much of the +underlying color will shine through \(if BLENDING is true). This is +only meaningful for true color images." + (check-type image image) + (gd-image-alpha-blending (img image) (if blending 1 0)) + blending) + +(defun save-alpha-p (&optional (image *default-image*)) + "Returns whether PNG images will be saved with full alpha channel +information." + (check-type image image) + (not (zerop (get-slot-value (img image) 'gd-image 'save-alpha-flag)))) + +(defun (setf save-alpha-p) (save &key (image *default-image*)) + "Determines whether PNG images will be saved with full alpha channel +information." + (check-type image image) + (gd-image-save-alpha (img image) (if save 1 0)) + save) + +(defun color-component (component color &key (image *default-image*)) + "Returns the specified color component of COLOR. COMPONENT can be +one of :RED, :GREEN, :BLUE, and :ALPHA." + (check-type color integer) + (check-type image image) + (funcall (ecase component + ((:red) #'gd-image-get-red) + ((:green) #'gd-image-get-green) + ((:blue) #'gd-image-get-blue) + ((:alpha) #'gd-image-get-alpha)) + (img image) + color)) + +(defun color-components (color &key (image *default-image*)) + "Returns a list of the color components of COLOR. The +components are in the order red, green, blue, alpha." + (mapcar #'(lambda (c) (color-component c color :image image)) + '(:red :green :blue :alpha))) + +(defun find-color-from-image (color source-image &key alpha exact hwb + resolve (image *default-image*)) + "Returns the color in IMAGE corresponding to COLOR in +SOURCE-IMAGE. The keyword parameters are passed to FIND-COLOR." + (let ((red (color-component :red color + :image source-image)) + (blue (color-component :blue color + :image source-image)) + (green (color-component :green color + :image source-image)) + (alpha (when alpha + (color-component :alpha color + :image source-image)))) + (find-color red green blue + :alpha alpha + :exact exact + :hwb hwb + :resolve resolve + :image image))) Added: trunk/cl-gd/doc/anti-aliased-lines.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/doc/brushed-arc.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/doc/chart.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/doc/clipped-tangent.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/doc/demooutp.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/doc/gddemo.c ============================================================================== --- (empty file) +++ trunk/cl-gd/doc/gddemo.c Wed Apr 30 04:38:52 2008 @@ -0,0 +1,169 @@ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif + +#include +#include +#include +#include "gd.h" +#include "gdfontg.h" +#include "gdfonts.h" + +int +main (void) +{ +#ifdef HAVE_LIBPNG + /* Input and output files */ + FILE *in; + FILE *out; + + /* Input and output images */ + gdImagePtr im_in = 0, im_out = 0; + + /* Brush image */ + gdImagePtr brush; + + /* Color indexes */ + int white; + int blue; + int red; + int green; + + /* Points for polygon */ + gdPoint points[3]; + int i; + + /* Create output image, in true color. */ + im_out = gdImageCreateTrueColor (256 + 384, 384); + /* 2.0.2: first color allocated would automatically be background in a + palette based image. Since this is a truecolor image, with an + automatic background of black, we must fill it explicitly. */ + white = gdImageColorAllocate (im_out, 255, 255, 255); + gdImageFilledRectangle (im_out, 0, 0, gdImageSX (im_out), + gdImageSY (im_out), white); + + /* Set transparent color. */ + gdImageColorTransparent (im_out, white); + + /* Try to load demoin.png and paste part of it into the + output image. */ + in = fopen ("demoin.png", "rb"); + if (!in) + { + fprintf (stderr, "Can't load source image; this demo\n"); + fprintf (stderr, "is much more impressive if demoin.png\n"); + fprintf (stderr, "is available.\n"); + im_in = 0; + } + else + { + int a; + im_in = gdImageCreateFromPng (in); + fclose (in); + /* Now copy, and magnify as we do so */ + gdImageCopyResampled (im_out, im_in, 32, 32, 0, 0, 192, 192, 255, 255); + /* Now display variously rotated space shuttles in a circle of our own */ + for (a = 0; (a < 360); a += 45) + { + int cx = cos (a * .0174532925) * 128; + int cy = -sin (a * .0174532925) * 128; + gdImageCopyRotated (im_out, im_in, + 256 + 192 + cx, 192 + cy, + 0, 0, gdImageSX (im_in), gdImageSY (im_in), a); + } + } + red = gdImageColorAllocate (im_out, 255, 0, 0); + green = gdImageColorAllocate (im_out, 0, 255, 0); + blue = gdImageColorAllocate (im_out, 0, 0, 255); + /* Fat Rectangle */ + gdImageSetThickness (im_out, 4); + gdImageLine (im_out, 16, 16, 240, 16, green); + gdImageLine (im_out, 240, 16, 240, 240, green); + gdImageLine (im_out, 240, 240, 16, 240, green); + gdImageLine (im_out, 16, 240, 16, 16, green); + gdImageSetThickness (im_out, 1); + /* Circle */ + gdImageArc (im_out, 128, 128, 60, 20, 0, 720, blue); + /* Arc */ + gdImageArc (im_out, 128, 128, 40, 40, 90, 270, blue); + /* Flood fill: doesn't do much on a continuously + variable tone jpeg original. */ + gdImageFill (im_out, 8, 8, blue); + /* Polygon */ + points[0].x = 64; + points[0].y = 0; + points[1].x = 0; + points[1].y = 128; + points[2].x = 128; + points[2].y = 128; + gdImageFilledPolygon (im_out, points, 3, green); + /* 2.0.12: Antialiased Polygon */ + gdImageSetAntiAliased (im_out, green); + for (i = 0; (i < 3); i++) + { + points[i].x += 128; + } + gdImageFilledPolygon (im_out, points, 3, gdAntiAliased); + /* Brush. A fairly wild example also involving a line style! */ + if (im_in) + { + int style[8]; + brush = gdImageCreateTrueColor (16, 16); + gdImageCopyResized (brush, im_in, + 0, 0, 0, 0, + gdImageSX (brush), gdImageSY (brush), + gdImageSX (im_in), gdImageSY (im_in)); + gdImageSetBrush (im_out, brush); + /* With a style, so they won't overprint each other. + Normally, they would, yielding a fat-brush effect. */ + style[0] = 0; + style[1] = 0; + style[2] = 0; + style[3] = 0; + style[4] = 0; + style[5] = 0; + style[6] = 0; + style[7] = 1; + gdImageSetStyle (im_out, style, 8); + /* Draw the styled, brushed line */ + gdImageLine (im_out, 0, 255, 255, 0, gdStyledBrushed); + } + /* Text (non-truetype; see gdtestft for a freetype demo) */ + gdImageString (im_out, gdFontGiant, 32, 32, (unsigned char *) "hi", red); + gdImageStringUp (im_out, gdFontSmall, 64, 64, (unsigned char *) "hi", red); + /* Random antialiased lines; coordinates all over the image, + but the output will respect a small clipping rectangle */ + gdImageSetClip(im_out, 0, gdImageSY(im_out) - 100, + 100, gdImageSY(im_out)); + /* Fixed seed for reproducibility of results */ + srand(100); + for (i = 0; (i < 100); i++) { + int x1 = rand() % gdImageSX(im_out); + int y1 = rand() % gdImageSY(im_out); + int x2 = rand() % gdImageSX(im_out); + int y2 = rand() % gdImageSY(im_out); + gdImageSetAntiAliased(im_out, white); + gdImageLine (im_out, x1, y1, x2, y2, gdAntiAliased); + } + /* Make output image interlaced (progressive, in the case of JPEG) */ + gdImageInterlace (im_out, 1); + out = fopen ("demoout.png", "wb"); + /* Write PNG */ + gdImagePng (im_out, out); + fclose (out); + /* 2.0.12: also write a paletteized version */ + out = fopen ("demooutp.png", "wb"); + gdImageTrueColorToPalette (im_out, 0, 256); + gdImagePng (im_out, out); + fclose (out); + gdImageDestroy (im_out); + if (im_in) + { + gdImageDestroy (im_in); + } +#else + fprintf (stderr, "No PNG library support.\n"); +#endif /* HAVE_LIBPNG */ + return 0; +} Added: trunk/cl-gd/doc/index.html ============================================================================== --- (empty file) +++ trunk/cl-gd/doc/index.html Wed Apr 30 04:38:52 2008 @@ -0,0 +1,1441 @@ + + + + + + CL-GD - Use the GD Graphics library from Common Lisp + + + + + +

CL-GD - Use the GD Graphics library from Common Lisp

+ +
+
 

Abstract

+ +CL-GD is a library for Common Lisp which provides an interface to the +GD Graphics Library for the +dynamic creation of images. It is based on UFFI and should thus be portable to all +CL implementations supported by UFFI. +

+A version which also works with CLISP is available from http://ungil.com/cl-gd-clisp.tgz +thanks to Carlos Ungil. Also, beginning from version 0.5.0/0.5.1, CL-GD +contains initial code to support CLISP and OpenMCL via CFFI (thanks to Luis +Oliveira and Bryan O'Connor). Please try it and report to the mailing list if you +have problems. +

+The focus of CL-GD is convenience and correctness, not necessarily speed. If you think CL-GD is too slow and you're concerned about speed, contact me before you start coding in C... :) +

+CL-GD comes with a BSD-style +license so you can basically do with it whatever you want. Please send bug reports to the mailing list mentioned below if you encounter any problems with CL-GD. (I'm glad to fix CL-GD but I can't do much about GD, of course. So if CL-GD basically works for you but you encounter seemingly strange behaviour when drawing please try if and how you can achieve the intended result with GD directly. That would help me a lot. Thanks.) +

+CL-GD is used by QuickHoney. + +

+Download shortcut: http://weitz.de/files/cl-gd.tar.gz. +

+ +
 

A simple example

+ +The image to the right was created with this piece of code: + +
+chart.png(with-image* (200 200) ; create 200x200 pixel image
+  (allocate-color 68 70 85) ; background color
+  (let ((beige (allocate-color 222 200 81))
+        (brown (allocate-color 206 150 75))
+        (green (allocate-color 104 156 84))
+        (red (allocate-color 163 83 84))
+        (white (allocate-color 255 255 255))
+        (two-pi (* 2 pi)))
+    ;; move origin to center of image
+    (with-transformation (:x1 -100 :x2 100 :y1 -100 :y2 100 :radians t)
+      ;; draw some 'pie slices'
+      (draw-arc 0 0 130 130 0 (* .6 two-pi)
+                :center-connect t :filled t :color beige)
+      (draw-arc 0 0 130 130 (* .6 two-pi) (* .8 two-pi)
+                :center-connect t :filled t :color brown)
+      (draw-arc 0 0 130 130 (* .8 two-pi) (* .95 two-pi)
+                :center-connect t :filled t :color green)
+      (draw-arc 0 0 130 130 (* .95 two-pi) two-pi
+                :center-connect t :filled t :color red)
+      (with-default-color (white)
+        (with-default-font (:small)
+          (draw-string -8 -30 "60%")
+          (draw-string -20 40 "20%")
+          (draw-string 20 30 "15%"))
+        (draw-freetype-string -90 75 "Global Revenue"
+                              ;; this assumes that 'DEFAULT_FONTPATH'
+                              ;; is set correctly
+                              :font-name "verdanab"))))
+  (write-image-to-file "chart.png"
+                       :compression-level 6 :if-exists :supersede))
+
+ +

+See below for more examples. + +
 

Contents

+ + +
 

Download and installation

+ +CL-GD together with this documentation can be downloaded from http://weitz.de/files/cl-gd.tar.gz. The +current version is 0.5.6. A Debian package is available thanks to Peter van Eynde and Kevin Rosenberg, so if you're on Debian you should have no problems installing CL-GD. There's also a port +for Gentoo Linux thanks to Matthew Kennedy. Otherwise, proceed like this: +
    +
  • Download and install a recent version of asdf. +
  • Download and install UFFI. CL-GD needs at least version 1.3.4 of UFFI to work properly. However, as of August 2003, only AllegroCL, CMUCL, LispWorks, SBCL, and SCL are fully supported because CL-GD needs the new UFFI macros WITH-CAST-POINTER and DEF-FOREIGN-VAR which haven't yet been ported to all UFFI platforms. Note: For CLISP or OpenMCL download and install CFFI instead. +
  • Download and install a recent version of GD and its supporting libraries libpng, zlib, libjpeg, libfreetype, and maybe libiconv. CL-GD has been tested and developed with GD 2.0.28, older version probably won't work. Note that you won't be able to compile CL-GD unless you have installed all supporting libraries. This is different from using GD directly from C where you only have to install the libraries you intend to use. +
  • Download cl-gd.tar.gz, unzip and untar the file and put the resulting directory wherever you want, then cd into this directory. +
  • Compile cl-gd-glue.c into a shared library for your platform. On FreeBSD or Linux this would be +
    +gcc -fPIC -c cl-gd-glue.c
+ld -lgd -lz -lpng -ljpeg -lfreetype -lm -shared cl-gd-glue.o -o cl-gd-glue.so
+rm cl-gd-glue.o
+
    +(Note: On older versions of Linux, you might have to add -liconv.) +

    +For Mac OS X, use +

    +gcc -lgd -ljpeg -dynamiclib cl-gd-glue.c -o cl-gd-glue.dylib
+
    +
  • Make sure that cl-gd.asd can be seen from asdf (this is usually achieved by a symbolic link), start your favorite Lisp, and compile CL-GD: +
    +(asdf:oos 'asdf:compile-op :cl-gd)
+
    +
  • From now on you can simply load CL-GD into a running Lisp image with +
    +(asdf:oos 'asdf:load-op :cl-gd)
+
    +
  • To build without GIF support compile the C library with the option -DGD_DONT_USE_GIF and push the symbol :CL-GD-NO-GIF onto *FEATURES* before compiling CL-GD. + +
  • CL-GD comes with a simple test suite that can be used to check if it's +basically working. Note that this'll only test a subset of CL-GD. To +run the tests load CL-GD and then +
    +(asdf:oos 'asdf:load-op :cl-gd-test)
+(cl-gd-test:test)
+
    +If you have the georgiab.ttf +TrueType font from Microsoft you can also check the FreeType +support of CL-GD with +
    +(cl-gd-test:test #p"/usr/X11R6/lib/X11/fonts/truetype/georgiab.ttf")
+
    +where you should obviously replace the path above with the pull path +to the font on your machine.
+

+Note that CL-GD might work correctly even if some of the tests fail +(as long as you don't get error messages). The exact results of the +tests seem to depend on the versions of the C libraries which are +used. +

+It is recommended that you at least skim over the original GD documentation before you start using CL-GD. +

+Note: If you're on Windows you might want to try this: +

    +
  • Download and install the supporting libraries (see above) from GnuWin32 and put the DLLs into a place where your Lisp's FFI will find them. The folder where your Lisp image starts up is usually a good place. +
  • Download the file cl-gd-glue.dll from http://weitz.de/files/cl-gd-glue.dll and put it into the CL-GD folder. You don't need to download and install GD itself because it's already integrated into cl-gd-glue.dll. +
  • Start your Lisp and compile CL-GD as described above. +
+This works for me on Windows XP pro SP2 with AllegroCL 6.2 trial as well as with LispWorks 4.3.7 pro. +

+Luís Oliveira maintains a darcs +repository of CL-GD +at http://common-lisp.net/~loliveira/ediware/. + + +
 

Support and mailing lists

+ +For questions, bug reports, feature requests, improvements, or patches +please use the cl-gd-devel +mailing list. If you want to be notified about future releases +subscribe to the cl-gd-announce +mailing list. These mailing lists were made available thanks to +the services of common-lisp.net. +

+If you want to send patches, please read this first. + +
 

Images

+ +In order to work with CL-GD you first have to create at least one +image - think of it as your canvas, kind of. Images can be +created from scratch or you can load an existing image file from +disk. After you've drawn something or otherwise modified your image +you can write it to a file or a stream. Once you're done with it you +must destroy it to avoid memory leaks. It is recommended that +you use the WITH-IMAGE- macros instead of the +CREATE-IMAGE- functions so you can be sure that images +will always be destroyed no matter what happens. + +


[Function] +
create-image width height &optional true-color => image + +


+Allocates and returns an image with size width x height (in pixels). Creates a true color image if +true-color is true - the default is NIL. You are responsible for +destroying the image after you're done with it. It is advisable to use +WITH-IMAGE instead. +
+ +


[Function] +
create-image-from-file file-name &optional type => image + +


+Creates an image from the file specified by file-name (which is +either a pathname or a string). The type of the image can be provided +as type (one of the keywords :JPG, :JPEG, :GIF, :PNG, :GD, :GD2, :XBM, or :XPM), or otherwise it will be guessed from the PATHNAME-TYPE of +file-name. You are responsible for destroying the image after you're +done with it. It is advisable to use WITH-IMAGE-FROM-FILE instead. +
+ +


[Function] +
create-image-from-gd2-part file-name src-x src-y width height => image + +


+Creates an image from the part of the GD2 file specified by file-name (which is +either a pathname or a string) specified by src-x, src-y, width, and height. You are responsible for destroying the image after you're +done with it. It is advisable to use WITH-IMAGE-FROM-GD2-PART instead. +
+ +


[Function] +
destroy-image image => result + +


+Destroys (deallocates) image which has been created by CREATE-IMAGE, +CREATE-IMAGE-FROM-FILE, or CREATE-IMAGE-FROM-GD2-PART. result is always NIL. +
+ +


[Macro] +
with-image (name width height &optional true-color) form* => results + +


+Creates an image as with CREATE-IMAGE and executes +form* with the image bound to +name. The image is +guaranteed to be destroyed before this macro exits. +
+ +


[Macro] +
with-image-from-file (name file-name &optional type) form* => results + +


+Creates an image as with CREATE-IMAGE-FROM-FILE and executes +form* with the image bound to +name. The image is +guaranteed to be destroyed before this macro exits. +
+ +
+(with-image-from-file (old "zappa.jpg")zappa-green.jpgzappa.jpg
+  (multiple-value-bind (width height)
+      (image-size old)
+    (with-image (new width height)
+      (allocate-color 0 255 0 :image new) ; green background
+      (copy-image old new 0 0 0 0 width height
+                  :merge 50)
+      (write-image-to-file "zappa-green.jpg"
+                           :image new
+                           :if-exists :supersede))))
+
+ +


[Macro] +
with-image-from-gd2-part (name file-name src-x src-y width height) form* => results + +


+Creates an image as with CREATE-IMAGE-FROM-GD2-PART and executes +form* with the image bound to +name. The image is +guaranteed to be destroyed before this macro exits. +
+ +


[Special variable] +
*default-image* + +


+Whenever a CL-GD function or macro has an optional or keyword argument called image the default is to use *default-image*. The idea behind this is that you'll never have to provide these arguments as long as you work with one image at a time (which should be the usual case). See the example at the top of the page. +
+ +


[Macro] +
with-default-image (image) form* => results + +


+This is just a convenience macro which will execute form* with *DEFAULT-IMAGE* bound to image. +
+ + +


[Macro] +
with-image* (width height &optional true-color) form* => results +


[Macro] +
with-image-from-file* (file-name &optional type) form* => results +


[Macro] +
with-image-from-gd2-part* (file-name src-x src-y width height) form* => results + +


+These are essentially like their asterisk-less counterparts but bind the image to *DEFAULT-IMAGE* instead. +
+ + +

+For the rest of this document, whenever a function expects an image as +one of its arguments you must pass a value which was created +with one of the functions or macros above. An image should be +considered an opaque object which you can pass to CL-GD functions but +should otherwise leave alone. (Internally it is a foreign pointer +wrapped in a CL-GD::IMAGE structure in order to enable +type checking.) + +


[Function] +
write-jpeg-to-stream stream &key quality image => image + +


+Writes image image to the stream +stream as a JPEG file. If +quality is not specified, the default IJG JPEG +quality value is used. Otherwise, +quality must be an integer in the range 0-100. stream must be a character stream or a binary +stream of element type (UNSIGNED-BYTE 8). If STREAM is a character +stream, the user of this function has to make sure the external format +yields faithful output of all 8-bit characters. CL-GD knows about AllegroCL's simple streams and the bivalent streams of LispWorks 4.3 and acts accordingly, i.e. it uses WRITE-BYTE instead of WRITE-CHAR whenever possible. +
+ +


[Function] +
write-png-to-stream stream &key compression-level image => image + +


+Writes image image to the stream +stream as a PNG file. If +compression-level is not specified, the default compression level at +the time zlib was compiled on your system will be used. Otherwise, a +compression level of 0 means 'no compression', a compression level of 1 means 'compressed, but as quickly as possible', a compression level +of 9 means 'compressed as much as possible to produce the smallest +possible file.' stream must be a character stream or a binary +stream of element type (UNSIGNED-BYTE 8). If STREAM is a character +stream, the user of this function has to make sure the external format +yields faithful output of all 8-bit characters. CL-GD knows about AllegroCL's simple streams and the bivalent streams of LispWorks 4.3 and acts accordingly, i.e. it uses WRITE-BYTE instead of WRITE-CHAR whenever possible. +
+ +


[Function] +
write-wbmp-to-stream stream &key foreground image => image + +


+Writes image image to the stream +stream as a WBMP (wireless bitmap) file. WBMP file support is black and white +only. The color specified by the foreground argument is the +"foreground," and only pixels of this color will be set in the WBMP +file. stream must be a character stream or a binary +stream of element type (UNSIGNED-BYTE 8). If STREAM is a character +stream, the user of this function has to make sure the external format +yields faithful output of all 8-bit characters. CL-GD knows about AllegroCL's simple streams and the bivalent streams of LispWorks 4.3 and acts accordingly, i.e. it uses WRITE-BYTE instead of WRITE-CHAR whenever possible. +
+ +


[Function] +
write-gd-to-stream stream &key image => image + +


+Writes image image to the stream +stream as a GD file. stream must be a character stream or a binary +stream of element type (UNSIGNED-BYTE 8). If STREAM is a character +stream, the user of this function has to make sure the external format +yields faithful output of all 8-bit characters. CL-GD knows about AllegroCL's simple streams and the bivalent streams of LispWorks 4.3 and acts accordingly, i.e. it uses WRITE-BYTE instead of WRITE-CHAR whenever possible. +
+ +


[Function] +
write-gif-to-stream stream &key image => image + +


+Writes image image to the stream +stream as a GIF file. stream must be a character stream or a binary +stream of element type (UNSIGNED-BYTE 8). If STREAM is a character +stream, the user of this function has to make sure the external format +yields faithful output of all 8-bit characters. CL-GD knows about AllegroCL's simple streams and the bivalent streams of LispWorks 4.3 and acts accordingly, i.e. it uses WRITE-BYTE instead of WRITE-CHAR whenever possible. +
+ +


[Function] +
write-gd2-to-stream stream &key image => image + +


+Writes image image to the stream +stream as a GD2 file. stream must be a character stream or a binary +stream of element type (UNSIGNED-BYTE 8). If STREAM is a character +stream, the user of this function has to make sure the external format +yields faithful output of all 8-bit characters. CL-GD knows about AllegroCL's simple streams and the bivalent streams of LispWorks 4.3 and acts accordingly, i.e. it uses WRITE-BYTE instead of WRITE-CHAR whenever possible. +
+ +


[Function] +
write-image-to-stream stream type &key &allow-other-keys => image + +


+Writes image image to the stream +stream. The type of the image is determined by type +which must be one of the keywords :JPG, :JPEG, :GIF, :PNG, :WBMP, :GD, or :GD2. The rest of the keyword arguments are handed over to the corresponding WRITE-XXX-TO-STREAM function. stream must be a character stream or a binary +stream of element type (UNSIGNED-BYTE 8). If STREAM is a character +stream, the user of this function has to make sure the external format +yields faithful output of all 8-bit characters. CL-GD knows about AllegroCL's simple streams and the bivalent streams of LispWorks 4.3 and acts accordingly, i.e. it uses WRITE-BYTE instead of WRITE-CHAR whenever possible. +
+ +


[Function] +
write-image-to-file file-name &key type if-exists &allow-other-keys => image + +


+Writes image image to the file specified by file-name (which is +either a pathname or a string). The type argument is interpreted as in WRITE-IMAGE-TO-STREAM. If it is not provided it will be guessed from the PATHNAME-TYPE of +file-name. The if-exists keyword argument is given to OPEN, +the rest of the keyword arguments are handed over to the corresponding WRITE-XXX-TO-STREAM function. +
+ +


[Function] +
image-width &optional image => width + +


+Returns the width of the image image. The result of this function is affected by WITH-TRANSFORMATION. +
+ +


[Function] +
image-height &optional image => height + +


+Returns the height of the image image. The result of this function is affected by WITH-TRANSFORMATION. +
+ +


[Function] +
image-size &optional image => width, height + +


+Returns the width and height of the image image as two values. The results of this function are affected by WITH-TRANSFORMATION. +
+ +
 

Colors

+ +Images in CL-GD are usually palette-based (although true color images +are also supported) and colors have to be allocated before they can be used, i.e. whenever a function expects a color as +one of its arguments you must pass a value which was created +with one of the functions below or with a 'special' color as described in the next section. +

+Colors +are determined by specifying values for their red, green, blue, and +optionally alpha components. The first +three have to be integer values in the range 0-255 while the last +one has to be in the range 0-127. For a palette-based image the +first color you allocate will be its background color. Note that +colors are allocated per image, i.e. you can't allocate a color in one +image and then use it to draw something in another image. +

+See also the next section for some 'special colors.' + +


[Special variable] +
*default-color* + +


+Whenever a CL-GD function or macro has an optional or keyword argument called color the default is to use *default-color*. See WITH-DEFAULT-COLOR below. +
+ +


[Macro] +
with-default-color (color) form* => results + +


+This is just a convenience macro which will execute form* with *DEFAULT-COLOR* bound to color. +
+ +


[Function] +
allocate-color red green blue &key alpha errorp image => color + +


+Finds the first available color index in the image image specified, +sets its RGB values to those requested (255 is the maximum for each), +and returns the index of the new color table entry, or an RGBA value in +the case of a true color image. In either case you can then use the +returned value as a color parameter to drawing functions. When +creating a new palette-based image, the first time you invoke this +function you are setting the background color for that image. If +alpha (not greater than 127) is provided, an RGBA color will always +be allocated. If all +MAX-COLORS+ have already been allocated this +function will, depending on the value of errorp, either raise an error +or return NIL. The default is to raise an error. +
+ +


[Function] +
find-color red green blue &key alpha exact hwb resolve image => color + +


+Tries to find and/or allocate a color from image's color +palette. If exact is true, the color will only be returned if it is +already allocated. If exact is false, a color which is 'close' to +the color specified by red, green, and blue (and probably alpha) +might be returned (unless there aren't any colors allocated in the +image yet). If hwb is true, the 'closeness' will be determined by hue, +whiteness, and blackness, otherwise by the Euclidian distance of the +RGB values. If resolve is true a color (probably a new one) will +always be returned, otherwise the result of this function might be +NIL. If alpha (not greater than 127) is provided, an RGBA color (or +NIL) will be returned. +alpha, exact, and hwb are mutually exclusive. resolve can't be used +together with exact or hwb. +
+ +


[Function] +
find-color-from-image color source-image &key alpha exact hwb resolve image => color + +


+Tries to find and/or allocate a color from image's color +palette that corresponds to color in source-image. +find-color-from-image calls find-color +with the color components of color. +Refer to find-color for a description of the +keyword arguments. +
+ +


[Function] +
color-component color component &key image => component + +


+Returns the specified color component of color. component can be +one of :RED, :GREEN, :BLUE, and :ALPHA. +
+ +


[Function] +
color-components color &key image => components + +


+Returns the color components of color as a list. The components are in the +order red, green, blue, alpha. +
+ +
+* (defun foo ()
+    (with-image* (10 10)
+      (loop for i below +max-colors+ do
+            ;; allocate enough colors (all gray) to fill the palette
+            (allocate-color i i i))
+      (format t "Number of colors allocated: ~A~%" (number-of-colors))
+      (format t "Maximal number of colors: ~A~%" +max-colors+)
+      (format t "Exact match for red: ~A~%" (find-color 255 0 0 :exact t))
+      (format t "Red, green, and blue components of 'closest' match for red: ~A~%"
+              (let ((match (find-color 255 0 0)))
+                (if match
+                  (list (color-component :red match)
+                        (color-component :green match)
+                        (color-component :blue match))))))
+    (values))
+
+FOO
+* (foo)
+Number of colors allocated: 256
+Maximal number of colors: 256
+Exact match for red: NIL
+Red, green, and blue components of 'closest' match for red: (64 64 64)
+
+ +


[Function] +
deallocate-color color &optional image => color + +


+Marks the specified color color as being available for reuse. No +attempt will be made to determine whether the color index is still in +use in the image image. +
+ +


[Function] +
true-color-p &optional image => result + +


+Returns true iff image is a true color image. +
+ +


[Function] +
number-of-colors &optional image => result + +


+Returns the number of colors allocated in image or NIL if image is a true color image. +
+ +


[Constant] +
+max-colors+ + +


+Maximum number of colors for palette-based images. +
+ +


[Accessor] +
transparent-color &optional image => color +
(setf (transparent-color &optional image) color) + +


+Gets and sets the transparent color of image. If color is NIL there is no transparent color. +
+ +


[Accessor] +
alpha-blending-p &optional image => blending +
(setf (alpha-blending-p &optional image) blending) + +


+Gets and set whether pixels drawn on image will be copied literally +including alpha channel information (if blending is false) or if +their alpha channel information will determine how much of the +underlying color will shine through (if blending is true). This is +only meaningful for true color images. +
+ +


[Accessor] +
save-alpha-p &optional image => save +
(setf (save-alpha-p &optional image) save) + +


+Gets and sets whether PNG images will be saved with full alpha channel information. +
+ +
+(with-image* (200 100)brushed-arc.png
+  (allocate-color 255 165 0) ; orange background
+  (with-image (brush 6 6)
+    (let* ((black (allocate-color 0 0 0 :image brush)) ; black background
+           (red (allocate-color 255 0 0 :image brush))
+           (blue (allocate-color 0 0 255 :image brush)))
+      (setf (transparent-color brush) black) ; make background transparent
+      ;; now set the pixels in the brush
+      (set-pixels '(2 2 2 3 3 2 3 3)
+                  :color blue :image brush)
+      (set-pixels '(3 2 3 3 1 2 1 3 4 2 4 3 2 1 3 1 2 4 3 4)
+                  :color red :image brush)
+      ;; then use it to draw an arc
+      (draw-arc 100 50 180 80 180 300
+                ;; convert BRUSH to brush
+                :color (make-brush brush)))
+  (write-image-to-file "brushed-arc.png"
+                       :compression-level 7
+                       :if-exists :supersede)))
+
+ +
 

Styles, brushes, tiles, anti-aliased lines

+ +Most drawing and string +functions (with DRAW-FREETYPE-STRING +being the only exception) will, when expecting a color, also accept other types of arguments. The +full range of allowed types which can be used for +color keyword arguments is listed below: + +
    +
  • A style which is either a list or a vector of colors + allocated with one of the functions described above or + NIL for transparent colors. When a style is used as the + color, the colors of the pixels are drawn successively from the + sequence provided. If the corresponding element of the sequence is + NIL, that pixel is not altered. + +
  • A brush as created with MAKE-BRUSH for drawing lines. A + brush is itself an image created as described + above. When a brush is used as the color, the brush image is drawn + in place of each pixel of the line drawn. (The brush is usually + larger than one pixel, creating the effect of a wide paintbrush.) + +
  • A tile as created with MAKE-TILE for filling regions. A + tile is itself an image created as described + above. When a tile is used as the color, a pixel from the tile image + is selected in such a way as to ensure that the filled area will be + tiled with copies of the tile image. + +
  • A CONS where the CAR is a brush and + the CDR is a list or a vector. This is called a + styled brush. When a styled brush is used as the color, the + brush image is drawn at each pixel of the line, provided that the + corresponding element of the style sequence is true. + (Pixels are drawn successively from the style as the line is drawn, + returning to the beginning when the available pixels in the style + are exhausted.) Note that the semantics described here differ + slightly from the styles described above. + +
  • An anti-aliased color as created with MAKE-ANTI-ALIASED for + drawing lines. When an anti-aliased color is used, the line is drawn + with anti-aliasing mechanisms to minimize any "jagged" + appearance. + +
  • A 'normal' color as created with one of the functions from the + previous section. + +
+ +Note that you can't arbitrarily combine 'color types' and drawing +functions, e.g. you can't set an anti-aliased pixel. However, it +should generally be obvious which types make sense and which don't. +Check the original GD +documentation for more details. +

+In GD itself, if you, say, change a brush after you've 'set' it with +gdImageSetBrush +but before you actually use it for drawing these changes won't be +visible, i.e. the brush is 'frozen' once it's 'set.' The same applies +to tiles and styles. CL-GD's behaviour differs in this regard, +i.e. brushes, tiles, and styles are 'set' at the very moment they're +used. This introduces a little bit of overhead but feels more 'Lisp-y' +and intuitive to me. + +


[Function] +
make-brush image => brush + +


+ +Creates a brush from the image image. Note that the new +brush is still 'linked' to image, i.e. changes you +make to image will also be visible in the +brush - the brush is just a kind of 'tagged' image. + +
+ +


[Function] +
make-tile image => tile + +


+ +Creates a tile from the image image. Note that the new +tile is still 'linked' to image, i.e. changes you +make to image will also be visible in the +tile - the tile is just a kind of 'tagged' image. + +
+ +


[Function] +
make-anti-aliased color &optionaldo-not-blend => color' + +


+ +Creates an anti-aliased color from the +color +color. do-not-blend (if provided) is the +color anti-aliased lines stand out against clearly. + +
+ +
+(with-image* (150 50)anti-aliased-lines.png
+  (let ((orange (allocate-color 255 165 0)) ; orange background
+        (white (allocate-color 255 255 255))
+        (red (allocate-color 255 0 0)))
+    ;; white background rectangle in the middle third
+    (draw-rectangle* 50 0 99 49
+                    :filled t
+                    :color white)
+    (with-thickness (2)
+      ;; just a red line
+      (draw-line 5 10 145 10 :color red)
+      ;; anti-aliased red line
+      (draw-line 5 25 145 25 :color (make-anti-aliased red))
+      ;; anti-aliased red line which should stand out against
+      ;; orange background
+      (draw-line 5 40 145 40 :color (make-anti-aliased red orange))))
+  (write-image-to-file "anti-aliased-lines.png"
+                       :compression-level 3
+                       :if-exists :supersede))
+
+ +
 

Transformations

+ +Usually, CL-GD coordinates and dimensions (width and height) have to be integers. The origin (0,0) of an image is its upper left corner and all other points like (X,Y) have positive X and Y values. Angles are also provided as integers (in the range 0-360) meaning degrees. A transformation provides a way to change this. + +


[Macro] +
with-transformation (&key x1 x2 width y1 y2 height reverse-x reverse-y radians image) form* => results + +


+Executes form* such that all points and width/height data are +subject to a simple affine transformation defined by the keyword +parameters. The new x-axis of image will start at x1 and end at x2 and +have length width. The new y-axis of image will start at y1 and end at +y2 and have length height. In both cases it suffices to provide two of +the three values - if you provide all three they have to match. If +reverse-x is false the x-axis will be oriented as usual in Cartesian +coordinates, otherwise its direction will be reversed. The same +applies to reverse-y, of course. If radians is true angles inside of +the macro's body will be assumed to be provided in radians, otherwise in degrees. The previous transformation (if any) will be restored before this macro exits. +

+with-transformation macros can be nested but they always transform the original coordinates of the image, i.e. you shouldn't expect that, say, two succesive applications of reverse-x will neutralize each other. There's a little bit of overhead involved with this macro, so it is recommended to wrap it around everything you do with an image instead of calling it repeatedly. Note that transformations are always bound to one particular image. +

+ +


[Macro] +
without-transformations form* => results + +


+Executes form* without any transformations applied. +
+ +
 

Drawing and filling

+ +This section (and the next one about strings) finally describes how you can actually change the visual appearance of an image. You can set single pixels, draw lines or geometric figures, and fill regions. Note that the current transformation (if any) applies to the input and output of these functions. + +


[Function] +
get-pixel x y &key image => color + +


+Returns the color of the pixel specified by x and y. +
+ +


[Function] +
set-pixel x y &key color image => x, y + +


+Sets the pixel specified by x and y to the color specified by color. +
+ +


[Generic function] +
set-pixels points &key color image => points + +


+Sets the pixels specified by points which can be a list (X1 Y1 X2 Y2 ...) or a vector #(X1 Y1 X2 Y2 ...) to the color specified by color. +
+ +


[Function] +
draw-line x1 y1 x2 y2 &key color image => x1, y1, x2, y2 + +


+Draws a line with color color from point (x1,y1) to point (x2,y2). +
+ +


[Function] +
draw-rectangle rectangle &key filled color image => rectangle + +


+Draws a rectangle with upper left corner (X1,Y1) and lower right corner (X2,Y2) where rectangle is the list (X1 Y2 X2 Y2). If filled is true the rectangle will be filled with color, otherwise it will be outlined. +
+ +


[Function] +
draw-rectangle* x1 y1 x2 y2 &key filled color image => x1, y1, x2, y2 + +


+Draws a rectangle with upper left corner (x1,y1) and lower right corner (x2,y2). If filled is true the rectangle will be filled with color, otherwise it will be outlined. +
+ +


[Generic function] +
draw-polygon vertices &key filled start end color image => vertices + +


+Draws a polygon with the vertices (at least three) +specified as a list (X1 Y1 X2 Y2 ...) or as a vector #\(X1 Y1 X2 Y2 ...). +If filled is true the polygon will be filled with the color color, +otherwise it will be outlined. If start and/or end are specified then +only the corresponding part of vertices is used as input. +
+ +
+(with-image* (100 100)triangle.png
+  (allocate-color 255 255 255) ; white background
+  (let ((red (allocate-color 255 0 0))
+        (yellow (allocate-color 255 255 0))
+        (orange (allocate-color 255 165 0)))
+    ;; thin black border
+    (draw-rectangle* 0 0 99 99
+                     :color (allocate-color 0 0 0))
+    ;; line thickness is five pixels
+    (with-thickness (5)
+      ;; triangle
+      (draw-polygon (list 10 10 90 50 50 90)
+                    ;; styled color
+                    :color (list red red red
+                                 yellow yellow yellow
+                                 nil nil nil
+                                 orange orange orange))
+      (write-image-to-file "triangle.png"
+                           :compression-level 8
+                           :if-exists :supersede))))
+
+ +


[Function] +
draw-filled-circle center-x center-y radius &key color image => center-x center-y radius + +


+Draws a filled circle with center (center-x,center-y) and radius radius. +
+ +


[Function] +
draw-filled-ellipse center-x center-y width height &key color image => center-x center-y width height + +


+Draws a filled ellipse with center (center-x,center-y), width width, and height height. +
+ +
+(with-image* (250 150)
+  (with-image-from-file (zappa "smallzappa.png")zappa-ellipse.png
+    (setf (transparent-color) (allocate-color 255 255 255))
+    (draw-filled-ellipse 125 75 250 150
+                         :color (make-tile zappa)))
+  (write-image-to-file "zappa-ellipse.png"
+                       :if-exists :supersede))
+
+ +


[Function] +
draw-arc center-x center-y width height start end &key straight-line center-connect filled color image => center-x, center-y, width, height, start, end + +


+Draws a partial ellipse centered at (center-x,center-y) with +width width and height height. The arc begins at angle start and ends +at angle end. If straight-line is true the start and end points are +just connected with a straight line. If center-connect is true, they +are connected to the center (which is useful to create 'pie +slices' - see example at the top of the page.). If filled is true the arc will be filled with the color color, otherwise it will be outlined. +
+ +


[Function] +
fill-image x y &key border color image => x, y + +


+Floods a portion of the image image with the color color beginning +at point (x,y) and extending into the surrounding region. If border +is true it must be a color and the filling will stop at the specified +border color. (You can't use 'special colors' for the border color.) Otherwise only points with the same color as the +starting point will be colored. If color is a tile the tile must not have a transparent color. +
+ +


[Accessor] +
clipping-rectangle &optional image => rectangle +
(setf (clipping-rectangle &optional image) rectangle) + +


+Gets and sets the clipping rectangle of image where rectangle should be a +list (X1 Y1 X2 Y2) describing the upper left and lower right corner of the rectangle. Once a clipping rectangle has been set, all future drawing operations on image will remain within the specified clipping area, until a new clipping rectangle is established. For instance, if a clipping rectangle (25 25 75 75) has been set within a 100x100 image, a diagonal line from (0,0) to (99,99) will appear only between (25,25) and (75,75). See also CLIPPING-RECTANGLE* and SET-CLIPPING-RECTANGLE*. +
+ +


[Function] +
clipping-rectangle* &optional image => x1, y1, x2, y2 + +


+Returns the clipping rectangle of image as four values. +
+ +


[Function] +
set-clipping-rectangle* x1 y1 x2 y2 &optional image => x1, y1, x2, y2 + +


+Sets the clipping rectangle of image as if set with (SETF (CLIPPING-RECTANGLE IMAGE) (LIST X1 Y1 X2 Y2)). +
+ +


[Macro] +
with-clipping-rectangle (rectangle &key image) form* => results + +


+Executes form* with the clipping rectangle of image set to rectangle +which should be a list as in CLIPPING-RECTANGLE. The previous clipping rectangle +is guaranteed to be restored before the macro exits. +
+ +


[Macro] +
with-clipping-rectangle* (x1 y1 x2 y2 &key image) form* => results + +


+Executes form* with the clipping rectangle of image set as if set with (SETF (CLIPPING-RECTANGLE IMAGE) (LIST X1 Y1 X2 Y2)). The previous clipping rectangle +is guaranteed to be restored before the macro exits. +
+ +
+(with-image* (150 150)clipped-tangent.png
+  (allocate-color 255 255 255) ; white background
+  ;; transform such that x axis ranges from (- PI) to PI and y
+  ;; axis ranges from -3 to 3
+  (with-transformation (:x1 (- pi) :width (* 2 pi) :y1 -3 :y2 3)
+    (let ((black (allocate-color 0 0 0))
+          (red (allocate-color 255 0 0))
+          (rectangle (list (- .4 pi) 2.5 (- pi .4) -2.5)))
+      (with-default-color (black)
+        ;; draw axes
+        (draw-line 0 -3 0 3 :color black)
+        (draw-line (- pi) 0 pi 0))
+      ;; show clipping rectangle (styled)
+      (draw-rectangle rectangle :color (list black black black nil black nil))
+      (with-clipping-rectangle (rectangle)
+        ;; draw tangent function
+        (loop for x from (- pi) below (* 2 pi) by (/ pi 75) do
+              (set-pixel x (tan x) :color red)))))
+  (write-image-to-file "clipped-tangent.png"
+                       :if-exists :supersede))
+
+ +


[Accessor] +
current-thickness &optional image => thickness +
(setf (current-thickness &optional image) thickness) + +


+Get and sets the current thickness of image in pixels. This determines the width of lines drawn with the drawing functions. thickness has to be an integer. See also WITH-THICKNESS. +
+ +


[Macro] +
with-thickness (thickness &key image) form* => results + +


+Executes form* with the current thickness of image set to thickness. The image's previous thickness is guaranteed to be restored +before the macro exits. +
+ +
 

Characters and strings

+ +CL-GD (actually GD) comes with five included fonts which can be accessed with the keywords :TINY, :SMALL, :MEDIUM, :MEDIUM-BOLD (a synonym for :MEDIUM), :LARGE, and :GIANT and used with DRAW-STRING and DRAW-CHARACTER. Using these fonts will make your application portable to all platforms supported by CL-GD (and thus GD). You can also invoke the FreeType library to draw (anti-aliased) strings with arbitrary TrueType fonts, sizes, and angles. This is, however, subject to the availability and location of the corresponding fonts on your target platform. + +


[Special variable] +
*default-font* + +


+Whenever a CL-GD string or character function has an optional or keyword argument called font or font-name the default is to use *default-font*. See WITH-DEFAULT-FONT below. +
+ +


[Macro] +
with-default-font (font) form* => results + +


+This is just a convenience macro which will execute form* with *DEFAULT-FONT* bound to font. But +note that the fonts used for DRAW-STRING/DRAW-CHARACTER and DRAW-FREETYPE-STRING are incompatible +
+ +


[Function] +
draw-character x y char &key up font color image => char + +


+Draws the character char from font font in color color at position (x,y). If +up is true the character will be drawn from bottom to top (rotated 90 degrees). font must be one of the keywords listed above. +
+ +


[Function] +
draw-string x y string &key up font color image => string + +


+Draws the string string in color color at position (y,y). If +up is true the string will be drawn from bottom to top (rotated 90 degrees). font must be one of the keywords listed above. +
+ +


[Function] +
draw-freetype-string x y string &key anti-aliased point-size angle convert-chars line-spacing font-name do-not-draw color image => bounding-rectangle + +


+Draws the string string in color color at position (x,y) using the +FreeType library. font-name is the full path (a pathname or a string) +to a TrueType font file, or a font face name if the GDFONTPATH +environment variable or FreeType's DEFAULT_FONTPATH variable have been +set intelligently. The string may be arbitrarily scaled (point-size) +and rotated (angle in radians). The direction of rotation is +counter-clockwise, with 0 radians (0 degrees) at 3 o'clock and (/ PI 2) radians (90 degrees) at 12 o'clock. Note that the angle argument is +purposefully not affected by WITH-TRANSFORMATION. If anti-aliased if +false, anti-aliasing is disabled. It is enabled by default. To output +multiline text with a specific line spacing, provide a value for +line-spacing, expressed as a multiple of the font height. The default +is to use 1.05. The string may contain XML character entity references +like "&#192;". If convert-chars is true (which is the default) +characters of string with CHAR-CODE greater than 127 are converted +accordingly. This of course pre-supposes that your Lisp's CHAR-CODE +function returns ISO/IEC 10646 (Unicode) character codes. +

+The return value is an array containing 8 elements representing +the 4 corner coordinates (lower left, lower right, upper right, upper left) of the bounding rectangle around the +string that was drawn. The points are relative to the text regardless +of the angle, so "upper left" means in the top left-hand +corner seeing the text horizontally. Set do-not-draw +to true to get the bounding +rectangle without rendering. This is a relatively cheap operation if +followed by a rendering of the same string, because of the caching of +the partial rendering during bounding rectangle calculation. +

+ +
+(with-image* (200 200)strings.png
+  ;; set background (white) and make it transparent
+  (setf (transparent-color)
+          (allocate-color 255 255 255))
+  (loop for angle from 0 to (* 2 pi) by (/ pi 6)
+        for blue downfrom 255 by 20 do
+        (draw-freetype-string 100 100 "Common Lisp"
+                              :font-name "/usr/X11R6/lib/X11/fonts/truetype/georgia.ttf"
+                              :angle angle
+                              ;; note that ALLOCATE-COLOR won't work
+                              ;; here because the anti-aliasing uses
+                              ;; up too much colors
+                              :color (find-color 0 0 blue
+                                                 :resolve t)))
+  (write-image-to-file "strings.png"
+                       :if-exists :supersede))
+
+ +
 

Miscellaneous

+ +Things that didn't seem to fit into one of the other categories... + +


[Macro] +
do-rows (y-var &optional image) declaration* form* => results + +


+This macro loops through all rows (from top to bottom) in turn and +executes form* for each row with +y-var bound to the vertical index of the current row +(starting with 0). It is not affected by WITH-TRANSFORMATION. +
+ +


[Local macro] +
do-pixels-in-row (x-var) declaration* form* => results + +


+This macro is only available within the body of a DO-ROWS form. +It loops through all pixels (from left to right) in turn and +executes form* for each pixel with +x-var bound to the horizontal index of the current pixel +(starting with 0). It is not affected by WITH-TRANSFORMATION. +
+ +


[Macro] +
do-pixels (&optional image) declaration* form* => results + +


+This is a shortcut for the previous two macros. It loops through all pixels and executes form* for each pixel. Obviously it only makes sense when used together with RAW-PIXEL. +
+ +


[Accessor] +
raw-pixel => pixel +
(setf (raw-pixel) pixel) + +


+This accessor is only available within the body of a DO-PIXELS-IN-ROW form (and +thus also within DO-PIXELS +forms). It provides access to the "raw" pixel the loop is +currently at, i.e. for true color images you access an element of the +im->tpixels array, for palette-based images it's +im->pixels. Read the original GD +documentation for details. Make sure you know what you're doing if +you change these values... +
+ +
+* (with-image* (3 3 t) ; true-color image with 3x3 pixels
+    (draw-rectangle* 0 0 2 2 :color (allocate-color 0 0 0)) ; black background
+    (draw-line 0 0 2 2 :color (allocate-color 255 255 255)) ; white line
+    (do-pixels ()
+      ;; loop through all pixels and change those which arent't black
+      (unless (zerop (raw-pixel))
+        (decf (raw-pixel) #xff)))
+    (do-rows (y)
+      ;; loop through all rows
+      (format t "Starting with row ~A~%" y)
+      (do-pixels-in-row (x)
+        ;; loop through all pixels in row
+        (format t "  Pixel <~A,~A> has value ~X~%" x y (raw-pixel)))
+      (format t "Done with row ~A~%" y)))
+Starting with row 0
+  Pixel <0,0> has value FFFF00 ; the line is yellow now
+  Pixel <1,0> has value 0
+  Pixel <2,0> has value 0
+Done with row 0
+Starting with row 1
+  Pixel <0,1> has value 0
+  Pixel <1,1> has value FFFF00
+  Pixel <2,1> has value 0
+Done with row 1
+Starting with row 2
+  Pixel <0,2> has value 0
+  Pixel <1,2> has value 0
+  Pixel <2,2> has value FFFF00
+Done with row 2
+NIL
+
+ +


[Accessor] +
interlacedp &optional image => interlaced +
(setf (interlacedp &optional image) interlaced) + +


+Gets or sets whether image will be stored in an interlaced fashion. +
+ +


[Function] +
differentp image1 image2 => different + +


+Returns false if the two images won't appear different when +displayed. Otherwise the return value is a list of keywords describing +the differences between the images. +
+ +


[Function] +
copy-image source destination source-x source-y dest-x dest-y width height &key resample rotate angle resize dest-width dest-height merge merge-gray => destination + +


+Copies (a part of) the image source into the image destination. Copies the +rectangle with the upper left corner (source-x,source-y) and size +width x height to the rectangle with the upper left corner (dest-x,dest-y). + +If resample is true pixel colors will be +smoothly interpolated. If resize is true +the copied rectangle will be strechted or shrunk so that its size is +dest-width x +dest-height. If rotate is true +the image will be rotated by angle. In this +particular case dest-x and +dest-y specify the center of the copied +image rather than its upper left corner! If merge +is true then it has to be an integer in the range 0-100 and the +two images will be 'merged' by the amount specified. If +merge is 100 then the source image will simply be +copied. If instead merge-gray is true the hue of +the source image is preserved by converting the destination area to +gray pixels before merging. + +The keyword arguments resample, rotate, resize, merge, and merge-gray +are mutually exclusive (with the exception of resample and +resize). angle is assumed to be specified in degrees if it's an +integer, and in radians otherwise. This function is not affected by WITH-TRANSFORMATION. +
+ +


[Function] +
copy-palette source destination => destination + +


+Copies the palette of the image source to the image destination attempting to +match the colors in the target image to the colors in the source palette. +
+ +


[Function] +
true-color-to-palette &key dither colors-wanted image => image + +


+Converts the true color image image to a palette-based image using +a high-quality two-pass quantization routine. If dither is true, the +image will be dithered to approximate colors better, at the expense of +some obvious "speckling." colors-wanted can be any positive integer +up to 256 (which is the default). If the original source image +includes photographic information or anything that came out of a JPEG, +256 is strongly recommended. 100% transparency of a single transparent +color in the original true color image will be preserved. There is no +other support for preservation of alpha channel or transparency in the +destination image. +
+ +
+(with-image* ((+ 256 384) 384 t)
+  (let ((white (allocate-color 255 255 255))
+        (red (allocate-color 255 0 0))
+        (green (allocate-color 0 255 0))
+        (blue (allocate-color 0 0 255))
+        (vertices (list 64 0 0 128 128 128))
+        (image-width (image-width))
+        (image-height (image-height)))
+    (setf (transparent-color) white)
+    (draw-rectangle* 0 0 image-width image-height :color white)
+    ;; "demoin.png" is part of the GD distribution
+    (with-image-from-file (in-file "demoin.png")
+      (copy-image in-file *default-image*
+                  0 0 32 32 192 192
+                  :resize t
+                  :dest-width 255
+                  :dest-height 255
+                  :resample t)
+      (multiple-value-bind (in-width in-height)
+          (image-size in-file)
+        (loop for a below 360 by 45 do
+              (copy-image in-file *default-image*
+                          0 0
+                          (+ 256 192 (* 128 (cos (* a .0174532925))))
+                          (- 192 (* 128 (sin (* a .0174532925))))
+                          in-width in-height
+                          :rotate t
+                          :angle a))
+        (with-default-color (green)
+          (with-thickness (4)
+            (draw-line 16 16 240 16)
+            (draw-line 240 16 240 240)
+            (draw-line 240 240 16 240)
+            (draw-line 16 240 16 16))
+          (draw-polygon vertices :filled t))
+        (dotimes (i 3)
+          (incf (nth (* 2 i) vertices) 128))
+        (draw-polygon vertices
+                      :color (make-anti-aliased green)
+                      :filled t)
+        (with-default-color (blue)
+          (draw-arc 128 128 60 20 0 720)
+          (draw-arc 128 128 40 40 90 270)
+          (fill-image 8 8))
+        (with-image (brush 16 16 t)
+          (copy-image in-file brush
+                      0 0 0 0
+                      in-width in-height
+                      :resize t
+                      :dest-width (image-width brush)
+                      :dest-height (image-height brush))
+          (draw-line 0 255 255 0
+                     :color (cons (make-brush brush)
+                                  (list nil nil nil nil nil nil nil t))))))
+    (with-default-color (red)
+      (draw-string 32 32 "hi" :font :giant)
+      (draw-string 64 64 "hi" :font :small))
+    (with-clipping-rectangle* (0 (- image-height 100) 100 image-height)
+      (with-default-color ((make-anti-aliased white))
+        (dotimes (i 100)
+          (draw-line (random image-width)
+                     (random image-height)
+                     (random image-width)
+                     (random image-height))))))
+  (setf (interlacedp) t)
+  (write-image-to-file "demoout.png"
+                       :if-exists :supersede)
+  (true-color-to-palette)
+  (write-image-to-file "demooutp.png"
+                       :if-exists :supersede))
+
+ +This last example is the demo which comes with GD. The equivalent C code is here. + +

+demooutp.png + +
 

Acknowledgements

+ +Thanks to Thomas Boutell for GD and thanks to Kevin Rosenberg +for UFFI without which CL-GD would +not have been possible. Kevin was also extremely helpful when I needed +functionality which wasn't yet part of UFFI. Thanks to Hans +Hübner for the GIF patches. Thanks to Manuel Odendahl for lots of useful patches. +Thanks to Luis Oliveira for CLISP/CFFI support and to Bryan O'Connor for OpenMCL support. +

+$Header: /usr/local/cvsrep/gd/doc/index.html,v 1.75 2007/07/29 16:37:15 edi Exp $ +

BACK TO MY HOMEPAGE + + + Added: trunk/cl-gd/doc/smallzappa.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/doc/strings.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/doc/triangle.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/doc/zappa-ellipse.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/doc/zappa-green.jpg ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/doc/zappa.jpg ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/drawing.lisp ============================================================================== --- (empty file) +++ trunk/cl-gd/drawing.lisp Wed Apr 30 04:38:52 2008 @@ -0,0 +1,354 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/drawing.lisp,v 1.28 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defun get-pixel (x y &key (image *default-image*)) + "Gets the color associated with point \(X,Y)." + (check-type image image) + (with-transformed-alternative + ((x x-transformer) + (y y-transformer)) + (gd-image-get-pixel (img image) x y))) + +(defun set-pixel (x y &key (color *default-color*) (image *default-image*)) + "Draws a pixel with color COLOR at point \(X,Y)." + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((x x-transformer) + (y y-transformer)) + (gd-image-set-pixel (img image) x y color))) + (values x y)) + +(defgeneric set-pixels (points &key color image) + (:documentation "Draws a list \(X1 Y1 X2 Y2 ...) or vector #\(X1 Y1 +X2 Y2 ...) of pixels.")) + +(defmethod set-pixels ((points list) &key (color *default-color*) (image *default-image*)) + (check-type image image) + (unless (evenp (length points)) + (error "List ~S must have an even number of elements" + points)) + (loop with img = (img image) + for (x y) on points by #'cddr do + (check-type x integer) + (check-type y integer) + (with-transformed-alternative + ((x x-transformer) + (y y-transformer)) + (gd-image-set-pixel img x y color)) + finally (return image))) + +(defmethod set-pixels ((points vector) &key (color *default-color*) (image *default-image*)) + (check-type image image) + (let ((length (length points))) + (unless (evenp length) + (error "List ~S must have an even number of elements" + points)) + (loop with img = (img image) + for i below length by 2 do + (check-type (aref points i) integer) + (check-type (aref points (1+ i)) integer) + (with-transformed-alternative + (((aref points i) x-transformer) + ((aref points (1+ i)) y-transformer)) + (gd-image-set-pixel img + (aref points i) + (aref points (1+ i)) + color)) + finally (return image)))) + +(defun draw-line (x1 y1 x2 y2 &key (color *default-color*) (image *default-image*)) + "Draws a line with color COLOR from point \(X1,Y1) to point \(X2,Y2)." + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((x1 x-transformer) + (y1 y-transformer) + (x2 x-transformer) + (y2 y-transformer)) + (gd-image-line (img image) x1 y1 x2 y2 color))) + (values x1 y1 x2 y2)) + +(defun draw-rectangle* (x1 y1 x2 y2 &key filled (color *default-color*) (image *default-image*)) + "Draws a rectangle with upper left corner \(X1,Y1) and lower right +corner \(X2,Y2). If FILLED is true the rectangle will be filled with +COLOR, otherwise it will be outlined." + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((x1 x-transformer) + (y1 y-transformer) + (x2 x-transformer) + (y2 y-transformer)) + (if filled + (gd-image-filled-rectangle (img image) x1 y1 x2 y2 color) + (gd-image-rectangle (img image) x1 y1 x2 y2 color)))) + (values x1 y1 x2 y2)) + +(defun draw-rectangle (rectangle &key filled (color *default-color*) (image *default-image*)) + "Draws a rectangle with upper left corner \(X1,Y1) and lower right +corner \(X2,Y2) where RECTANGLE is the list \(X1 Y1 X2 Y2). If FILLED +is true the rectangle will be filled with COLOR, otherwise it will be +outlined." + (draw-rectangle* (first rectangle) + (second rectangle) + (third rectangle) + (fourth rectangle) + :filled filled + :color color + :image image) + rectangle) + +(defgeneric draw-polygon (vertices &key filled start end color image) + (:documentation "Draws a polygon with the VERTICES \(at least three) +specified as a list \(x1 y1 x2 y2 ...) or as a vector #\(x1 y1 x2 y2 +...). If FILLED is true the polygon will be filled with COLOR, +otherwise it will be outlined. If START and/or END are specified then +only the corresponding part of VERTICES is used as input.")) + +(defmethod draw-polygon ((vertices vector) &key filled (start 0) (end (length vertices)) (color *default-color*) (image *default-image*)) + (check-type start integer) + (check-type end integer) + (check-type image image) + (let ((effective-length (- end start))) + (unless (and (>= effective-length 6) + (evenp effective-length)) + (error "We need an even number of at least six vertices")) + (with-safe-alloc (arr (allocate-foreign-object 'gd-point (/ effective-length 2)) + (free-foreign-object arr)) + (with-color-argument + (with-transformed-alternative + (((aref vertices i) x-transformer) + ((aref vertices (1+ i)) y-transformer)) + (loop for i from start below end by 2 + for point-ptr = (deref-array arr '(:array gd-point) (/ (- i start) 2)) + do (setf (get-slot-value point-ptr 'gd-point 'x) + (aref vertices i) + (get-slot-value point-ptr 'gd-point 'y) + (aref vertices (1+ i)))) + (funcall (if filled + #'gd-image-filled-polygon + #'gd-image-polygon) + (img image) arr (/ effective-length 2) color) + vertices))))) + +(defmethod draw-polygon ((vertices list) &key filled (start 0) (end (length vertices)) (color *default-color*) (image *default-image*)) + (check-type start integer) + (check-type end integer) + (check-type image image) + (let ((effective-length (- end start))) + (unless (and (>= effective-length 6) + (evenp effective-length)) + (error "We need an even number of at least six vertices")) + (with-safe-alloc (arr (allocate-foreign-object 'gd-point (/ effective-length 2)) + (free-foreign-object arr)) + (with-color-argument + (with-transformed-alternative + (((first x/y) x-transformer) + ((second x/y) y-transformer)) + (loop for i below (- end start) by 2 + ;; we don't use LOOP's destructuring capabilities here + ;; because of your simple WITH-TRANSFORMED-ALTERNATIVE + ;; macro which would get confused + for x/y on (nthcdr start vertices) by #'cddr + for point-ptr = (deref-array arr '(:array gd-point) (/ i 2)) + do (setf (get-slot-value point-ptr 'gd-point 'x) + (first x/y) + (get-slot-value point-ptr 'gd-point 'y) + (second x/y))) + (funcall (if filled + #'gd-image-filled-polygon + #'gd-image-polygon) + (img image) arr (/ effective-length 2) color) + vertices))))) + +(defun draw-filled-ellipse (center-x center-y width height &key (color *default-color*) (image *default-image*)) + "Draws a filled ellipse centered at \(CENTER-X, CENTER-Y) with width +WIDTH and height HEIGHT." + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((center-x x-transformer) + (center-y y-transformer) + (width w-transformer) + (height h-transformer)) + (gd-image-filled-ellipse (img image) center-x center-y width height color))) + (values center-x center-y width height)) + +(defun draw-filled-circle (center-x center-y radius &key (color *default-color*) (image *default-image*)) + "Draws a filled circle centered at \(CENTER-X, CENTER-Y) with radius +RADIUS." + (draw-filled-ellipse center-x center-y (* 2 radius) (* 2 radius) + :color color :image image) + (values center-x center-y radius)) + +(defun draw-arc (center-x center-y width height start end &key straight-line center-connect filled (color *default-color*) (image *default-image*)) + "Draws a partial ellipse centered at \(CENTER-X, CENTER-Y) with +width WIDTH and height HEIGHT. The arc begins at angle START and ends +at angle END. If STRAIGHT-LINE is true the start and end points are +just connected with a straight line. If CENTER-CONNECT is true, they +are connected to the center \(which is useful to create 'pie +slices'). If FILLED is true the arc will be filled with COLOR, +otherwise it will be outlined." + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((center-x x-transformer) + (center-y y-transformer) + (width w-transformer) + (height h-transformer) + (start angle-transformer) + (end angle-transformer)) + (cond ((not (or straight-line filled center-connect)) + (gd-image-arc (img image) center-x center-y width height start end color)) + (t + (gd-image-filled-arc (img image) center-x center-y width height start end color + (logior (if straight-line +gd-chord+ 0) + (if filled 0 +gd-no-fill+) + (if center-connect +gd-edged+ 0))))))) + (values center-x center-y width height start end)) + +(defun fill-image (x y &key border (color *default-color*) (image *default-image*)) + "Floods a portion of the image IMAGE with the color COLOR beginning +at point \(X, Y) and extending into the surrounding region. If BORDER +is true it must be a color and the filling will stop at the specified +border color. Otherwise only points with the same color as the +starting point will be colored." + (check-type border (or null integer)) + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((x x-transformer) + (y y-transformer)) + (if border + (gd-image-fill-to-border (img image) x y border color) + (gd-image-fill (img image) x y color)))) + (values x y)) + +(defun clipping-rectangle (&optional (image *default-image*)) + "Returns the clipping rectangle of IMAGE as a list of four +elements." + (check-type image image) + (with-transformed-alternative + (((deref-pointer x1p) x-inv-transformer) + ((deref-pointer y1p) y-inv-transformer) + ((deref-pointer x2p) x-inv-transformer) + ((deref-pointer y2p) y-inv-transformer)) + (with-foreign-object (x1p :int) + (with-foreign-object (y1p :int) + (with-foreign-object (x2p :int) + (with-foreign-object (y2p :int) + (gd-image-get-clip (img image) x1p y1p x2p y2p) + (list (deref-pointer x1p :int) + (deref-pointer y1p :int) + (deref-pointer x2p :int) + (deref-pointer y2p :int)))))))) + +(defun (setf clipping-rectangle) (rectangle &optional (image *default-image*)) + "Sets the clipping rectangle of IMAGE where rectangle should be a +list \(X1 Y1 X2 Y2)." + (check-type image image) + (with-transformed-alternative + (((first rectangle) x-transformer) + ((second rectangle) y-transformer) + ((third rectangle) x-transformer) + ((fourth rectangle) y-transformer)) + (gd-image-set-clip (img image) + (first rectangle) + (second rectangle) + (third rectangle) + (fourth rectangle))) + rectangle) + +(defun clipping-rectangle* (&optional (image *default-image*)) + "Returns the clipping rectangle of IMAGE as four values." + (check-type image image) + (with-transformed-alternative + (((deref-pointer x1p) x-inv-transformer) + ((deref-pointer y1p) y-inv-transformer) + ((deref-pointer x2p) x-inv-transformer) + ((deref-pointer y2p) y-inv-transformer)) + (with-foreign-object (x1p :int) + (with-foreign-object (y1p :int) + (with-foreign-object (x2p :int) + (with-foreign-object (y2p :int) + (gd-image-get-clip (img image) x1p y1p x2p y2p) + (values (deref-pointer x1p :int) + (deref-pointer y1p :int) + (deref-pointer x2p :int) + (deref-pointer y2p :int)))))))) + +(defun set-clipping-rectangle* (x1 y1 x2 y2 &optional (image *default-image*)) + "Sets the clipping rectangle of IMAGE to be the rectangle with upper +left corner \(X1, Y1) and lower right corner \(X2, Y2)." + (check-type image image) + (with-transformed-alternative + ((x1 x-transformer) + (y1 y-transformer) + (x2 x-transformer) + (y2 y-transformer)) + (gd-image-set-clip (img image) x1 y1 x2 y2)) + (values x1 y1 x2 y2)) + +(defmacro with-clipping-rectangle ((rectangle &key (image '*default-image*)) &body body) + "Executes BODY with the clipping rectangle of IMAGE set to RECTANGLE +which should be a list \(X1 Y1 X2 Y2). The previous clipping rectangle +is guaranteed to be restored before the macro exits." + ;; we rebind everything so we have left-to-right evaluation + (with-rebinding (rectangle image) + (with-unique-names (%x1 %y1 %x2 %y2) + `(multiple-value-bind (,%x1 ,%y1 ,%x2 ,%y2) + (without-transformations + (clipping-rectangle* ,image)) + (unwind-protect + (progn + (setf (clipping-rectangle ,image) ,rectangle) + , at body) + (without-transformations + (set-clipping-rectangle* ,%x1 ,%y1 ,%x2 ,%y2 ,image))))))) + +(defmacro with-clipping-rectangle* ((x1 y1 x2 y2 &key (image '*default-image*)) &body body) + "Executes BODY with the clipping rectangle of IMAGE set to the +rectangle with upper left corner \(X1, Y1) and lower right corner +\(X2, Y2). The previous clipping rectangle is guaranteed to be +restored before the macro exits." + ;; we rebind everything so we have left-to-right evaluation + (with-rebinding (x1 y1 x2 y2 image) + (with-unique-names (%x1 %y1 %x2 %y2) + `(multiple-value-bind (,%x1 ,%y1 ,%x2 ,%y2) + (without-transformations + (clipping-rectangle* ,image)) + (unwind-protect + (progn + (set-clipping-rectangle* ,x1 ,y1 ,x2 ,y2 ,image) + , at body) + (without-transformations + (set-clipping-rectangle* ,%x1 ,%y1 ,%x2 ,%y2 ,image))))))) Added: trunk/cl-gd/gd-uffi.lisp ============================================================================== --- (empty file) +++ trunk/cl-gd/gd-uffi.lisp Wed Apr 30 04:38:52 2008 @@ -0,0 +1,731 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/gd-uffi.lisp,v 1.32 2007/04/05 23:22:24 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +;; internal representation of an image in GD +(def-struct gd-image + (pixels (* (* :unsigned-char))) + (sx :int) + (sy :int) + (colors-total :int) + (red (:array :int #.+max-colors+)) + (green (:array :int #.+max-colors+)) + (blue (:array :int #.+max-colors+)) + (open (:array :int #.+max-colors+)) + (transparent :int) + (poly-ints (* :int)) + (poly-allocated :int) + (brush :pointer-self) + (tile :pointer-self) + (brush-color-map (:array :int #.+max-colors+)) + (tile-color-map (:array :int #.+max-colors+)) + (style-length :int) + (style-pos :int) + (style (* :int)) + (interface :int) + (thick :int) + (alpha (:array :int #.+max-colors+)) + (true-color :int) + (t-pixels (* (* :int))) + (alpha-blending-flag :int) + (save-alpha-flag :int) + (aa :int) + (aa-color :int) + (aa-do-not-blend :int) + (aa-opacity (* (* :unsigned-char))) + (aa-polygon :int) + (aal-x1 :int) + (aal-y1 :int) + (aal-x2 :int) + (aal-y2 :int) + (aal-bx-ax :int) + (aal-by-ay :int) + (aal-lab-2 :int) + (aal-lab :float) + (cx1 :int) + (cy1 :int) + (cx2 :int) + (cy2 :int)) + +(def-type pixels-array (* (* :unsigned-char))) +(def-type pixels-row (* :unsigned-char)) +(def-type t-pixels-array (* (* :int))) +(def-type t-pixels-row (* :int)) + +(def-foreign-type gd-image-ptr (* gd-image)) + +;; initialize special variable +(setq *null-image* (make-image (make-null-pointer 'gd-image))) + +;; internal representation of a point in GD, used by the polygon +;; functions +(def-struct gd-point + (x :int) + (y :int)) + +(def-foreign-type gd-point-ptr (* gd-point)) + +;; internal representation of a font in GD, used by the (non-FreeType) +;; functions which draw characters and strings +(def-struct gd-font + (nchars :int) + (offset :int) + (w :int) + (h :int) + (data (* :char))) + +(def-foreign-type gd-font-ptr (* gd-font)) + +;; additional info for calls to the FreeType library - currently only +;; used for line spacing +(def-struct gd-ft-string-extra + (flags :int) + (line-spacing :double) + (charmap :int)) + +(def-foreign-type gd-ft-string-extra-ptr (* gd-ft-string-extra)) + +;; the GD standard fonts used when drawing characters or strings +;; without invoking the FreeType library +(def-foreign-var ("gdFontTiny" +gd-font-tiny+) gd-font-ptr "gd") +(def-foreign-var ("gdFontSmall" +gd-font-small+) gd-font-ptr "gd") +(def-foreign-var ("gdFontMediumBold" +gd-font-medium-bold+) gd-font-ptr "gd") +(def-foreign-var ("gdFontLarge" +gd-font-large+) gd-font-ptr "gd") +(def-foreign-var ("gdFontGiant" +gd-font-giant+) gd-font-ptr "gd") + +;;; all GD functions which are accessed from CL-GD + +(def-function ("gdImageCreate" gd-image-create) + ((sx :int) + (sy :int)) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateTrueColor" gd-image-create-true-color) + ((sx :int) + (sy :int)) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateFromJpegFile" gd-image-create-from-jpeg-file) + ((filename :cstring) + (err (* :int))) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateFromPngFile" gd-image-create-from-png-file) + ((filename :cstring) + (err (* :int))) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateFromGdFile" gd-image-create-from-gd-file) + ((filename :cstring) + (err (* :int))) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateFromGd2File" gd-image-create-from-gd2-file) + ((filename :cstring) + (err (* :int))) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateFromGd2PartFile" gd-image-create-from-gd2-part-file) + ((filename :cstring) + (err (* :int)) + (src-x :int) + (src-y :int) + (w :int) + (h :int)) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateFromXbmFile" gd-image-create-from-xbm-file) + ((filename :cstring) + (err (* :int))) + :returning gd-image-ptr + :module "gd") + +#-:win32 +(def-function ("gdImageCreateFromXpm" gd-image-create-from-xpm) + ((filename :cstring)) + :returning gd-image-ptr + :module "gd") + +#-:cl-gd-no-gif +(def-function ("gdImageCreateFromGifFile" gd-image-create-from-gif-file) + ((filename :cstring) + (err (* :int))) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageJpegPtr" gd-image-jpeg-ptr) + ((im gd-image-ptr) + (size (* :int)) + (quality :int)) + :returning :pointer-void + :module "gd") + +(def-function ("gdImageGdPtr" gd-image-gd-ptr) + ((im gd-image-ptr) + (size (* :int))) + :returning :pointer-void + :module "gd") + +(def-function ("gdImageGd2Ptr" gd-image-gd2-ptr) + ((im gd-image-ptr) + (size (* :int))) + :returning :pointer-void + :module "gd") + +(def-function ("gdImageWBMPPtr" gd-image-wbmp-ptr) + ((im gd-image-ptr) + (size (* :int)) + (fg :int)) + :returning :pointer-void + :module "gd") + +(def-function ("gdImagePngPtr" gd-image-png-ptr) + ((im gd-image-ptr) + (size (* :int))) + :returning :pointer-void + :module "gd") + +(def-function ("gdImagePngPtrEx" gd-image-png-ptr-ex) + ((im gd-image-ptr) + (size (* :int)) + (level :int)) + :returning :pointer-void + :module "gd") + +#-:cl-gd-no-gif +(def-function ("gdImageGifPtr" gd-image-gif-ptr) + ((im gd-image-ptr) + (size (* :int))) + :returning :pointer-void + :module "gd") + +(def-function ("gdImageDestroy" gd-image-destroy) + ((im gd-image-ptr)) + :returning :void + :module "gd") + +(def-function ("gdImageColorAllocate" gd-image-color-allocate) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorAllocateAlpha" gd-image-color-allocate-alpha) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int) + (a :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorDeallocate" gd-image-color-deallocate) + ((im gd-image-ptr) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageColorExact" gd-image-color-exact) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorClosest" gd-image-color-closest) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorClosestHWB" gd-image-color-closest-hwb) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorClosestAlpha" gd-image-color-closest-alpha) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int) + (a :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorResolve" gd-image-color-resolve) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorResolveAlpha" gd-image-color-resolve-alpha) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int) + (a :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorTransparent" gd-image-color-transparent) + ((im gd-image-ptr) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageGetGetTransparent" gd-image-get-transparent) + ((im gd-image-ptr)) + :returning :int + :module "gd") + +(def-function ("gdImageSetAntiAliased" gd-image-set-anti-aliased) + ((im gd-image-ptr) + (c :int)) + :returning :void + :module "gd") + +(def-function ("gdImageSetAntiAliasedDontBlend" gd-image-set-anti-aliased-do-not-blend) + ((im gd-image-ptr) + (c :int) + (dont-blend :int)) + :returning :void + :module "gd") + +(def-function ("gdImageSetBrush" gd-image-set-brush) + ((im gd-image-ptr) + (brush gd-image-ptr)) + :returning :void + :module "gd") + +(def-function ("gdImageSetTile" gd-image-set-tile) + ((im gd-image-ptr) + (tile gd-image-ptr)) + :returning :void + :module "gd") + +(def-function ("gdImageSetStyle" gd-image-set-style) + ((im gd-image-ptr) + (style (* :int)) + (style-length :int)) + :returning :void + :module "gd") + +(def-function ("gdImageSetThickness" gd-image-set-thickness) + ((im gd-image-ptr) + (thickness :int)) + :returning :void + :module "gd") + +(def-function ("gdImageAlphaBlending" gd-image-alpha-blending) + ((im gd-image-ptr) + (blending :int)) + :returning :void + :module "gd") + +(def-function ("gdImageSaveAlpha" gd-image-save-alpha) + ((im gd-image-ptr) + (save-flag :int)) + :returning :void + :module "gd") + +(def-function ("gdImageGetRed" gd-image-get-red) + ((im gd-image-ptr) + (color :int)) + :returning :int + :module "gd") + +(def-function ("gdImageGetGreen" gd-image-get-green) + ((im gd-image-ptr) + (color :int)) + :returning :int + :module "gd") + +(def-function ("gdImageGetBlue" gd-image-get-blue) + ((im gd-image-ptr) + (color :int)) + :returning :int + :module "gd") + +(def-function ("gdImageGetAlpha" gd-image-get-alpha) + ((im gd-image-ptr) + (color :int)) + :returning :int + :module "gd") + +(def-function ("gdImageGetColorsTotal" gd-image-get-colors-total) + ((im gd-image-ptr)) + :returning :int + :module "gd") + +(def-function ("gdImageSetClip" gd-image-set-clip) + ((im gd-image-ptr) + (x1 :int) + (y1 :int) + (x2 :int) + (y2 :int)) + :returning :void + :module "gd") + +(def-function ("gdImageGetClip" gd-image-get-clip) + ((im gd-image-ptr) + (x1p (* :int)) + (y1p (* :int)) + (x2p (* :int)) + (y2p (* :int))) + :returning :void + :module "gd") + +(def-function ("gdImageSetPixel" gd-image-set-pixel) + ((im gd-image-ptr) + (x :int) + (y :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageLine" gd-image-line) + ((im gd-image-ptr) + (x1 :int) + (y1 :int) + (x2 :int) + (y2 :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImagePolygon" gd-image-polygon) + ((im gd-image-ptr) + (points gd-point-ptr) + (points-total :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageFilledPolygon" gd-image-filled-polygon) + ((im gd-image-ptr) + (points gd-point-ptr) + (points-total :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageRectangle" gd-image-rectangle) + ((im gd-image-ptr) + (x1 :int) + (y1 :int) + (x2 :int) + (y2 :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageFilledRectangle" gd-image-filled-rectangle) + ((im gd-image-ptr) + (x1 :int) + (y1 :int) + (x2 :int) + (y2 :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageFilledEllipse" gd-image-filled-ellipse) + ((im gd-image-ptr) + (cx :int) + (cy :int) + (w :int) + (h :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageArc" gd-image-arc) + ((im gd-image-ptr) + (cx :int) + (cy :int) + (w :int) + (h :int) + (s :int) + (e :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageFilledArc" gd-image-filled-arc) + ((im gd-image-ptr) + (cx :int) + (cy :int) + (w :int) + (h :int) + (s :int) + (e :int) + (color :int) + (style :int)) + :returning :void + :module "gd") + +(def-function ("gdImageFill" gd-image-fill) + ((im gd-image-ptr) + (x :int) + (y :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageFillToBorder" gd-image-fill-to-border) + ((im gd-image-ptr) + (x :int) + (y :int) + (border :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageChar" gd-image-char) + ((im gd-image-ptr) + (f gd-font-ptr) + (x :int) + (y :int) + (c :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageCharUp" gd-image-char-up) + ((im gd-image-ptr) + (f gd-font-ptr) + (x :int) + (y :int) + (c :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageString" gd-image-string) + ((im gd-image-ptr) + (f gd-font-ptr) + (x :int) + (y :int) + (s :cstring) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageStringUp" gd-image-string-up) + ((im gd-image-ptr) + (f gd-font-ptr) + (x :int) + (y :int) + (s :cstring) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageStringFT" gd-image-string-ft) + ((im gd-image-ptr) + (brect (* :int)) + (fg :int) + (fontname :cstring) + (ptsize :double) + (angle :double) + (x :int) + (y :int) + (string :cstring)) + :returning :cstring + :module "gd") + +(def-function ("gdImageStringFTEx" gd-image-string-ft-ex) + ((im gd-image-ptr) + (brect (* :int)) + (fg :int) + (fontname :cstring) + (ptsize :double) + (angle :double) + (x :int) + (y :int) + (string :cstring) + (strex gd-ft-string-extra-ptr)) + :returning :cstring + :module "gd") + +(def-function ("gdImageGetPixel" gd-image-get-pixel) + ((im gd-image-ptr) + (x :int) + (y :int)) + :returning :int + :module "gd") + +(def-function ("gdImageBoundsSafe" gd-image-bounds-safe) + ((im gd-image-ptr) + (x :int) + (y :int)) + :returning :int + :module "gd") + +(def-function ("gdImageGetSX" gd-image-get-sx) + ((im gd-image-ptr)) + :returning :int + :module "gd") + +(def-function ("gdImageGetSY" gd-image-get-sy) + ((im gd-image-ptr)) + :returning :int + :module "gd") + +(def-function ("gdImageInterlace" gd-image-interlace) + ((im gd-image-ptr) + (interlace :int)) + :returning :void + :module "gd") + +(def-function ("gdImageGetGetInterlaced" gd-image-get-interlaced) + ((im gd-image-ptr)) + :returning :int + :module "gd") + +(def-function ("gdImageCopy" gd-image-copy) + ((dst gd-image-ptr) + (src gd-image-ptr) + (dest-x :int) + (dest-y :int) + (src-x :int) + (src-y :int) + (w :int) + (h :int)) + :returning :void + :module "gd") + +(def-function ("gdImageCopyMerge" gd-image-copy-merge) + ((dst gd-image-ptr) + (src gd-image-ptr) + (dest-x :int) + (dest-y :int) + (src-x :int) + (src-y :int) + (w :int) + (h :int) + (percent :int)) + :returning :void + :module "gd") + +(def-function ("gdImageCopyMergeGray" gd-image-copy-merge-gray) + ((dst gd-image-ptr) + (src gd-image-ptr) + (dest-x :int) + (dest-y :int) + (src-x :int) + (src-y :int) + (w :int) + (h :int) + (percent :int)) + :returning :void + :module "gd") + +(def-function ("gdImageCopyResized" gd-image-copy-resized) + ((dst gd-image-ptr) + (src gd-image-ptr) + (dst-x :int) + (dst-y :int) + (src-x :int) + (src-y :int) + (dest-w :int) + (dest-h :int) + (src-w :int) + (src-h :int)) + :returning :void + :module "gd") + +(def-function ("gdImageCopyResampled" gd-image-copy-resampled) + ((dst gd-image-ptr) + (src gd-image-ptr) + (dst-x :int) + (dst-y :int) + (src-x :int) + (src-y :int) + (dest-w :int) + (dest-h :int) + (src-w :int) + (src-h :int)) + :returning :void + :module "gd") + +(def-function ("gdImageCopyRotated" gd-image-copy-rotated) + ((dst gd-image-ptr) + (src gd-image-ptr) + (dst-x :double) + (dst-y :double) + (src-x :int) + (src-y :int) + (src-w :int) + (src-h :int) + (angle :int)) + :returning :void + :module "gd") + +(def-function ("gdImagePaletteCopy" gd-image-palette-copy) + ((dst gd-image-ptr) + (src gd-image-ptr)) + :returning :void + :module "gd") + +(def-function ("gdImageCompare" gd-image-compare) + ((im1 gd-image-ptr) + (im2 gd-image-ptr)) + :returning :int + :module "gd") + +(def-function ("gdImageTrueColorToPalette" gd-image-true-color-to-palette) + ((im gd-image-ptr) + (dither :int) + (colors-wanted :int)) + :returning :void + :module "gd") + +(def-function ("gdFree" gd-free) + ((ptr :pointer-void)) + :returning :void + :module "gd") Added: trunk/cl-gd/images.lisp ============================================================================== --- (empty file) +++ trunk/cl-gd/images.lisp Wed Apr 30 04:38:52 2008 @@ -0,0 +1,411 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/images.lisp,v 1.33 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defun create-image (width height &optional true-color) + "Allocates and returns a GD image structure with size WIDTH x +HEIGHT. Creates a true color image if TRUE-COLOR is true. You are +responsible for destroying the image after you're done with it. It is +advisable to use WITH-IMAGE instead." + (check-type width integer) + (check-type height integer) + (let ((image-ptr + (if true-color + (gd-image-create-true-color width height) + (gd-image-create width height)))) + (when (null-pointer-p image-ptr) + (error "Could not allocate image of size ~A x ~A" width height)) + (let ((image (make-image image-ptr))) + image))) + +(defun destroy-image (image) + "Destroys \(deallocates) IMAGE which has been created by +CREATE-IMAGE, CREATE-IMAGE-FROM-FILE, or CREATE-IMAGE-FROM-GD2-PART." + (check-type image image) + (gd-image-destroy (img image)) + nil) + +(defmacro with-default-image ((image) &body body) + "Executes BODY with *DEFAULT-IMAGE* bound to IMAGE so that you don't +have to provide the IMAGE keyword/optional argument to CL-GD +functions." + `(let ((*default-image* ,image)) + , at body)) + +(defmacro with-image ((name width height &optional true-color) &body body) + "Creates an image with size WIDTH x HEIGHT, and executes BODY with +the image bound to NAME. If TRUE-COLOR is true, creates a true color +image. The image is guaranteed to be destroyed before this macro +exits." + ;; we rebind everything so we have left-to-right evaluation + (with-rebinding (width height true-color) + `(with-safe-alloc (,name + (create-image ,width ,height ,true-color) + (destroy-image ,name)) + , at body))) + +(defmacro with-image* ((width height &optional true-color) &body body) + "Creates an image with size WIDTH x HEIGHT and executes BODY with +the image bound to *DEFAULT-IMAGE*. If TRUE-COLOR is true, creates a +true color image. The image is guaranteed to be destroyed before this +macro exits." + `(with-image (*default-image* ,width ,height ,true-color) + , at body)) + +(defun create-image-from-file (file-name &optional type) + "Creates an image from the file specified by FILE-NAME \(which is +either a pathname or a string). The type of the image can be provided +as TYPE or otherwise it will be guessed from the PATHNAME-TYPE of +FILE-NAME. You are responsible for destroying the image after you're +done with it. It is advisable to use WITH-IMAGE-FROM-FILE instead." + (check-type file-name (or pathname string)) + (let* ((pathname-type (pathname-type file-name)) + (%type (or type + (cond ((or (string-equal pathname-type "jpg") + (string-equal pathname-type "jpeg")) + :jpg) + ((string-equal pathname-type "png") + :png) + ((string-equal pathname-type "gd") + :gd) + ((string-equal pathname-type "gd2") + :gd2) + ((string-equal pathname-type "xbm") + :xbm) + #-:win32 + ((string-equal pathname-type "xpm") + :xpm) + #-:cl-gd-no-gif + ((string-equal pathname-type "gif") + :gif))))) + (unless %type + (error "No type provided and it couldn't be guessed from filename")) + (unless (probe-file file-name) + (error "File ~S could not be found" file-name)) + (when (pathnamep file-name) + (setq file-name + #+:cmu (ext:unix-namestring file-name) + #-:cmu (namestring file-name))) + (with-foreign-object (err :int) + (with-cstring (c-file-name file-name) + (let ((image (ecase %type + ((:jpg :jpeg) + (gd-image-create-from-jpeg-file c-file-name err)) + ((:png) + (gd-image-create-from-png-file c-file-name err)) + ((:gd) + (gd-image-create-from-gd-file c-file-name err)) + ((:gd2) + (gd-image-create-from-gd2-file c-file-name err)) + ((:xbm) + (gd-image-create-from-xbm-file c-file-name err)) + #-:win32 + ((:xpm) + (gd-image-create-from-xpm c-file-name)) + #-:cl-gd-no-gif + ((:gif) + (gd-image-create-from-gif-file c-file-name err))))) + (cond ((null-pointer-p image) + (cond ((or (eq %type :xpm) + (zerop (deref-pointer err :int))) + (error "Could not create image from ~A file ~S" + %type file-name)) + (t + (error "Could not create image from ~A file ~S: errno was ~A" + %type file-name (deref-pointer err :int))))) + (t (let ((image (make-image image))) + image)))))))) + +(defmacro with-image-from-file ((name file-name &optional type) &body body) + "Creates an image from the file specified by FILE-NAME \(which is +either a pathname or a string) and executes BODY with the image bound +to NAME. The type of the image can be provied as TYPE or otherwise it +will be guessed from the PATHNAME-TYPE of FILE-NAME. The image is +guaranteed to be destroyed before this macro exits." + ;; we rebind everything so we have left-to-right evaluation + (with-rebinding (file-name type) + `(with-safe-alloc (,name + (create-image-from-file ,file-name ,type) + (destroy-image ,name)) + , at body))) + +(defmacro with-image-from-file* ((file-name &optional type) &body body) + "Creates an image from the file specified by FILE-NAME \(which is +either a pathname or a string) and executes BODY with the image bound +to *DEFAULT-IMAGE*. The type of the image can be provied as TYPE or +otherwise it will be guessed from the PATHNAME-TYPE of FILE-NAME. The +image is guaranteed to be destroyed before this macro exits." + `(with-image-from-file (*default-image* ,file-name ,type) + , at body)) + +(defun create-image-from-gd2-part (file-name src-x src-y width height) + "Creates an image from the part of the GD2 file FILE-NAME \(which is +either a pathname or a string) specified by SRC-X, SRC-Y, WIDTH, and +HEIGHT. You are responsible for destroying the image after you're done +with it. It is advisable to use WITH-IMAGE-FROM-GD2-PART instead." + (check-type file-name (or string pathname)) + (check-type src-x integer) + (check-type src-y integer) + (check-type width integer) + (check-type height integer) + (unless (probe-file file-name) + (error "File ~S could not be found" file-name)) + (when (pathnamep file-name) + (setq file-name + #+:cmu (ext:unix-namestring file-name) + #-:cmu (namestring file-name))) + (with-foreign-object (err :int) + (with-cstring (c-file-name file-name) + (let ((image (gd-image-create-from-gd2-part-file c-file-name err src-x src-y width height))) + (cond ((null-pointer-p image) + (error "Could not create GD2 image from file ~S: errno was ~A" + file-name (deref-pointer err :int))) + (t image)))))) + +(defmacro with-image-from-gd2-part ((name file-name src-x src-y width height) &body body) + "Creates an image from the part of the GD2 file FILE-NAME \(which is +either a pathname or a string) specified SRC-X, SRC-Y, WIDTH, and +HEIGHT and executes BODY with the image bound to NAME. The type of the +image can be provied as TYPE or otherwise it will be guessed from the +PATHNAME-TYPE of FILE-NAME. The image is guaranteed to be destroyed +before this macro exits." + ;; we rebind everything so we have left-to-right evaluation + (with-rebinding (file-name src-x src-y width height) + `(with-safe-alloc (,name + (create-image-from-gd2-part ,file-name ,src-x ,src-y ,width ,height) + (destroy-image ,name)) + , at body))) + +(defmacro with-image-from-gd2-part* ((file-name src-x src-y width height) &body body) + "Creates an image from the part of the GD2 file FILE-NAME \(which is +either a pathname or a string) specified SRC-X, SRC-Y, WIDTH, and +HEIGHT and executes BODY with the image bound to *DEFAULT-IMAGE*. The +type of the image can be provied as TYPE or otherwise it will be +guessed from the PATHNAME-TYPE of FILE-NAME. The image is guaranteed +to be destroyed before this macro exits." + `(with-image-from-gd2-part (*default-image* ,file-name ,src-x ,src-y ,width ,height) + , at body)) + +(defmacro make-stream-fn (name signature gd-call type-checks docstring) + "Internal macro used to generate WRITE-JPEG-TO-STREAM and friends." + `(defun ,name ,signature + ,docstring + , at type-checks + (cond ((or #+(and :allegro :allegro-version>= (version>= 6 0)) + (typep stream 'excl:simple-stream) + #+:lispworks4.3 + (subtypep 'base-char (stream-element-type stream)) + (subtypep '(unsigned-byte 8) (stream-element-type stream))) + (with-foreign-object (size :int) + (with-safe-alloc (memory ,gd-call (gd-free memory)) + (let (#+:lispworks4.3 + (temp-array (make-array 1 :element-type + '(unsigned-byte 8)))) + (with-cast-pointer (temp memory :unsigned-byte) + (dotimes (i (deref-pointer size :int)) + ;; LispWorks workaround, WRITE-BYTE won't work - see + ;; + #+:lispworks4.3 + (setf (aref temp-array 0) + (deref-array temp '(:array :unsigned-byte) i)) + #+:lispworks4.3 + (write-sequence temp-array stream) + #-:lispworks4.3 + (write-byte (deref-array temp '(:array :unsigned-byte) i) + stream)) + image))))) + ((subtypep 'character (stream-element-type stream)) + (with-foreign-object (size :int) + (with-safe-alloc (memory ,gd-call (gd-free memory)) + (with-cast-pointer (temp memory + #+(or :cmu :scl :sbcl) :unsigned-char + #-(or :cmu :scl :sbcl) :char) + (dotimes (i (deref-pointer size :int)) + (write-char (ensure-char-character + (deref-array temp '(:array :char) i)) + stream)) + image)))) + (t (error "Can't use a stream with element-type ~A" + (stream-element-type stream)))))) + +(make-stream-fn write-jpeg-to-stream (stream &key (quality -1) (image *default-image*)) + (gd-image-jpeg-ptr (img image) size quality) + ((check-type stream stream) + (check-type quality (integer -1 100)) + (check-type image image)) + "Writes image IMAGE to stream STREAM as JPEG. If +QUALITY is not specified, the default IJG JPEG quality value is +used. Otherwise, for practical purposes, quality should be a value in +the range 0-95. STREAM must be a character stream or a binary stream +of element type \(UNSIGNED-BYTE 8). If STREAM is a character stream, +the user of this function has to make sure the external format is +yields faithful output of all 8-bit characters.") + +(make-stream-fn write-png-to-stream (stream &key compression-level (image *default-image*)) + (cond (compression-level + (gd-image-png-ptr-ex (img image) size compression-level)) + (t + (gd-image-png-ptr (img image) size))) + ((check-type stream stream) + (check-type compression-level (or null (integer -1 9))) + (check-type image image)) + "Writes image IMAGE to stream STREAM as PNG. If +COMPRESSION-LEVEL is not specified, the default compression level at +the time zlib was compiled on your system will be used. Otherwise, a +compression level of 0 means 'no compression', a compression level of +1 means 'compressed, but as quickly as possible', a compression level +of 9 means 'compressed as much as possible to produce the smallest +possible file.' STREAM must be a character stream or a binary stream +of element type \(UNSIGNED-BYTE 8). If STREAM is a character stream, +the user of this function has to make sure the external format yields +faithful output of all 8-bit characters.") + +#-:cl-gd-no-gif +(make-stream-fn write-gif-to-stream (stream &key (image *default-image*)) + (gd-image-gif-ptr (img image) size) + ((check-type stream stream) + (check-type image image)) + "Writes image IMAGE to stream STREAM as GIF. STREAM +must be a character stream or a binary stream of element type +\(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this +function has to make sure the external format yields faithful output +of all 8-bit characters.") + +(make-stream-fn write-wbmp-to-stream (stream &key foreground (image *default-image*)) + (gd-image-wbmp-ptr (img image) size foreground) + ((check-type stream stream) + (check-type foreground integer) + (check-type image image)) + "Writes image IMAGE to stream STREAM as WBMP. STREAM +must be a character stream or a binary stream of element type +\(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this +function has to make sure the external format yields faithful output +of all 8-bit characters. WBMP file support is black and white +only. The color index specified by the FOREGOUND argument is the +\"foreground,\" and only pixels of this color will be set in the WBMP +file") + +(make-stream-fn write-gd-to-stream (stream &key (image *default-image*)) + (gd-image-gd-ptr (img image) size) + ((check-type stream stream) + (check-type image image)) + "Writes image IMAGE to stream STREAM as GD. STREAM +must be a character stream or a binary stream of element type +\(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this +function has to make sure the external format yields faithful output +of all 8-bit characters.") + +(make-stream-fn write-gd2-to-stream (stream &key (image *default-image*)) + (gd-image-gd2-ptr (img image) size) + ((check-type stream stream) + (check-type image image)) + "Writes image IMAGE to stream STREAM as GD2. STREAM +must be a character stream or a binary stream of element type +\(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this +function has to make sure the external format yields faithful output +of all 8-bit characters.") + +(defun write-image-to-stream (stream type &rest rest &key &allow-other-keys) + "Writes image to STREAM. The type of the image is determined by TYPE +which must be one of :JPG, :JPEG, :PNG, :WBMP, :GD, or :GD2. STREAM +must be a character stream or a binary stream of element type +\(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this +function has to make sure the external format yields faithful output +of all 8-bit characters." + (apply (ecase type + ((:jpg :jpeg) + #'write-jpeg-to-stream) + ((:png) + #'write-png-to-stream) + ((:wbmp) + #'write-wbmp-to-stream) + ((:gd) + #'write-gd-to-stream) + ((:gd2) + #'write-gd2-to-stream) + #-:cl-gd-no-gif + ((:gif) + #'write-gif-to-stream)) + stream rest)) + +(defun write-image-to-file (file-name &rest rest &key type (if-exists :error) &allow-other-keys) + "Writes image to the file specified by FILE-NAME \(a pathname or a +string). The TYPE argument is interpreted as in +WRITE-IMAGE-TO-STREAM. If it is not provided it is guessed from the +PATHNAME-TYPE of FILE-NAME. The IF-EXISTS keyword argument is given to +OPEN. Other keyword argument like QUALITY or COMPRESSION-LEVEL can be +provided depending on the images's type." + (with-open-file (stream file-name :direction :output + :if-exists if-exists + :element-type '(unsigned-byte 8)) + (apply #'write-image-to-stream + stream + (or type + (let ((pathname-type (pathname-type (truename file-name)))) + (cond ((or (string-equal pathname-type "jpg") + (string-equal pathname-type "jpeg")) + :jpg) + ((string-equal pathname-type "png") + :png) + ((string-equal pathname-type "wbmp") + :wbmp) + ((string-equal pathname-type "gd") + :gd) + ((string-equal pathname-type "gd2") + :gd2) + #-:cl-gd-no-gif + ((string-equal pathname-type "gif") + :gif) + (t + (error "Can't determine the type of the image"))))) + (sans rest :type :if-exists)))) + +(defun image-width (&optional (image *default-image*)) + "Returns width of IMAGE." + (check-type image image) + (with-transformed-alternative + (((gd-image-get-sx (img image)) w-inv-transformer)) + (gd-image-get-sx (img image)))) + +(defun image-height (&optional (image *default-image*)) + (check-type image image) + "Returns height of IMAGE." + (with-transformed-alternative + (((gd-image-get-sy (img image)) h-inv-transformer)) + (gd-image-get-sy (img image)))) + +(defun image-size (&optional (image *default-image*)) + (check-type image image) + "Returns width and height of IMAGE as two values." + (with-transformed-alternative + (((gd-image-get-sx (img image)) w-inv-transformer) + ((gd-image-get-sy (img image)) h-inv-transformer)) + (values (gd-image-get-sx (img image)) + (gd-image-get-sy (img image))))) Added: trunk/cl-gd/init.lisp ============================================================================== --- (empty file) +++ trunk/cl-gd/init.lisp Wed Apr 30 04:38:52 2008 @@ -0,0 +1,46 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/init.lisp,v 1.12 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defun load-gd-glue () + "Load the little glue library we have to create for the image input +functions." + ;; try to find the library at different places + (let ((filename (find-foreign-library "cl-gd-glue" + *shared-library-directories* + :types *shared-library-types* + :drive-letters *shared-library-drive-letters*))) + (load-foreign-library filename + :module "gd" + :supporting-libraries *gd-supporting-libraries*))) + +;; invoke the function, i.e. load the library (and thus GD itself) +;; before gd-uffi.lisp is loaded/compiled +(load-gd-glue) Added: trunk/cl-gd/misc.lisp ============================================================================== --- (empty file) +++ trunk/cl-gd/misc.lisp Wed Apr 30 04:38:52 2008 @@ -0,0 +1,238 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/misc.lisp,v 1.15 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defun interlacedp (&optional (image *default-image*)) + "Returns whether IMAGE will be stored in an interlaced fashion." + (check-type image image) + (not (zerop (gd-image-get-interlaced (img image))))) + +(defun (setf interlacedp) (interlaced &optional (image *default-image*)) + "Sets whether IMAGE will be stored in an interlaced fashion." + (check-type image image) + (gd-image-interlace (img image) (if interlaced 1 0)) + interlaced) + +(defun differentp (image1 image2) + "Returns false if the two images won't appear different when +displayed. Otherwise the return value is a list of keywords describing +the differences between the images." + (check-type image1 image) + (check-type image2 image) + (let ((result (gd-image-compare (img image1) (img image2)))) + (cond ((zerop (logand +gd-cmp-image+ result)) + nil) + (t + (loop for (gd-flag keyword) in `((,+gd-cmp-num-colors+ + :different-number-of-colors) + (,+gd-cmp-color+ + :different-colors) + (,+gd-cmp-size-x+ + :different-widths) + (,+gd-cmp-size-y+ + :different-heights) + (,+gd-cmp-transparent+ + :different-transparent-colors) + (,+gd-cmp-background+ + :different-background-colors) + (,+gd-cmp-interlace+ + :different-interlace-settings) + (,+gd-cmp-true-color+ + :true-color-versus-palette-based)) + when (plusp (logand gd-flag result)) + collect keyword))))) + +(defun copy-image (source destination + source-x source-y + dest-x dest-y + width height + &key resample + rotate angle + resize dest-width dest-height + merge merge-gray) + "Copies \(a part of) image SOURCE into image DESTINATION. Copies the +rectangle with the upper left corner \(SOURCE-X,SOURCE-Y) and size +WIDTH x HEIGHT to the rectangle with the upper left corner +\(DEST-X,DEST-Y). + +If RESAMPLE is true pixel colors will be smoothly interpolated. If +RESIZE is true the copied rectangle will be strechted or shrinked so +that its size is DEST-WIDTH x DEST-HEIGHT. If ROTATE is true the image +will be rotated by ANGLE. In this particular case DEST-X and DEST-Y +specify the CENTER of the copied image rather than its upper left +corner! If MERGE is true it has to be an integer in the range 0-100 +and the two images will be 'merged' by the amount specified. If MERGE +is 100 then the source image will simply be copied. If instead +MERGE-GRAY is true the hue of the source image is preserved by +converting the destination area to gray pixels before merging. + +The keyword options RESAMPLE, ROTATE, RESIZE, MERGE, and MERGE-GRAY +are mutually exclusive \(with the exception of RESAMPLE and +RESIZE). ANGLE is assumed to be specified in degrees if it's an +integer, and in radians otherwise." + (check-type source image) + (check-type destination image) + (check-type source-x integer) + (check-type source-y integer) + (unless rotate + (check-type dest-x integer) + (check-type dest-y integer)) + (check-type width integer) + (check-type height integer) + (check-type angle (or null number)) + (check-type dest-width (or null integer)) + (check-type dest-height (or null integer)) + (check-type merge (or null (integer 0 100))) + (check-type merge-gray (or null (integer 0 100))) + (when (and merge merge-gray) + (error "You can't specify MERGE and MERGE-GRAY at the same time.")) + (when (and (or merge merge-gray) + (or resample rotate resize)) + (error "MERGE and MERGE-GRAY can't be combined with RESAMPLE, ROTATE, or RESIZE.")) + (when (and (or dest-width dest-height) + (not resize)) + (error "Use RESIZE if you want to specify DEST-WIDTH or DEST-HEIGHT")) + (when (and resize + (not (or dest-width dest-height))) + (error "Please specify DEST-WIDTH and DEST-HEIGHT together with RESIZE.")) + (when (and angle + (not rotate)) + (error "Use ROTATE if you want to specify ANGLE.")) + (when (and rotate + (not angle)) + (error "Please specify ANGLE together with ROTATE.")) + (when (and rotate + (or resample resize)) + (error "ROTATE can't be used together with RESAMPLE or RESIZE.")) + (cond ((and resample resize) + (gd-image-copy-resampled (img destination) (img source) + dest-x dest-y source-x source-y + dest-width dest-height width height)) + (resample + (gd-image-copy-resampled (img destination) (img source) + dest-x dest-y source-x source-y + width height width height)) + ((and rotate (integerp angle)) + (gd-image-copy-rotated (img destination) (img source) + (coerce dest-x 'double-float) + (coerce dest-y 'double-float) + source-x source-y width height angle)) + (rotate + (gd-image-copy-rotated (img destination) (img source) + (coerce dest-x 'double-float) + (coerce dest-y 'double-float) + source-x source-y width height + (round (* angle +radians-to-degree-factor+)))) + (resize + (gd-image-copy-resized (img destination) (img source) + dest-x dest-y source-x source-y + dest-width dest-height width height)) + (merge + (gd-image-copy-merge (img destination) (img source) + dest-x dest-y source-x source-y + width height merge)) + (merge-gray + (gd-image-copy-merge-gray (img destination) (img source) + dest-x dest-y source-x source-y + width height merge-gray)) + (t + (gd-image-copy (img destination) (img source) dest-x dest-y + source-x source-y width height))) + destination) + +(defun copy-palette (source destination) + "Copies palette of image SOURCE to image DESTINATION attempting to +match the colors in the target image to the colors in the source +palette." + (check-type source image) + (check-type destination image) + (gd-image-palette-copy (img destination) (img source)) + destination) + +(defun true-color-to-palette (&key dither (colors-wanted 256) (image *default-image*)) + "Converts the true color image IMAGE to a palette-based image using +a high-quality two-pass quantization routine. If DITHER is true, the +image will be dithered to approximate colors better, at the expense of +some obvious \"speckling.\" COLORS-WANTED can be any positive integer +up to 256 \(which is the default). If the original source image +includes photographic information or anything that came out of a JPEG, +256 is strongly recommended. 100% transparency of a single transparent +color in the original true color image will be preserved. There is no +other support for preservation of alpha channel or transparency in the +destination image." + (check-type image image) + (check-type colors-wanted (integer 0 256)) + (gd-image-true-color-to-palette (img image) + (if dither 1 0) + colors-wanted) + image) + +(defmacro do-rows ((y-var &optional (image '*default-image*)) &body body) + (with-rebinding (image) + (with-unique-names (img width height true-color-p raw-pixels row x-var inner-body) + `(let* ((,img (img ,image)) + (,width (gd-image-get-sx ,img)) + (,height (gd-image-get-sy ,img)) + (,true-color-p (true-color-p ,image))) + (declare (fixnum ,width ,height)) + (cond (,true-color-p + (let ((,raw-pixels (get-slot-value ,img 'gd-image 't-pixels))) + (declare (type t-pixels-array ,raw-pixels)) + (dotimes (,y-var ,height) + (let ((,row (deref-array ,raw-pixels '(:array (* :int)) ,y-var))) + (declare (type t-pixels-row ,row)) + (macrolet ((do-pixels-in-row ((,x-var) &body ,inner-body) + `(dotimes (,,x-var ,',width) + (macrolet ((raw-pixel () + `(deref-array ,',',row '(:array :int) ,',,x-var))) + (locally + ,@,inner-body))))) + (locally + , at body)))))) + (t + (let ((,raw-pixels (get-slot-value ,img 'gd-image 'pixels))) + (declare (type pixels-array ,raw-pixels)) + (dotimes (,y-var ,height) + (let ((,row (deref-array ,raw-pixels '(:array (* :unsigned-char)) ,y-var))) + (declare (type pixels-row ,row)) + (macrolet ((do-pixels-in-row ((,x-var) &body ,inner-body) + `(dotimes (,,x-var ,',width) + (macrolet ((raw-pixel () + `(deref-array ,',',row '(:array :unsigned-char) ,',,x-var))) + (locally + ,@,inner-body))))) + (locally + , at body))))))))))) + +(defmacro do-pixels ((&optional (image '*default-image*)) &body body) + (with-unique-names (x y) + `(do-rows (,y ,image) + (do-pixels-in-row (,x) + , at body)))) \ No newline at end of file Added: trunk/cl-gd/packages.lisp ============================================================================== --- (empty file) +++ trunk/cl-gd/packages.lisp Wed Apr 30 04:38:52 2008 @@ -0,0 +1,80 @@ +(in-package #:cl-user) + +(defpackage #:cl-gd + (:use #:cl #:uffi) + (:export #:*default-image* + #:*default-color* + #:*default-font* + #:+max-colors+ + #:without-transformations + #:with-transformation + #:create-image + #:destroy-image + #:with-image + #:create-image-from-file + #:with-image-from-file + #:create-image-from-gd2-part + #:with-image-from-gd2-part + #:with-default-image + #:with-image* + #:with-image-from-file* + #:with-image-from-gd2-part* + #:write-jpeg-to-stream + #:write-png-to-stream + #:write-wbmp-to-stream + #:write-gd-to-stream + #:write-gd2-to-stream + #-:cl-gd-no-gif #:write-gif-to-stream + #:write-image-to-stream + #:write-image-to-file + #:image-width + #:image-height + #:image-size + #:make-brush + #:make-tile + #:make-anti-aliased + #:with-default-color + #:allocate-color + #:deallocate-color + #:transparent-color + #:true-color-p + #:number-of-colors + #:find-color + #:find-color-from-image + #:thickness + #:with-thickness + #:alpha-blending-p + #:save-alpha-p + #:color-component + #:color-components + #:draw-polygon + #:draw-line + #:get-pixel + #:set-pixel + #:set-pixels + #:draw-rectangle + #:draw-rectangle* + #:draw-arc + #:draw-filled-ellipse + #:draw-filled-circle + #:fill-image + #:clipping-rectangle + #:clipping-rectangle* + #:set-clipping-rectangle* + #:with-clipping-rectangle + #:with-clipping-rectangle* + #:with-default-font + #:draw-character + #:draw-string + #:draw-freetype-string + #:interlacedp + #:differentp + #:copy-image + #:copy-palette + #:true-color-to-palette + #:do-rows + #:do-pixels-in-row + #:do-pixels + #:raw-pixel)) + +(pushnew :cl-gd *features*) Added: trunk/cl-gd/specials.lisp ============================================================================== --- (empty file) +++ trunk/cl-gd/specials.lisp Wed Apr 30 04:38:52 2008 @@ -0,0 +1,173 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/specials.lisp,v 1.29 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package #:cl-gd) + +(defvar *default-image* nil + "The default image. This special variable is usually bound by +WITH-IMAGE or WITH-IMAGE-FROM-FILE.") + +(defvar *default-color* nil + "The default color. This special variable is usually bound by +WITH-COLOR.") + +(defvar *default-font* nil + "The default font. This special variable is usually bound by +WITH-FONT.") + +(defstruct (image + (:conc-name nil) + (:constructor make-image (img)) + (:copier nil)) + img) + +(defstruct (brush + (:include image) + (:constructor %make-brush (img)) + (:copier nil))) + +(defun make-brush (image) + (%make-brush (img image))) + +(defstruct (tile + (:include image) + (:constructor %make-tile (img)) + (:copier nil))) + +(defun make-tile (image) + (%make-tile (img image))) + +(defstruct (anti-aliased-color + (:conc-name nil) + (:constructor %make-anti-aliased (color do-not-blend)) + (:copier nil)) + color do-not-blend) + +(defun make-anti-aliased (color &optional do-not-blend) + (%make-anti-aliased color do-not-blend)) + +;; the following variable will be initialized in "gd-uffi.lisp" +(defvar *null-image* nil + "A 'null' image which might be useful for DRAW-FREETYPE-STRING.") + +(defconstant +max-colors+ 256 + "Maximum number of colors for palette-based images.") + +(defconstant +gd-chord+ 1 + "Used internally by GD-FILLED-ARC") +(defconstant +gd-no-fill+ 2 + "Used internally by GD-FILLED-ARC") +(defconstant +gd-edged+ 4 + "Used internally by GD-FILLED-ARC") + +(defconstant +brushed+ -3 + "Special 'color' for lines drawn with brush.") +(defconstant +styled+ -2 + "Special 'color' for styled lines.") +(defconstant +styled-brushed+ -4 + "Special 'color' for lines drawn with styled brush.") +(defconstant +transparent+ -6 + "Special 'color' used in GD function 'gdImageSetStyle' for transparent color.") +(defconstant +tiled+ -5 + "Special fill 'color' used for tiles.") +(defconstant +anti-aliased+ -7 + "Special 'color' for anti-aliased lines.") + +(defconstant +gd-ftex-linespace+ 1 + "Indicate line-spacing for FreeType library.") + +(defconstant +gd-cmp-image+ 1 + "Images will appear different when displayed.") +(defconstant +gd-cmp-num-colors+ 2 + "Number of colors in palette differ.") +(defconstant +gd-cmp-color+ 4 + "Image colors differ.") +(defconstant +gd-cmp-size-x+ 8 + "Image widths differ.") +(defconstant +gd-cmp-size-y+ 16 + "Image heights differ.") +(defconstant +gd-cmp-transparent+ 32 + "Transparent color is different.") +(defconstant +gd-cmp-background+ 64 + "Background color is different.") +(defconstant +gd-cmp-interlace+ 128 + "Interlace settings are different.") +(defconstant +gd-cmp-true-color+ 256 + "One image is a true-color image, the other one is palette-based.") + +(defvar *shared-library-directories* + `(,(namestring (make-pathname :name nil + :type nil + :version :newest + :defaults cl-gd.system:*cl-gd-directory*)) + "/usr/local/lib/" + "/usr/lib/" + "/usr/lib/cl-gd/" + "/cygwin/usr/local/lib/" + "/cygwin/usr/lib/") + "A list of directories where UFFI tries to find cl-gd-glue.so") +(defvar *shared-library-types* '("so" "dll" "dylib") + "The list of types a shared library can have. Used when looking for +cl-gd-glue.so") +(defvar *shared-library-drive-letters* '("C" "D" "E" "F" "G") + "The list of drive letters \(used by Wintendo) used when looking for +cl-gd-glue.dll.") + +(defvar *gd-supporting-libraries* '("c" "gd" "png" "z" "jpeg" "freetype" "iconv" "m") + "The libraries which are needed by cl-gd-glues.so \(and GD +itself). Only needed for Python-based Lisps like CMUCL, SBCL, or +SCL.") + +(defconstant +radians-to-degree-factor+ (/ 360 (* 2 pi)) + "Factor to convert from radians to degrees.") + +(defvar *transformers* nil + "Stack of currently active transformer objects.") + +(defconstant +most-positive-unsigned-byte-32+ + (1- (expt 2 31)) + "Name says it all...") + +;; stuff for Nikodemus Siivola's HYPERDOC +;; see +;; and + +(defvar *hyperdoc-base-uri* "http://weitz.de/cl-gd/") + +(let ((exported-symbols-alist + (loop for symbol being the external-symbols of :cl-gd + collect (cons symbol + (concatenate 'string + "#" + (string-downcase symbol)))))) + (defun hyperdoc-lookup (symbol type) + (declare (ignore type)) + (cdr (assoc symbol + exported-symbols-alist + :test #'eq)))) \ No newline at end of file Added: trunk/cl-gd/strings.lisp ============================================================================== --- (empty file) +++ trunk/cl-gd/strings.lisp Wed Apr 30 04:38:52 2008 @@ -0,0 +1,194 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/strings.lisp,v 1.23 2007/04/24 09:01:39 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defmacro with-default-font ((font) &body body) + "Execute BODY with *DEFAULT-FONT* bound to FONT so that you +don't have to provide the FONT keyword/optional argument to +string functions. But note that the fonts used for +DRAW-STRING/DRAW-CHARACTER and DRAW-FREETYPE-STRING are +incompatible." + `(let ((*default-font* ,font)) + , at body)) + +(defun draw-character (x y char &key up (font *default-font*) (color *default-color*) (image *default-image*)) + "Draws the character CHAR from font FONT in color COLOR at position +\(X,Y). If UP is true the character will be drawn from bottom to top +\(rotated 90 degrees). FONT must be one of :TINY, :SMALL, :MEDIUM, +:LARGE, :GIANT." + (check-type char character) + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((x x-transformer) + (y y-transformer)) + (if up + (gd-image-char-up (img image) (ecase font + ((:tiny) +gd-font-tiny+) + ((:small) +gd-font-small+) + ((:medium :medium-bold) +gd-font-medium-bold+) + ((:large) +gd-font-large+) + ((:giant) +gd-font-giant+)) + x y (char-code char) color) + (gd-image-char (img image) (ecase font + ((:tiny) +gd-font-tiny+) + ((:small) +gd-font-small+) + ((:medium :medium-bold) +gd-font-medium-bold+) + ((:large) +gd-font-large+) + ((:giant) +gd-font-giant+)) + x y (char-code char) color)))) + char) + +(defun draw-string (x y string &key up (font *default-font*) (color *default-color*) (image *default-image*)) + "Draws the string STRING in color COLOR at position \(X,Y). If UP is +true the character will be drawn from bottom to top \(rotated 90 +degrees). FONT must be one of :TINY, :SMALL, :MEDIUM, :LARGE, :GIANT." + (check-type string string) + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((x x-transformer) + (y y-transformer)) + (with-cstring (c-string string) + (if up + (gd-image-string-up (img image) (ecase font + ((:tiny) +gd-font-tiny+) + ((:small) +gd-font-small+) + ((:medium :medium-bold) +gd-font-medium-bold+) + ((:large) +gd-font-large+) + ((:giant) +gd-font-giant+)) + x y c-string color) + (gd-image-string (img image) (ecase font + ((:tiny) +gd-font-tiny+) + ((:small) +gd-font-small+) + ((:medium :medium-bold) +gd-font-medium-bold+) + ((:large) +gd-font-large+) + ((:giant) +gd-font-giant+)) + x y c-string color))))) + string) + +(defun draw-freetype-string (x y string + &key (anti-aliased t) + (point-size 12.0d0) + (angle 0.0d0) + (convert-chars t) + line-spacing + (font-name *default-font*) + do-not-draw + (color *default-color*) + (image *default-image*)) + "Draws the string STRING in color COLOR at position \(X,Y) using the +FreeType library. FONT-NAME is the full path \(a pathname or a string) +to a TrueType font file, or a font face name if the GDFONTPATH +environment variable or FreeType's DEFAULT_FONTPATH variable have been +set intelligently. The string may be arbitrarily scaled \(POINT-SIZE) +and rotated \(ANGLE in radians). The direction of rotation is +counter-clockwise, with 0 radians \(0 degrees) at 3 o'clock and PI/2 +radians \(90 degrees) at 12 o'clock. Note that the ANGLE argument is +purposefully _not_ affected by WITH-TRANSFORMATION. If ANTI-ALIASED if +false, anti-aliasing is disabled. It is enabled by default. To output +multiline text with a specific line spacing, provide a value for +LINE-SPACING, expressed as a multiple of the font height. The default +is to use 1.05. The string may contain XML character entity references +like \"À\". If CONVERT-CHARS is true \(which is the default) +characters of STRING with CHAR-CODE greater than 127 are converted +accordingly. This of course pre-supposes that your Lisp's CHAR-CODE +function returns ISO/IEC 10646 (Unicode) character codes. + +The return value is an array containing 8 elements representing the 4 +corner coordinates \(lower left, lower right, upper right, upper left) +of the bounding rectangle around the string that was drawn. The points +are relative to the text regardless of the angle, so \"upper left\" +means in the top left-hand corner seeing the text horizontally. Set +DO-NOT-DRAW to true to get the bounding rectangle without +rendering. This is a relatively cheap operation if followed by a +rendering of the same string, because of the caching of the partial +rendering during bounding rectangle calculation." + (check-type string string) + (check-type font-name (or pathname string)) + (unless do-not-draw + (check-type color integer) + (check-type image image)) + (with-transformed-alternative + ((x x-transformer) + (y y-transformer) + ((deref-array c-bounding-rectangle '(:array :int) i) x-inv-transformer) + ((deref-array c-bounding-rectangle '(:array :int) (1+ i)) y-inv-transformer)) + (when do-not-draw + (setq color 0 + image *null-image*)) + (when (pathnamep font-name) + (setq font-name (namestring font-name))) + (when convert-chars + (setq string (convert-to-char-references string))) + (with-cstring (c-font-name font-name) + (with-cstring (c-string string) + (with-safe-alloc (c-bounding-rectangle + (allocate-foreign-object :int 8) + (free-foreign-object c-bounding-rectangle)) + (let ((msg (convert-from-cstring + (cond (line-spacing + (with-foreign-object (strex 'gd-ft-string-extra) + (setf (get-slot-value strex + 'gd-ft-string-extra + 'flags) + +gd-ftex-linespace+ + (get-slot-value strex + 'gd-ft-string-extra + 'line-spacing) + (coerce line-spacing 'double-float)) + (gd-image-string-ft-ex (img image) + c-bounding-rectangle + (if anti-aliased color (- color)) + c-font-name + (coerce point-size 'double-float) + (coerce angle 'double-float) + x y + c-string + strex))) + (t + (gd-image-string-ft (img image) + c-bounding-rectangle + (if anti-aliased color (- color)) + c-font-name + (coerce point-size 'double-float) + (coerce angle 'double-float) + x y + c-string)))))) + (when msg + (error "Error in FreeType library: ~A" msg)) + (let ((bounding-rectangle (make-array 8))) + ;; strange iteration due to WITH-TRANSFORMED-ALTERNATIVE + (loop for i below 8 by 2 do + (setf (aref bounding-rectangle i) + (deref-array c-bounding-rectangle '(:array :int) i)) + (setf (aref bounding-rectangle (1+ i)) + (deref-array c-bounding-rectangle '(:array :int) (1+ i)))) + bounding-rectangle))))))) \ No newline at end of file Added: trunk/cl-gd/svn-commit.2.tmp ============================================================================== --- (empty file) +++ trunk/cl-gd/svn-commit.2.tmp Wed Apr 30 04:38:52 2008 @@ -0,0 +1,4 @@ +Import current version +--This line, and those below, will be ignored-- + +A . Added: trunk/cl-gd/svn-commit.tmp ============================================================================== --- (empty file) +++ trunk/cl-gd/svn-commit.tmp Wed Apr 30 04:38:52 2008 @@ -0,0 +1,4 @@ +Branches dir +--This line, and those below, will be ignored-- + +A svn+ssh://eweitz at common-lisp.net/project/cl-gd/svn/trunk/branches Added: trunk/cl-gd/test/demoin.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/orig/anti-aliased-lines.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/orig/brushed-arc.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/orig/chart.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/orig/circle.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/orig/clipped-tangent.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/orig/one-line.jpg ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/orig/one-line.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/orig/one-pixel.jpg ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/orig/one-pixel.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/orig/triangle.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/orig/zappa-ellipse.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/orig/zappa-green.jpg ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/smallzappa.png ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/test/zappa.jpg ============================================================================== Binary file. No diff available. Added: trunk/cl-gd/transform.lisp ============================================================================== --- (empty file) +++ trunk/cl-gd/transform.lisp Wed Apr 30 04:38:52 2008 @@ -0,0 +1,193 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/transform.lisp,v 1.21 2007/07/29 16:37:13 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defclass transformer () + ((image :initarg :image + :reader image) + (w-transformer :initarg :w-transformer + :reader w-transformer + :type function) + (h-transformer :initarg :h-transformer + :reader h-transformer + :type function) + (x-transformer :initarg :x-transformer + :reader x-transformer + :type function) + (y-transformer :initarg :y-transformer + :reader y-transformer + :type function) + (w-inv-transformer :initarg :w-inv-transformer + :reader w-inv-transformer + :type function) + (h-inv-transformer :initarg :h-inv-transformer + :reader h-inv-transformer + :type function) + (x-inv-transformer :initarg :x-inv-transformer + :reader x-inv-transformer + :type function) + (y-inv-transformer :initarg :y-inv-transformer + :reader y-inv-transformer + :type function) + (angle-transformer :initarg :angle-transformer + :reader angle-transformer + :type function)) + (:documentation "Class used internally for WITH-TRANSFORMATION +macro.")) + +(defmacro without-transformations (&body body) + "Executes BODY without any transformations applied." + `(let (*transformers*) + , at body)) + +(declaim (inline round-to-c-int)) +(defun round-to-signed-byte-32 (x) + "Like ROUND but make sure result isn't longer than 32 bits." + (mod (round x) +most-positive-unsigned-byte-32+)) + +(defmacro with-transformation ((&key x1 x2 width y1 y2 height reverse-x reverse-y (radians t) (image '*default-image*)) &body body) + "Executes BODY such that all points and width/height data are +subject to a simple affine transformation defined by the keyword +parameters. The new x-axis of IMAGE will start at X1 and end at X2 and +have length WIDTH. The new y-axis of IMAGE will start at Y1 and end at +Y2 and have length HEIGHT. In both cases it suffices to provide two of +the three values - if you provide all three they have to match. If +REVERSE-X is false the x-axis will be oriented as usual in Cartesian +coordinates, otherwise its direction will be reversed. The same +applies to REVERSE-Y, of course. If RADIANS is true angles inside of +BODY will be assumed to be provided in radians, otherwise in degrees." + (with-rebinding (x1 x2 width y1 y2 height reverse-x reverse-y radians image) + (with-unique-names (image-width image-height + stretch-x stretch-y + w-transformer h-transformer + x-transformer y-transformer + w-inv-transformer h-inv-transformer + x-inv-transformer y-inv-transformer + angle-transformer) + ;; rebind for thread safety + `(let ((*transformers* *transformers*)) + (unless (<= 2 (count-if #'identity (list ,x1 ,x2 ,width))) + (error "You must provide at least two of X1, X2, and WIDTH.")) + (unless (<= 2 (count-if #'identity (list ,y1 ,y2 ,height))) + (error "You must provide at least two of Y1, Y2, and HEIGHT.")) + (when (and ,x1 ,x2 ,width + (/= ,width (- ,x2 ,x1))) + (error "X1, X2, and WIDTH don't match. Try to provide just two of the three arguments.")) + (when (and ,y1 ,y2 ,height + (/= ,height (- ,y2 ,y1))) + (error "Y1, Y2, and HEIGHT don't match. Try to provide just two of the three arguments.")) + ;; kludgy code to keep SBCL quiet + (unless ,x1 (setq ,x1 (- ,x2 ,width))) + (unless ,x2 (setq ,x2 (+ ,x1 ,width))) + (unless ,width (setq ,width (- ,x2 ,x1))) + (unless ,y1 (setq ,y1 (- ,y2 ,height))) + (unless ,y2 (setq ,y2 (+ ,y1 ,height))) + (unless ,height (setq ,height (- ,y2 ,y1))) + (multiple-value-bind (,image-width ,image-height) + (without-transformations + (image-size ,image)) + (let* ((,stretch-x (/ ,image-width ,width)) + (,stretch-y (/ ,image-height ,height)) + (,w-transformer (lambda (w) + (round-to-signed-byte-32 + (* w ,stretch-x)))) + (,w-inv-transformer (lambda (w) + (/ w ,stretch-x))) + (,h-transformer (lambda (h) + (round-to-signed-byte-32 + (* h ,stretch-y)))) + (,h-inv-transformer (lambda (h) + (/ h ,stretch-y))) + (,x-transformer (if ,reverse-x + (lambda (x) + (round-to-signed-byte-32 + (* (- ,x2 x) ,stretch-x))) + (lambda (x) + (round-to-signed-byte-32 + (* (- x ,x1) ,stretch-x))))) + (,x-inv-transformer (if ,reverse-x + (lambda (x) + (- ,x2 (/ x ,stretch-x))) + (lambda (x) + (+ ,x1 (/ x ,stretch-x))))) + (,y-transformer (if ,reverse-y + (lambda (y) + (round-to-signed-byte-32 + (* (- y ,y1) ,stretch-y))) + (lambda (y) + (round-to-signed-byte-32 + (* (- ,y2 y) ,stretch-y))))) + (,y-inv-transformer (if ,reverse-y + (lambda (y) + (+ ,y1 (/ y ,stretch-y))) + (lambda (y) + (- ,y2 (/ y ,stretch-y))))) + (,angle-transformer (cond (,radians + (lambda (angle) + (round-to-signed-byte-32 + (* angle + +radians-to-degree-factor+)))) + (t + #'identity)))) + (push (make-instance 'transformer + :image ,image + :w-transformer ,w-transformer + :h-transformer ,h-transformer + :x-transformer ,x-transformer + :y-transformer ,y-transformer + :w-inv-transformer ,w-inv-transformer + :h-inv-transformer ,h-inv-transformer + :x-inv-transformer ,x-inv-transformer + :y-inv-transformer ,y-inv-transformer + :angle-transformer ,angle-transformer) + *transformers*) + (unwind-protect + (progn + , at body) + (pop *transformers*)))))))) + +(defmacro with-transformed-alternative ((&rest transformations) &body body) + "Internal macro used to make functions +transformation-aware. TRANSFORMATION is a list of (EXPR +TRANSFORMATION) pairs where each EXPR will be replaced by the +transformation denoted by TRANSFORMATION." + (with-unique-names (transformer) + (let ((transformations-alist + (loop for (expr transformation) in transformations + collect `(,expr . (funcall (,transformation ,transformer) ,expr))))) + ;; note that we always use the name 'IMAGE' - no problem because + ;; this is a private macro + `(let ((,transformer (find image *transformers* :key #'image))) + (cond (,transformer + ,(sublis transformations-alist + `(progn , at body) + :test #'equal)) + (t (progn + , at body))))))) Added: trunk/cl-gd/util.lisp ============================================================================== --- (empty file) +++ trunk/cl-gd/util.lisp Wed Apr 30 04:38:52 2008 @@ -0,0 +1,136 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/util.lisp,v 1.15 2007/02/28 15:47:58 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +#+:lispworks +(import 'lw:with-unique-names) + +#-:lispworks +(defmacro with-unique-names ((&rest bindings) &body body) + "Syntax: WITH-UNIQUE-NAMES ( { var | (var x) }* ) declaration* form* + +Executes a series of forms with each VAR bound to a fresh, +uninterned symbol. The uninterned symbol is as if returned by a call +to GENSYM with the string denoted by X - or, if X is not supplied, the +string denoted by VAR - as argument. + +The variable bindings created are lexical unless special declarations +are specified. The scopes of the name bindings and declarations do not +include the Xs. + +The forms are evaluated in order, and the values of all but the last +are discarded \(that is, the body is an implicit PROGN)." + ;; reference implementation posted to comp.lang.lisp as + ;; by Vebjorn Ljosa - see also + ;; + `(let ,(mapcar #'(lambda (binding) + (check-type binding (or cons symbol)) + (if (consp binding) + (destructuring-bind (var x) binding + (check-type var symbol) + `(,var (gensym ,(etypecase x + (symbol (symbol-name x)) + (character (string x)) + (string x))))) + `(,binding (gensym ,(symbol-name binding))))) + bindings) + , at body)) + +#+:lispworks +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf (macro-function 'with-rebinding) + (macro-function 'lw:rebinding))) + +#-:lispworks +(defmacro with-rebinding (bindings &body body) + "REBINDING ( { var | (var prefix) }* ) form* + +Evaluates a series of forms in the lexical environment that is +formed by adding the binding of each VAR to a fresh, uninterned +symbol, and the binding of that fresh, uninterned symbol to VAR's +original value, i.e., its value in the current lexical environment. + +The uninterned symbol is created as if by a call to GENSYM with the +string denoted by PREFIX - or, if PREFIX is not supplied, the string +denoted by VAR - as argument. + +The forms are evaluated in order, and the values of all but the last +are discarded \(that is, the body is an implicit PROGN)." + ;; reference implementation posted to comp.lang.lisp as + ;; by Vebjorn Ljosa - see also + ;; + (loop for binding in bindings + for var = (if (consp binding) (car binding) binding) + for name = (gensym) + collect `(,name ,var) into renames + collect ``(,,var ,,name) into temps + finally (return `(let ,renames + (with-unique-names ,bindings + `(let (,, at temps) + ,, at body)))))) + +(defun sans (plist &rest keys) + "Returns PLIST with keyword arguments from KEYS removed." + ;; stolen from Usenet posting <3247672165664225 at naggum.no> by Erik + ;; Naggum + (let ((sans ())) + (loop + (let ((tail (nth-value 2 (get-properties plist keys)))) + ;; this is how it ends + (unless tail + (return (nreconc sans plist))) + ;; copy all the unmatched keys + (loop until (eq plist tail) do + (push (pop plist) sans) + (push (pop plist) sans)) + ;; skip the matched key + (setq plist (cddr plist)))))) + +(defun convert-to-char-references (string) + "Returns a string where all characters of STRING with CHAR-CODE +greater than 127 are converted to XML character entities." + (with-output-to-string (s) + (with-standard-io-syntax + (loop for char across string + for char-code = (char-code char) + when (<= char-code 127) do + (write-char char s) + else do + (write-char #\& s) + (write-char #\# s) + (princ char-code s) + (write-char #\; s))))) + +(defmacro with-safe-alloc ((var alloc free) &rest body) + `(let (,var) + (unwind-protect + (progn (setf ,var ,alloc) + , at body) + (when ,var ,free)))) \ No newline at end of file