Permalink
Browse files

noch ein versuch des upgrades. kann mal jemand dieses subversion wege…

…rfinden?

git-svn-id: svn://bknr.net/svn/trunk/thirdparty/cl-gd@1597 4281704c-cde7-0310-8518-8e2dc76b1ff0
  • Loading branch information...
1 parent e18d2e5 commit b530deb2989d4a381df539cd809b82728318602c @hanshuebner hanshuebner committed Mar 30, 2005
Showing with 0 additions and 10,812 deletions.
  1. +0 −58 CHANGELOG
  2. +0 −2 Makefile
  3. +0 −65 README
  4. +0 −185 cl-gd-glue.c
  5. +0 −45 cl-gd-test.asd
  6. +0 −490 cl-gd-test.lisp
  7. +0 −56 cl-gd.asd
  8. +0 −168 colors-aux.lisp
  9. +0 −247 colors.lisp
  10. BIN doc/anti-aliased-lines.png
  11. BIN doc/brushed-arc.png
  12. BIN doc/chart.png
  13. BIN doc/clipped-tangent.png
  14. BIN doc/demooutp.png
  15. +0 −169 doc/gddemo.c
  16. +0 −1,398 doc/index.html
  17. BIN doc/smallzappa.png
  18. BIN doc/strings.png
  19. BIN doc/triangle.png
  20. BIN doc/zappa-ellipse.png
  21. BIN doc/zappa-green.jpg
  22. BIN doc/zappa.jpg
  23. +0 −346 drawing.lisp
  24. +0 −729 gd-uffi.lisp
  25. +0 −58 gd/CHANGELOG
  26. +0 −65 gd/README
  27. +0 −185 gd/cl-gd-glue.c
  28. +0 −45 gd/cl-gd-test.asd
  29. +0 −490 gd/cl-gd-test.lisp
  30. +0 −56 gd/cl-gd.asd
  31. +0 −168 gd/colors-aux.lisp
  32. +0 −247 gd/colors.lisp
  33. BIN gd/doc/anti-aliased-lines.png
  34. BIN gd/doc/brushed-arc.png
  35. BIN gd/doc/chart.png
  36. BIN gd/doc/clipped-tangent.png
  37. BIN gd/doc/demooutp.png
  38. +0 −169 gd/doc/gddemo.c
  39. +0 −1,398 gd/doc/index.html
  40. BIN gd/doc/smallzappa.png
  41. BIN gd/doc/strings.png
  42. BIN gd/doc/triangle.png
  43. BIN gd/doc/zappa-ellipse.png
  44. BIN gd/doc/zappa-green.jpg
  45. BIN gd/doc/zappa.jpg
  46. +0 −346 gd/drawing.lisp
  47. +0 −729 gd/gd-uffi.lisp
  48. +0 −402 gd/images.lisp
  49. +0 −47 gd/init.lisp
  50. +0 −238 gd/misc.lisp
  51. +0 −79 gd/packages.lisp
  52. +0 −173 gd/specials.lisp
  53. +0 −193 gd/strings.lisp
  54. BIN gd/test/demoin.png
  55. BIN gd/test/orig/anti-aliased-lines.png
  56. BIN gd/test/orig/brushed-arc.png
  57. BIN gd/test/orig/chart.png
  58. BIN gd/test/orig/circle.png
  59. BIN gd/test/orig/clipped-tangent.png
  60. BIN gd/test/orig/one-line.jpg
  61. BIN gd/test/orig/one-line.png
  62. BIN gd/test/orig/one-pixel.jpg
  63. BIN gd/test/orig/one-pixel.png
  64. BIN gd/test/orig/triangle.png
  65. BIN gd/test/orig/zappa-ellipse.png
  66. BIN gd/test/orig/zappa-green.jpg
  67. BIN gd/test/smallzappa.png
  68. BIN gd/test/zappa.jpg
  69. +0 −192 gd/transform.lisp
  70. +0 −125 gd/util.lisp
  71. +0 −402 images.lisp
  72. +0 −47 init.lisp
  73. +0 −238 misc.lisp
  74. +0 −79 packages.lisp
  75. +0 −173 specials.lisp
  76. +0 −193 strings.lisp
  77. BIN test/demoin.png
  78. BIN test/orig/anti-aliased-lines.png
  79. BIN test/orig/brushed-arc.png
  80. BIN test/orig/chart.png
  81. BIN test/orig/circle.png
  82. BIN test/orig/clipped-tangent.png
  83. BIN test/orig/one-line.jpg
  84. BIN test/orig/one-line.png
  85. BIN test/orig/one-pixel.jpg
  86. BIN test/orig/one-pixel.png
  87. BIN test/orig/triangle.png
  88. BIN test/orig/zappa-ellipse.png
  89. BIN test/orig/zappa-green.jpg
  90. BIN test/smallzappa.png
  91. BIN test/zappa.jpg
  92. +0 −192 transform.lisp
  93. +0 −125 util.lisp
View
58 CHANGELOG
@@ -1,58 +0,0 @@
-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 <http://article.gmane.org/gmane.lisp.lispworks.general/1827>
-
-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
View
2 Makefile
@@ -1,2 +0,0 @@
-all:
- gcc -I/usr/local/include -L/usr/local/lib -fPIC -c cl-gd-glue.c
View
65 README
@@ -1,65 +0,0 @@
-Complete documentation for CL-GD can be found in the 'doc'
-directory. Make sure to read it if you want GIF support!
-
-CL-GD also supports Nikodemus Siivola's HYPERDOC, see
-<http://common-lisp.net/project/hyperdoc/> and
-<http://www.cliki.net/hyperdoc>.
-
-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
-
-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.)
View
185 cl-gd-glue.c
@@ -1,185 +0,0 @@
-/* Copyright (c) 2003-2005, 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 <errno.h>
-#include <stdio.h>
-#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;
-}
-
-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;
-}
-
-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);
-}
View
45 cl-gd-test.asd
@@ -1,45 +0,0 @@
-;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
-;;; $Header: /usr/local/cvsrep/gd/cl-gd-test.asd,v 1.7 2005/03/09 14:17:56 edi Exp $
-
-;;; Copyright (c) 2003-2005, 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
- :components ((:file "cl-gd-test"))
- :depends-on (:cl-gd))
-
View
490 cl-gd-test.lisp
@@ -1,490 +0,0 @@
-;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*-
-;;; $Header: /usr/local/cvsrep/gd/cl-gd-test.lisp,v 1.23 2005/03/09 14:17:56 edi Exp $
-
-;;; Copyright (c) 2003-2005, 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 :unspecific
- :version :unspecific
- :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)))
View
56 cl-gd.asd
@@ -1,56 +0,0 @@
-;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
-;;; $Header: /usr/local/cvsrep/gd/cl-gd.asd,v 1.7 2005/03/09 14:17:56 edi Exp $
-
-;;; Copyright (c) 2003-2005, 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
- :components ((:file "packages")
- (:file "util" :depends-on ("packages"))
- (:file "specials" :depends-on ("util"))
- (:file "init" :depends-on ("specials"))
- (:file "gd-uffi" :depends-on ("init"))
- (:file "transform" :depends-on ("gd-uffi"))
- (:file "images" :depends-on ("transform"))
- (:file "colors-aux" :depends-on ("transform"))
- (:file "colors" :depends-on ("transform"))
- (:file "drawing" :depends-on ("transform" "colors-aux"))
- (:file "strings" :depends-on ("transform" "colors-aux"))
- (:file "misc" :depends-on ("transform")))
- :depends-on (:uffi))
View
168 colors-aux.lisp
@@ -1,168 +0,0 @@
-;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*-
-;;; $Header: /usr/local/cvsrep/gd/colors-aux.lisp,v 1.10 2005/03/09 14:17:56 edi Exp $
-
-;;; Copyright (c) 2003-2005, 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))))
View
247 colors.lisp
@@ -1,247 +0,0 @@
-;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*-
-;;; $Header: /usr/local/cvsrep/gd/colors.lisp,v 1.22 2005/03/09 14:17:56 edi Exp $
-
-;;; Copyright (c) 2003-2005, 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))
- ,@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
- (rebinding (thickness image)
- `(let ((,old-thickness (thickness ,image)))
- (unwind-protect
- (progn
- (setf (thickness ,image) ,thickness))
- ,@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)))
View
BIN doc/anti-aliased-lines.png
Deleted file not rendered
View
BIN doc/brushed-arc.png
Deleted file not rendered
View
BIN doc/chart.png
Deleted file not rendered
View
BIN doc/clipped-tangent.png
Deleted file not rendered
View
BIN doc/demooutp.png
Deleted file not rendered
View
169 doc/gddemo.c
@@ -1,169 +0,0 @@
-
-#ifdef HAVE_CONFIG_H
-#include "config.h"
-#endif
-
-#include <stdio.h>
-#include <math.h>
-#include <stdlib.h>
-#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;
-}
View
1,398 doc/index.html
@@ -1,1398 +0,0 @@
-<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
-<html>
-
-<head>
- <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
- <title>CL-GD - Use the GD Graphics Library from Common Lisp</title>
- <style type="text/css">
- pre { padding:5px; background-color:#e0e0e0 }
- a.none { text-decoration: none; color:black }
- a.none:visited { text-decoration: none; color:black }
- a.none:active { text-decoration: none; color:black }
- a.none:hover { text-decoration: none; color:black }
- a { text-decoration: none; }
- a:visited { text-decoration: none; }
- a:active { text-decoration: underline; }
- a:hover { text-decoration: underline; }
- </style>
-</head>
-
-<body bgcolor=white>
-
-<h2>CL-GD - Use the GD Graphics Library from Common Lisp</h2>
-
-<blockquote>
-<br>&nbsp;<br><h3>Abstract</h3>
-
-CL-GD is a library for Common Lisp which provides an interface to the
-<a href="http://www.boutell.com/gd/">GD Graphics Library</a> for the
-dynamic creation of images. It is based on <a
-href="http://uffi.b9.com/">UFFI</a> and should thus be portable to all
-CL implementations supported by UFFI. (A version which also works with CLISP is available from <a href="http://ungil.com/cl-gd-clisp.tgz">http://ungil.com/cl-gd-clisp.tgz</a> thanks to Carlos Ungil.)
-<p>
-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, <a href="#mail">contact me</a> before you start coding in C... :)
-<p>
-CL-GD comes with a <a
-href="http://www.opensource.org/licenses/bsd-license.php">BSD-style
-license</a> so you can basically do with it whatever you want. Please send bug reports to <a href="#mail">the mailing list</a> 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.)
-<p>
-<font color=red>Download shortcut:</font> <a href="http://weitz.de/files/cl-gd.tar.gz">http://weitz.de/files/cl-gd.tar.gz</a>.
-</blockquote>
-
-<br>&nbsp;<br><h3><a href="#contents" name="example" class=none>A simple example</a></h3>
-
-The image to the right was created with this piece of code:
-
-<pre>
-<img alt="chart.png" title="chart.png" align=right border=0 vspace=10 hspace=10 width=200 height=200 src="chart.png">(<a href="#with-image*">with-image*</a> (200 200) <font color=orange>; create 200x200 pixel image</font>
- (<a href="#allocate-color">allocate-color</a> 68 70 85) <font color=orange>; background color</font>
- (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)))
- <font color=orange>;; move origin to center of image</font>
- (<a href="#with-transformation">with-transformation</a> (:x1 -100 :x2 100 :y1 -100 :y2 100 :radians t)
- <font color=orange>;; draw some 'pie slices'</font>
- (<a href="#draw-arc">draw-arc</a> 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)
- (<a href="#with-default-color">with-default-color</a> (white)
- (<a href="#with-default-font">with-default-font</a> (:small)
- (<a href="#draw-string">draw-string</a> -8 -30 &quot;60%&quot;)
- (draw-string -20 40 &quot;20%&quot;)
- (draw-string 20 30 &quot;15%&quot;))
- (<a href="#draw-freetype-string">draw-freetype-string</a> -90 75 &quot;Global Revenue&quot;
- <font color=orange>;; this assumes that 'DEFAULT_FONTPATH'</font>
- <font color=orange>;; is set correctly</font>
- :font-name &quot;verdanab&quot;))))
- (<a href="#write-image-to-file">write-image-to-file</a> &quot;chart.png&quot;
- :compression-level 6 :if-exists :supersede))
-</pre>
-
-<p>
-See below for more examples.
-
-<br>&nbsp;<br><h3><a class=none name="contents">Contents</a></h3>
-<ul>
- <li><a href="#example">A simple example</a>
- <li><a href="#install">Download and installation</a>
- <li><a href="#mail">Support and mailing lists</a>
- <li><a href="#images">Images</a>
- <ul>
- <li><a href="#create-image"><code>create-image</code></a>
- <li><a href="#create-image-from-file"><code>create-image-from-file</code></a>
- <li><a href="#create-image-from-gd2-part"><code>create-image-from-gd2-part</code></a>
- <li><a href="#destroy-image"><code>destroy-image</code></a>
- <li><a href="#with-image"><code>with-image</code></a>
- <li><a href="#with-image-from-file"><code>with-image-from-file</code></a>
- <li><a href="#with-image-from-gd2-part"><code>with-image-from-gd2-part</code></a>
- <li><a href="#default-image"><code>*default-image*</code></a>
- <li><a href="#with-default-image"><code>with-default-image</code></a>
- <li><a href="#with-image*"><code>with-image*</code></a>
- <li><a href="#with-image-from-file*"><code>with-image-from-file*</code></a>
- <li><a href="#with-image-from-gd2-part*"><code>with-image-from-gd2-part*</code></a>
- <li><a href="#write-jpeg-to-stream"><code>write-jpeg-to-stream</code></a>
- <li><a href="#write-png-to-stream"><code>write-png-to-stream</code></a>
- <li><a href="#write-wbmp-to-stream"><code>write-wbmp-to-stream</code></a>
- <li><a href="#write-gif-to-stream"><code>write-gif-to-stream</code></a>
- <li><a href="#write-gd-to-stream"><code>write-gd-to-stream</code></a>
- <li><a href="#write-gd2-to-stream"><code>write-gd2-to-stream</code></a>
- <li><a href="#write-image-to-stream"><code>write-image-to-stream</code></a>
- <li><a href="#write-image-to-file"><code>write-image-to-file</code></a>
- <li><a href="#image-width"><code>image-width</code></a>
- <li><a href="#image-height"><code>image-height</code></a>
- <li><a href="#image-size"><code>image-size</code></a>
- </ul>
- <li><a href="#colors">Colors</a>
- <ul>
- <li><a href="#default-color"><code>*default-color*</code></a>
- <li><a href="#with-default-color"><code>with-default-color</code></a>
- <li><a href="#allocate-color"><code>allocate-color</code></a>
- <li><a href="#find-color"><code>find-color</code></a>
- <li><a href="#find-color-from-image"><code>find-color-from-image</code></a>
- <li><a href="#color-component"><code>color-component</code></a>
- <li><a href="#color-components"><code>color-components</code></a>
- <li><a href="#deallocate-color"><code>deallocate-color</code></a>
- <li><a href="#true-color-p"><code>true-color-p</code></a>
- <li><a href="#number-of-colors"><code>number-of-colors</code></a>
- <li><a href="#max-colors"><code>+max-colors+</code></a>
- <li><a href="#transparent-color"><code>transparent-color</code></a>
- <li><a href="#alpha-blending-p"><code>alpha-blending-p</code></a>
- <li><a href="#save-alpha-p"><code>save-alpha-p</code></a>
- </ul>
- <li><a href="#colors">Styles, brushes, tiles, anti-aliased lines</a>
- <ul>
- <li><a href="#make-brush"><code>make-brush</code></a>
- <li><a href="#make-tile"><code>make-tile</code></a>
- <li><a href="#make-tile"><code>make-anti-aliased</code></a>
- </ul>
- <li><a href="#transformations">Transformations</a>
- <ul>
- <li><a href="#with-transformation"><code>with-transformation</code></a>
- <li><a href="#without-transformation"><code>without-transformation</code></a>
- </ul>
- <li><a href="#drawing">Drawing and filling</a>
- <ul>
- <li><a href="#set-pixel"><code>set-pixel</code></a>
- <li><a href="#set-pixels"><code>set-pixels</code></a>
- <li><a href="#draw-line"><code>draw-line</code></a>
- <li><a href="#draw-rectangle"><code>draw-rectangle</code></a>
- <li><a href="#draw-rectangle*"><code>draw-rectangle*</code></a>
- <li><a href="#draw-polygon"><code>draw-polygon</code></a>
- <li><a href="#draw-filled-circle"><code>draw-filled-circle</code></a>
- <li><a href="#draw-filled-ellipse"><code>draw-filled-ellipse</code></a>
- <li><a href="#draw-arc"><code>draw-arc</code></a>
- <li><a href="#fill-image"><code>fill-image</code></a>
- <li><a href="#clipping-rectangle"><code>clipping-rectangle</code></a>
- <li><a href="#clipping-rectangle*"><code>clipping-rectangle*</code></a>
- <li><a href="#set-clipping-rectangle*"><code>set-clipping-rectangle*</code></a>
- <li><a href="#with-clipping-rectangle"><code>with-clipping-rectangle</code></a>
- <li><a href="#with-clipping-rectangle*"><code>with-clipping-rectangle*</code></a>
- <li><a href="#current-thickness"><code>current-thickness</code></a>
- <li><a href="#with-thickness"><code>with-thickness</code></a>
- </ul>
- <li><a href="#strings">Strings and characters</a>
- <ul>
- <li><a href="#default-font"><code>*default-font*</code></a>
- <li><a href="#with-default-font"><code>with-default-font</code></a>
- <li><a href="#draw-character"><code>draw-character</code></a>
- <li><a href="#draw-string"><code>draw-string</code></a>
- <li><a href="#draw-freetype-string"><code>draw-freetype-string</code></a>
- </ul>
- <li><a href="#misc">Miscellaneous</a>
- <ul>
- <li><a href="#do-rows"><code>do-rows</code></a>
- <li><a href="#do-pixels-in-rows"><code>do-pixels-in-rows</code></a>
- <li><a href="#do-pixels"><code>do-pixels</code></a>
- <li><a href="#raw-pixel"><code>raw-pixel</code></a>
- <li><a href="#interlacedp"><code>interlacedp</code></a>
- <li><a href="#differentp"><code>differentp</code></a>
- <li><a href="#copy-image"><code>copy-image</code></a>
- <li><a href="#copy-palette"><code>copy-palette</code></a>
- <li><a href="#true-color-to-palette"><code>true-color-to-palette</code></a>
- </ul>
- <li><a href="#ack">Acknowledgements</a>
-</ul>
-
-<br>&nbsp;<br><h3><a href="#contents" name="install" class=none>Download and installation</a></h3>
-
-CL-GD together with this documentation can be downloaded from <a
-href="http://weitz.de/files/cl-gd.tar.gz">http://weitz.de/files/cl-gd.tar.gz</a>. The
-current version is 0.4.5. A <a href="http://packages.debian.org/cgi-bin/search_packages.pl?keywords=cl-gd&searchon=names&subword=1&version=all&release=all">Debian package</a> is available thanks to <a href="http://pvaneynd.mailworks.org/">Peter van Eynde</a> and <a href="http://b9.com/">Kevin Rosenberg</a>, so if you're on Debian you should have no problems installing CL-GD. There's also a port
-for <a href="http://www.cliki.net/gentoo">Gentoo Linux</a> thanks to Matthew Kennedy. Otherwise, proceed like this:
-<ul>
-<li>Download and install a recent version of <a href="http://www.cliki.net/asdf">asdf</a>.
-<li>Download and install <a href="http://uffi.b9.com/">UFFI</a>. CL-GD needs at least version&nbsp;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 <a href="http://uffi.b9.com/manual/with-cast-pointer.html"><code>WITH-CAST-POINTER</code></a> and <a href="http://uffi.b9.com/manual/def-foreign-var.html"><code>DEF-FOREIGN-VAR</code></a> which haven't yet been ported to all UFFI platforms.
-<li>Download and install a recent version of <a href="http://www.boutell.com/gd/">GD</a> and its supporting libraries <a href="http://www.libpng.org/pub/png/">libpng</a>, <a href="http://www.info-zip.org/pub/infozip/zlib/">zlib</a>, <a href="http://www.ijg.org/">libjpeg</a>, <a href="http://www.gnu.org/software/libiconv/">libiconv</a>, and <a href="http://www.freetype.org/">libfreetype</a>. 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 <em>all</em> supporting libraries. This is different from using GD directly from C where you only have to install the libraries you intend to use.
-<li>Download <a href="http://weitz.de/files/cl-gd.tar.gz"><code>cl-gd.tar.gz</code></a>, unzip and untar the file and put the resulting directory wherever you want, then cd into this directory.
-<li>Compile <code>cl-gd-glue.c</code> into a shared library for your platform. On Linux this would be
-<pre>
-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
-</pre>
-<li>Make sure that <code>cl-gd.asd</code> can be seen from asdf (this is usually achieved by a symbolic link), start your favorite Lisp, and compile CL-GD:
-<pre>
-(asdf:oos 'asdf:compile-op :cl-gd)
-</pre>
-<li>From now on you can simply load CL-GD into a running Lisp image with
-<pre>
-(asdf:oos 'asdf:load-op :cl-gd)
-</pre>
-<li>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
-<pre>
-(asdf:oos 'asdf:load-op :cl-gd-test)
-(cl-gd-test:test)
-</pre>
-If you have the <a
-href="http://corefonts.sourceforge.net/"><code>georgiab.ttf</code>
-TrueType font from Microsoft</a> you can also check the FreeType
-support of CL-GD with
-<pre>
-(cl-gd-test:test #p&quot;/usr/X11R6/lib/X11/fonts/truetype/georgiab.ttf&quot;)
-</pre>
-where you should obviously replace the path above with the pull path
-to the font on your machine. </ul>
-<p>
-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&nbsp;libraries which are
-used.
-<p>
-<b>It is recommended that you at least skim over the <a href="http://www.boutell.com/gd/manual2.0.33.html">original GD documentation</a> before you start using CL-GD.</b>
-<p>
-Note: If you're on Windows you might want to try this:
-<ul>
-<li>Download and install the supporting libraries (see above) from <a href="http://gnuwin32.sf.net/">GnuWin32</a> 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.
-<li>Download the file <code>cl-gd-glue.dll</code> from <a href="http://weitz.de/files/cl-gd-glue.dll">http://weitz.de/files/cl-gd-glue.dll</a> and put it into the CL-GD folder. You <em>don't</em> need to download and install GD itself because it's already integrated into <code>cl-gd-glue.dll</code>.
-<li>Start your Lisp and compile CL-GD as described above.
-</ul>
-This works for me on Windows&nbsp;XP&nbsp;pro&nbsp;SP2 with AllegroCL&nbsp;6.2&nbsp;trial as well as with LispWorks&nbsp;4.3.7&nbsp;pro.
-
-<br>&nbsp;<br><h3><a name="mail" class=none>Support and mailing lists</a></h3>
-
-For questions, bug reports, feature requests, improvements, or patches
-please use the <a
-href="http://common-lisp.net/mailman/listinfo/cl-gd-devel">cl-gd-devel
-mailing list</a>. If you want to be notified about future releases
-subscribe to the <a
-href="http://common-lisp.net/mailman/listinfo/cl-gd-announce">cl-gd-announce
-mailing list</a>. These mailing lists were made available thanks to
-the services of <a href="http://common-lisp.net/">common-lisp.net</a>.
-
-<br>&nbsp;<br><h3><a href="#contents" name="images" class=none>Images</a></h3>
-
-In order to work with CL-GD you first have to create at least one
-<em>image</em> - 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 <em>destroy</em> it to avoid memory leaks. It is recommended that
-you use the <code>WITH-IMAGE-</code> macros instead of the
-<code>CREATE-IMAGE-</code> functions so you can be sure that images
-will always be destroyed no matter what happens.
-
-<p><br>[Function]
-<br><a class=none name="create-image"><b>create-image</b> <i>width height <tt>&amp;optional</tt> true-color</i> =&gt; <i>image</i></a>
-
-<blockquote><br>
-Allocates and returns an image with size <code><i>width</i></code> <tt>x</tt> <code><i>height</i></code> (in pixels). Creates a true color image if
-<code><i>true-color</i></code> is true - the default is <code>NIL</code>. You are responsible for
-<a href="#destroy-image">destroying</a> the image after you're done with it. It is advisable to use
-<a href="#with-image"><code>WITH-IMAGE</code></a> instead.
-</blockquote>
-
-<p><br>[Function]
-<br><a class=none name="create-image-from-file"><b>create-image-from-file</b> <i>file-name <tt>&amp;optional</tt> type</i> =&gt; <i>image</i></a>
-
-<blockquote><br>
-Creates an image from the file specified by <code><i>file-name</i></code> (which is
-either a pathname or a string). The type of the image can be provided
-as <code><i>type</i></code> (one of the keywords <code>:JPG</code>, <code>:JPEG</code>, <code>:GIF</code>, <code>:PNG</code>, <code>:GD</code>, <code>:GD2</code>, <code>:XBM</code>, or <code>:XPM</code>), or otherwise it will be guessed from the <code>PATHNAME-TYPE</code> of
-<code><i>file-name</i></code>. You are responsible for <a href="#destroy-image">destroying</a> the image after you're
-done with it. It is advisable to use <a href="#with-image-from-file"><code>WITH-IMAGE-FROM-FILE</code></a> instead.
-</blockquote>
-
-<p><br>[Function]
-<br><a class=none name="create-image-from-gd2-part"><b>create-image-from-gd2-part</b> <i>file-name src-x src-y width height</i> =&gt; <i>image</i></a>
-
-<blockquote><br>
-Creates an image from the part of the GD2 file specified by <code><i>file-name</i></code> (which is
-either a pathname or a string) specified by <code><i>src-x</i></code>, <code><i>src-y</i></code>, <code><i>width</i></code>, and <code><i>height</i></code>. You are responsible for <a href="#destroy-image">destroying</a> the image after you're
-done with it. It is advisable to use <a href="#with-image-from-gd2-part"><code>WITH-IMAGE-FROM-GD2-PART</code></a> instead.
-</blockquote>
-
-<p><br>[Function]
-<br><a class=none name="destroy-image"><b>destroy-image</b> <i>image</i> =&gt; <i>result</i></a>
-
-<blockquote><br>
-Destroys (deallocates) <code><i>image</i></code> which has been created by <a href="#create-image"><code>CREATE-IMAGE</code></a>,
-<a href="#create-image-from-file"><code>CREATE-IMAGE-FROM-FILE</code></a>, or <a href="#create-image-from-gd2-part"><code>CREATE-IMAGE-FROM-GD2-PART</code></a>. <code><i>result</i></code> is always <code>NIL</code>.
-</blockquote>
-
-<p><br>[Macro]
-<br><a class=none name="with-image"><b>with-image</b> <i>(name width height <tt>&amp;optional</tt> true-color) form*</i> =&gt; <i>results</i></a>
-
-<blockquote><br>
-Creates an image as with <a
-href="#create-image"><code>CREATE-IMAGE</code></a> and executes
-<code><i>form*</i></code> with the image bound to
-<code><i>name</i></code>. The image is
-guaranteed to be <a href="#destroy-image">destroyed</a> before this macro exits.
-</blockquote>
-
-<p><br>[Macro]
-<br><a class=none name="with-image-from-file"><b>with-image-from-file</b> <i>(name file-name <tt>&amp;optional</tt> type) form*</i> =&gt; <i>results</i></a>
-
-<blockquote><br>
-Creates an image as with <a
-href="#create-image-from-file"><code>CREATE-IMAGE-FROM-FILE</code></a> and executes
-<code><i>form*</i></code> with the image bound to
-<code><i>name</i></code>. The image is
-guaranteed to be <a href="#destroy-image">destroyed</a> before this macro exits.
-</blockquote>
-
-<pre>
-(<a href="#with-image-from-file">with-image-from-file</a> (old &quot;zappa.jpg&quot;)<img vspace=10 hspace=10 border=0 alt="zappa-green.jpg" title="zappa-green.jpg" src="zappa-green.jpg" width=150 height=200 align=right><img vspace=10 hspace=10 border=0 alt="zappa.jpg" title="zappa.jpg" src="zappa.jpg" width=150 height=200 align=right>
- (multiple-value-bind (width height)
- (<a href="#image-size">image-size</a> old)
- (<a href="#with-image">with-image</a> (new width height)
- (<a href="#allocate-color">allocate-color</a> 0 255 0 :image new) <font color=orange>; green background</font>
- (<a href="#copy-image">copy-image</a> old new 0 0 0 0 width height
- :merge 50)
- (<a href="#write-image-to-file">write-image-to-file</a> &quot;zappa-green.jpg&quot;
- :image new
- :if-exists :supersede))))
-</pre>
-
-<p><br>[Macro]
-<br><a class=none name="with-image-from-gd2-part"><b>with-image-from-gd2-part</b> <i>(name file-name src-x src-y width height) form*</i> =&gt; <i>results</i></a>
-
-<blockquote><br>
-Creates an image as with <a
-href="#create-image-from-gd2-part"><code>CREATE-IMAGE-FROM-GD2-PART</code></a> and executes
-<code><i>form*</i></code> with the image bound to
-<code><i>name</i></code>. The image is
-guaranteed to be <a href="#destroy-image">destroyed</a> before this macro exits.
-</blockquote>
-
-<p><br>[Special variable]
-<br><a class=none name="default-image"><b>*default-image*</b></a>
-
-<blockquote><br>
-Whenever a CL-GD function or macro has an optional or keyword argument called <em>image</em> the default is to use <code><i>*default-image*</i></code>. 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 <a href="#example">example</a> at the top of the page.
-</blockquote>
-
-<p><br>[Macro]
-<br><a class=none name="with-default-image"><b>with-default-image</b> <i>(image) form*</i> =&gt; <i>results</i></a>
-
-<blockquote><br>
-This is just a convenience macro which will execute <code><i>form*</i></code> with <a href="#default-image"><code>*DEFAULT-IMAGE*</code></a> bound to <code><i>image</i></code>.
-</blockquote>
-
-
-<p><br>[Macro]
-<br><a class=none name="with-image*"><b>with-image*</b> <i>(width height <tt>&amp;optional</tt> true-color) form*</i> =&gt; <i>results</i></a>
-<p><br>[Macro]
-<br><a class=none name="with-image-from-file*"><b>with-image-from-file*</b> <i>(file-name <tt>&amp;optional</tt> type) form*</i> =&gt; <i>results</i></a>
-<p><br>[Macro]
-<br><a class=none name="with-image-from-gd2-part*"><b>with-image-from-gd2-part*</b> <i>(file-name src-x src-y width height) form*</i> =&gt; <i>results</i></a>
-
-<blockquote><br>
-These are essentially like their asterisk-less counterparts but bind the image to <a href="default-image"><code>*DEFAULT-IMAGE*</code></a> instead.
-</blockquote>
-
-
-<P>
-<b>For the rest of this document, whenever a function expects an image as
-one of its arguments you <em>must</em> pass a value which was created
-with one of the functions or macros above.</b> 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 <code>CL-GD::IMAGE</code> structure in order to enable
-type checking.)
-
-<p><br>[Function]
-<br><a class=none name="write-jpeg-to-stream"><b>write-jpeg-to-stream</b> <i>stream <tt>&amp;key</tt> quality image</i> =&gt; <i>image</i></a>
-
-<blockquote><br>
-Writes image <code><i>image</i></code> to the stream
-<code><i>stream</i></code> as a JPEG file. If
-<code><i>quality</i></code> is not specified, the default <a href"http://www.ijg.org/">IJG</a> JPEG
-quality value is used. Otherwise,
-<code><i>quality</i></code> must be an integer in the range&nbsp;0-100. <code><i>stream</i></code> must be a character stream or a binary
-stream of element type <code>(UNSIGNED-BYTE&nbsp;8)</code>. If STREAM is a character
-stream, the user of this function has to make sure the external format
-yields <a href="http://cl-cookbook.sf.net/io.html#faith">faithful output</a> of all 8-bit characters. CL-GD knows about AllegroCL's <a href="http://www.franz.com/support/documentation/6.2/doc/streams.htm">simple streams</a> and the bivalent streams of <a href="http://www.lispworks.com/">LispWorks</a>&nbsp;4.3 and acts accordingly, i.e. it uses <code>WRITE-BYTE</code> instead of <code>WRITE-CHAR</code> whenever possible.
-</blockquote>
-
-<p><br>[Function]
-<br><a class=none name="write-png-to-stream"><b>write-png-to-stream</b> <i>stream <tt>&amp;key</tt> compression-level image</i> =&gt; <i>image</i></a>
-
-<blockquote><br>
-Writes image <code><i>image</i></code> to the stream
-<code><i>stream</i></code> as a PNG file. If
-<code><i>compression-level</i></code> is not specified, the default compression level at
-the time zlib was compiled on your system will be used. Otherwise, a
-compression level of&nbsp;0 means 'no compression', a compression level of&nbsp;1 means 'compressed, but as quickly as possible', a compression level
-of&nbsp;9 means 'compressed as much as possible to produce the smallest
-possible file.' <code><i>stream</i></code> must be a character stream or a binary
-stream of element type <code>(UNSIGNED-BYTE&nbsp;8)</code>. If STREAM is a character
-stream, the user of this function has to make sure the external format
-yields <a href="http://cl-cookbook.sf.net/io.html#faith">faithful output</a> of all 8-bit characters. CL-GD knows about AllegroCL's <a href="http://www.franz.com/support/documentation/6.2/doc/streams.htm">simple streams</a> and the bivalent streams of <a href="http://www.lispworks.com/">LispWorks</a>&nbsp;4.3 and acts accordingly, i.e. it uses <code>WRITE-BYTE</code> instead of <code>WRITE-CHAR</code> whenever possible.
-</blockquote>
-
-<p><br>[Function]
-<br><a class=none name="write-wbmp-to-stream"><b>write-wbmp-to-stream</b> <i>stream <tt>&amp;key</tt> foreground image</i> =&gt; <i>image</i></a>
-
-<blockquote><br>
-Writes image <code><i>image</i></code> to the stream
-<code><i>stream</i></code> as a WBMP (wireless bitmap) file. WBMP file support is black and white
-only. The <a href="#colors">color</a> specified by the <code><i>foreground</i></code> argument is the
-&quot;foreground,&quot; and only pixels of this color will be set in the WBMP
-file. <code><i>stream</i></code> must be a character stream or a binary
-stream of element type <code>(UNSIGNED-BYTE&nbsp;8)</code>. If STREAM is a character
-stream, the user of this function has to make sure the external format
-yields <a href="http://cl-cookbook.sf.net/io.html#faith">faithful output</a> of all 8-bit characters. CL-GD knows about AllegroCL's <a href="http://www.franz.com/support/documentation/6.2/doc/streams.htm">simple streams</a> and the bivalent streams of <a href="http://www.lispworks.com/">LispWorks</a>&nbsp;4.3 and acts accordingly, i.e. it uses <code>WRITE-BYTE</code> instead of <code>WRITE-CHAR</code> whenever possible.
-</blockquote>
-
-<p><br>[Function]
-<br><a class=none name="write-gd-to-stream"><b>write-gd-to-stream</b> <i>stream <tt>&amp;key</tt> image</i> =&gt; <i>image</i></a>
-
-<blockquote><br>
-Writes image <code><i>image</i></code> to the stream
-<code><i>stream</i></code> as a GD file. <code><i>stream</i></code> must be a character stream or a binary
-stream of element type <code>(UNSIGNED-BYTE&nbsp;8)</code>. If STREAM is a character
-stream, the user of this function has to make sure the external format
-yields <a href="http://cl-cookbook.sf.net/io.html#faith">faithful output</a> of all 8-bit characters. CL-GD knows about AllegroCL's <a href="http://www.franz.com/support/documentation/6.2/doc/streams.htm">simple streams</a> and the bivalent streams of <a href="http://www.lispworks.com/">LispWorks</a>&nbsp;4.3 and acts accordingly, i.e. it uses <code>WRITE-BYTE</code> instead of <code>WRITE-CHAR</code> whenever possible.
-</blockquote>
-
-<p><br>[Function]
-<br><a class=none name="write-gif-to-stream"><b>write-gif-to-stream</b> <i>stream <tt>&amp;key</tt> image</i> =&gt; <i>image</i></a>
-
-<blockquote><br>
-Writes image <code><i>image</i></code> to the stream
-<code><i>stream</i></code> as a GIF file. <code><i>stream</i></code> must be a character stream or a binary
-stream of element type <code>(UNSIGNED-BYTE&nbsp;8)</code>. If STREAM is a character
-stream, the user of this function has to make sure the external format
-yields <a href="http://cl-cookbook.sf.net/io.html#faith">faithful output</a> of all 8-bit characters. CL-GD knows about AllegroCL's <a href="http://www.franz.com/support/documentation/6.2/doc/streams.htm">simple streams</a> and the bivalent streams of <a href="http://www.lispworks.com/">LispWorks</a>&nbsp;4.3 and acts accordingly, i.e. it uses <code>WRITE-BYTE</code> instead of <code>WRITE-CHAR</code> whenever possible.
-</blockquote>
-
-<p><br>[Function]
-<br><a class=none name="write-gd2-to-stream"><b>write-gd2-to-stream</b> <i>stream <tt>&amp;key</tt> image</i> =&gt; <i>image</i></a>
-
-<blockquote><br>
-Writes image <code><i>image</i></code> to the stream
-<code><i>stream</i></code> as a GD2 file. <code><i>stream</i></code> must be a character stream or a binary
-stream of element type <code>(UNSIGNED-BYTE&nbsp;8)</code>. If STREAM is a character
-stream, the user of this function has to make sure the external format
-yields <a href="http://cl-cookbook.sf.net/io.html#faith">faithful output</a> of all 8-bit characters. CL-GD knows about AllegroCL's <a href="http://www.franz.com/support/documentation/6.2/doc/streams.htm">simple streams</a> and the bivalent streams of <a href="http://www.lispworks.com/">LispWorks</a>&nbsp;4.3 and acts accordingly, i.e. it uses <code>WRITE-BYTE</code> instead of <code>WRITE-CHAR</code> whenever possible.
-</blockquote>
-
-<p><br>[Function]
-<br><a class=none name="write-image-to-stream"><b>write-image-to-stream</b> <i>stream type <tt>&amp;key</tt> <tt>&amp;allow-other-keys</tt></i> =&gt; <i>image</i></a>
-
-<blockquote><br>
-Writes image <code><i>image</i></code> to the stream
-<code><i>stream</i></code>. The type of the image is determined by <code><i>type</i></code>
-which must be one of the keywords <code>:JPG</code>, <code>:JPEG</code>, <code>:GIF</code>, <code>:PNG</code>, <code>:WBMP</code>, <code>:GD</code>, or <code>:GD2</code>. The rest of the keyword arguments are handed over to the corresponding <code>WRITE-<i>XXX</i>-TO-STREAM</code> function. <code><i>stream</i></code> must be a character stream or a binary
-stream of element type <code>(UNSIGNED-BYTE&nbsp;8)</code>. If STREAM is a character
-stream, the user of this function has to make sure the external format
-yields <a href="http://cl-cookbook.sf.net/io.html#faith">faithful output</a> of all 8-bit characters. CL-GD knows about AllegroCL's <a href="http://www.franz.com/support/documentation/6.2/doc/streams.htm">simple streams</a> and the bivalent streams of <a href="http://www.lispworks.com/">LispWorks</a>&nbsp;4.3 and acts accordingly, i.e. it uses <code>WRITE-BYTE</code> instead of <code>WRITE-CHAR</code> whenever possible.
-</blockquote>
-
-<p><br>[Function]
-<br><a class=none name="write-image-to-file"><b>write-image-to-file</b> <i>file-name type if-exists <tt>&amp;key</tt> <tt>&amp;allow-other-keys</tt></i> =&gt; <i>image</i></a>
-
-<blockquote><br>
-Writes image <code><i>image</i></code> to the file specified by <code><i>file-name</i></code> (which is
-either a pathname or a string). The <code><i>type</i></code> argument is interpreted as in <a href="#write-image-to-stream"><code>WRITE-IMAGE-TO-STREAM</code></a>. If it is not provided it will be guessed from the <code>PATHNAME-TYPE</code> of
-<code><i>file-name</i></code>. The <code><i>if-exists</i></code> keyword argument is given to <a href="http://www.lispworks.com/reference/HyperSpec/Body/f_open.htm"><code>OPEN</code></a>,
-the rest of the keyword arguments are handed over to the corresponding <code>WRITE-<i>XXX</i>-TO-STREAM</code> function.
-</blockquote>
-
-<p><br>[Function]
-<br><a class=none name="image-width"><b>image-width</b> <i><tt>&amp;optional</tt> image</i> =&gt; <i>width</i></a>
-
-<blockquote><br>
-Returns the width of the image <code><i>image</i></code>. The result of this function is affected by <a href="#with-transformation"><code>WITH-TRANSFORMATION</code></a>.
-</blockquote>
-
-<p><br>[Function]
-<br><a class=none name="image-height"><b>image-height</b> <i><tt>&amp;optional</tt> image</i> =&gt; <i>height</i></a>
-
-<blockquote><br>
-Returns the height of the image <code><i>image</i></code>. The result of this function is affected by <a href="#with-transformation"><code>WITH-TRANSFORMATION</code></a>.
-</blockquote>
-
-<p><br>[Function]
-<br><a class=none name="image-size"><b>image-size</b> <i><tt>&amp;optional</tt> image</i> =&gt; <i>width, height</i></a>
-
-<blockquote><br>
-Returns the width and height of the image <code><i>image</i></code> as two values. The results of this function are affected by <a href="#with-transformation"><code>WITH-TRANSFORMATION</code></a>.
-</blockquote>
-
-<br>&nbsp;<br><h3><a href="#contents" name="colors" class=none>Colors</a></h3>
-
-Images in CL-GD are usually palette-based (although true color images
-are also supported) and colors have to be <a
-href="#allocate-color">allocated</a> before they can be used, i.e. <b>whenever a function expects a color as
-one of its arguments you <em>must</em> pass a value which was created
-with one of the functions below or with a 'special' color as described in the <a href="#brushes">next section</a></b>.
-<p>
-Colors
-are determined by specifying values for their red, green, blue, and
-optionally alpha <a href="#color-component">components</a>. The first
-three have to be integer values in the range&nbsp;0-255 while the last
-one has to be in the range&nbsp;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.
-<p>
-See also the <a href="#styles">next section</a> for some 'special colors.'
-
-<p><br>[Special variable]
-<br><a class=none name="default-color"><b>*default-color*</b></a>
-
-<blockquote><br>
-Whenever a CL-GD function or macro has an optional or keyword argument called <em>color</em> the default is to use <code><i>*default-color*</i></code>. See <a href="#with-default-color"><code>WITH-DEFAULT-COLOR</code></a> below.
-</blockquote>
-
-<p><br>[Macro]
-<br><a class=none name="with-default-color"><b>with-default-color</b> <i>(color) form*</i> =&gt; <i>results</i></a>
-
-<blockquote><br>
-This is just a convenience macro which will execute <code><i>form*</i></code> with <a href="#default-color"><code>*DEFAULT-COLOR*</code></a> bound to <code><i>color</i></code>.
-</blockquote>
-
-<p><br>[Function]
-<br><a class=none name="allocate-color"><b>allocate-color</b> <i>red green blue <tt>&amp;key</tt> alpha errorp image</i> =&gt; <i>color</i></a>
-
-<blockquote><br>
-Finds the first available color index in the image <code><i>image</i></code> 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
-<code><i>alpha</i></code> (not greater than 127) is provided, an RGBA color will always
-be allocated. If all <a href="#max-colors"><code>+MAX-COLORS+</code></a> have already been allocated this
-function will, depending on the value of <code><i>errorp</i></code>, either raise an error
-or return <code>NIL</code>. The default is to raise an error.
-</blockquote>
-
-<p><br>[Function]
-<br><a class=none name="find-color"><b>find-color</b> <i>red green blue <tt>&amp;key</tt> alpha exact hwb resolve image</i> =&gt; <i>color</i></a>
-
-<blockquote><br>
-Tries to find and/or allocate a color from <code><i>image</i></code>'s color
-palette. If <code><i>exact</i></code> is <em>true</em>, the color will only be returned if it is
-already allocated. If <code><i>exact</i></code> is <em>false</em>, a color which is 'close' to
-the color specified by <code><i>red</i></code>, <code><i>green</i></code>, and <code><i>blue</i></code> (and probably <code><i>alpha</i></code>)
-might be returned (unless there aren't any colors allocated in the
-image yet). If <code><i>hwb</i></code> is <em>true</em>, the 'closeness' will be determined by hue,
-whiteness, and blackness, otherwise by the Euclidian distance of the
-RGB values. If <code><i>resolve</i></code> is <em>true</em> a color (probably a new one) will
-always be returned, otherwise the result of this function might be
-<code>NIL</code>. If <code><i>alpha</i></code> (not greater than 127) is provided, an RGBA color (or
-<code>NIL</code>) will be returned.
-<code><i>alpha</i></code>, <code><i>exact</i></code>, and <code><i>hwb</i></code> are mutually exclusive. <code><i>resolve</i></code> can't be used
-together with <code><i>exact</i></code> or <code><i>hwb</i></code>.
-</blockquote>
-
-<p><br>[Function]
-<br><a class=none name="find-color-from-image"><b>find-color-from-image</b> <i>color source-image <tt>&amp;key</tt> alpha exact hwb resolve image</i> =&gt; <i>color</i></a>
-
-<blockquote><br>
-Tries to find and/or allocate a color from <code><i>image</i></code>'s color
-palette that corresponds to <code><i>color</i></code> in <code><i>source-image</i></code>.
-<code><i>find-color-from-image</i></code> calls <a href="#find-color"><code><i>find-color</i></code></a>
-with the color components of <code><i>color</i></code>.
-Refer to <a href="#find-color"><code><i>find-color</i></code></a> for a description of the
-keyword arguments.
-</blockquote>
-