Permalink
Browse files

mal sehen *grusel*

git-svn-id: svn://bknr.net/svn/trunk/thirdparty/cl-gd@1595 4281704c-cde7-0310-8518-8e2dc76b1ff0
  • Loading branch information...
1 parent d5fc6d8 commit 78c64e043df38fa4d5652dd9c48b94e532b2ce8d @hanshuebner hanshuebner committed Mar 29, 2005
Showing with 5,471 additions and 233 deletions.
  1. +23 −1 CHANGELOG
  2. +0 −5 Makefile
  3. +2 −2 README
  4. +18 −1 cl-gd-glue.c
  5. +2 −2 cl-gd-test.asd
  6. +4 −3 cl-gd-test.lisp
  7. +2 −2 cl-gd.asd
  8. +17 −17 colors-aux.lisp
  9. +23 −14 colors.lisp
  10. +22 −41 doc/index.html
  11. +36 −44 drawing.lisp
  12. +3 −5 gd-uffi.lisp
  13. +58 −0 gd/CHANGELOG
  14. +65 −0 gd/README
  15. +1 −1 cl-gd-glue-gif.c → gd/cl-gd-glue.c
  16. +45 −0 gd/cl-gd-test.asd
  17. +490 −0 gd/cl-gd-test.lisp
  18. +56 −0 gd/cl-gd.asd
  19. +168 −0 gd/colors-aux.lisp
  20. +247 −0 gd/colors.lisp
  21. 0 {test → gd/doc}/anti-aliased-lines.png
  22. 0 {test → gd/doc}/brushed-arc.png
  23. BIN gd/doc/chart.png
  24. 0 {test → gd/doc}/clipped-tangent.png
  25. BIN gd/doc/demooutp.png
  26. +169 −0 gd/doc/gddemo.c
  27. +1,398 −0 gd/doc/index.html
  28. BIN gd/doc/smallzappa.png
  29. BIN gd/doc/strings.png
  30. 0 {test → gd/doc}/triangle.png
  31. 0 {test → gd/doc}/zappa-ellipse.png
  32. 0 {test → gd/doc}/zappa-green.jpg
  33. BIN gd/doc/zappa.jpg
  34. +346 −0 gd/drawing.lisp
  35. +729 −0 gd/gd-uffi.lisp
  36. +402 −0 gd/images.lisp
  37. +47 −0 gd/init.lisp
  38. +238 −0 gd/misc.lisp
  39. +79 −0 gd/packages.lisp
  40. +173 −0 gd/specials.lisp
  41. +193 −0 gd/strings.lisp
  42. BIN gd/test/demoin.png
  43. BIN gd/test/orig/anti-aliased-lines.png
  44. BIN gd/test/orig/brushed-arc.png
  45. 0 {test → gd/test/orig}/chart.png
  46. 0 {test → gd/test/orig}/circle.png
  47. BIN gd/test/orig/clipped-tangent.png
  48. BIN {test → gd/test/orig}/one-line.jpg
  49. BIN gd/test/orig/one-line.png
  50. 0 {test → gd/test/orig}/one-pixel.jpg
  51. 0 {test → gd/test/orig}/one-pixel.png
  52. BIN gd/test/orig/triangle.png
  53. BIN gd/test/orig/zappa-ellipse.png
  54. BIN gd/test/orig/zappa-green.jpg
  55. BIN gd/test/smallzappa.png
  56. BIN gd/test/zappa.jpg
  57. +192 −0 gd/transform.lisp
  58. +125 −0 gd/util.lisp
  59. +32 −28 images.lisp
  60. +2 −2 init.lisp
  61. +2 −2 misc.lisp
  62. +3 −3 packages.lisp
  63. +3 −4 specials.lisp
  64. +48 −48 strings.lisp
  65. BIN test/demooutp.png
  66. BIN test/one-line.png
  67. BIN test/orig/anti-aliased-lines.png
  68. BIN test/orig/clipped-tangent.png
  69. BIN test/orig/one-line.jpg
  70. BIN test/orig/one-line.png
  71. BIN test/orig/triangle.png
  72. BIN test/orig/zappa-ellipse.png
  73. +2 −2 transform.lisp
  74. +6 −6 util.lisp
View
24 CHANGELOG
@@ -1,6 +1,28 @@
+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 seperate C source files (with and without GIF support)
+Two separate C source files (with and without GIF support)
Added note about failed tests
Added hyperdoc support
Added :CL-GD to *FEATURES*
View
5 Makefile
@@ -1,5 +0,0 @@
-
-cl-gd-glue.so: cl-gd-glue-gif.c
- gcc -I/usr/local/include -fPIC -c cl-gd-glue-gif.c
- ld -L/usr/local/lib -lgd -lz -lpng -ljpeg -lfreetype -lm -shared cl-gd-glue-gif.o -o cl-gd-glue.so
-
View
4 README
@@ -5,7 +5,7 @@ CL-GD also supports Nikodemus Siivola's HYPERDOC, see
<http://common-lisp.net/project/hyperdoc/> and
<http://www.cliki.net/hyperdoc>.
-1. Installation
+1. Installation (see doc/index.html for Windows instructions)
1.1. Download and install a recent version of asdf.
@@ -18,7 +18,7 @@ CL-GD also supports Nikodemus Siivola's HYPERDOC, see
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 and developed with GD 2.0.15, older version probably won't
+ 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
View
19 cl-gd-glue.c
@@ -1,4 +1,4 @@
-/* Copyright (c) 2003, Dr. Edmund Weitz. All rights reserved.
+/* 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
@@ -45,6 +45,23 @@ gdImagePtr gdImageCreateFromJpegFile (char *filename, int *err) {
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;
View
4 cl-gd-test.asd
@@ -1,7 +1,7 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
-;;; $Header: /home/manuel/bknr-cvs/cvs/thirdparty/cl-gd/cl-gd-test.asd,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;; $Header: /usr/local/cvsrep/gd/cl-gd-test.asd,v 1.7 2005/03/09 14:17:56 edi Exp $
-;;; Copyright (c) 2003, Dr. Edmund Weitz. All rights reserved.
+;;; 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
View
7 cl-gd-test.lisp
@@ -1,7 +1,7 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*-
-;;; $Header: /home/manuel/bknr-cvs/cvs/thirdparty/cl-gd/cl-gd-test.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;; $Header: /usr/local/cvsrep/gd/cl-gd-test.lisp,v 1.23 2005/03/09 14:17:56 edi Exp $
-;;; Copyright (c) 2003, Dr. Edmund Weitz. All rights reserved.
+;;; 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
@@ -251,7 +251,8 @@
orange orange orange))
(write-image-to-file file
:compression-level 8
- :if-exists :supersede))))))
+ :if-exists :supersede))))
+ (compare-files file)))
(defun test-013 ()
(let ((file (test-file-location "brushed-arc" "png")))
View
4 cl-gd.asd
@@ -1,7 +1,7 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
-;;; $Header: /home/manuel/bknr-cvs/cvs/thirdparty/cl-gd/cl-gd.asd,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;; $Header: /usr/local/cvsrep/gd/cl-gd.asd,v 1.7 2005/03/09 14:17:56 edi Exp $
-;;; Copyright (c) 2003, Dr. Edmund Weitz. All rights reserved.
+;;; 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
View
34 colors-aux.lisp
@@ -1,7 +1,7 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*-
-;;; $Header: /home/manuel/bknr-cvs/cvs/thirdparty/cl-gd/colors-aux.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;; $Header: /usr/local/cvsrep/gd/colors-aux.lisp,v 1.10 2005/03/09 14:17:56 edi Exp $
-;;; Copyright (c) 2003, Dr. Edmund Weitz. All rights reserved.
+;;; 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
@@ -97,29 +97,29 @@ either a color or NIL \(for transparent pixels)."))
(check-type image image)
(let ((length (length style)))
(with-safe-alloc (c-style (allocate-foreign-object :int length)
- (free-foreign-object c-style))
+ (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))))
+ 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))
+ (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))))
+ 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)))
@@ -154,7 +154,7 @@ argument for GD, modifying internal slots of IMAGE if needed."
image)
+anti-aliased+)
((or vector list)
- (setf (current-style image) (cdr color))
+ (setf (current-style image) color)
+styled+)
(integer
color)))
View
37 colors.lisp
@@ -1,7 +1,7 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*-
-;;; $Header: /home/manuel/bknr-cvs/cvs/thirdparty/cl-gd/colors.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;; $Header: /usr/local/cvsrep/gd/colors.lisp,v 1.22 2005/03/09 14:17:56 edi Exp $
-;;; Copyright (c) 2003, Dr. Edmund Weitz. All rights reserved.
+;;; 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
@@ -221,18 +221,27 @@ one of :RED, :GREEN, :BLUE, and :ALPHA."
color))
(defun color-components (color &key (image *default-image*))
- "Returns the color components of COLOR as a list. The components are in the
-order red, green, blue, alpha."
+ "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)))
+ '(: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)))
+ 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
63 doc/index.html
@@ -28,13 +28,15 @@
<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.
+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>
@@ -76,14 +78,6 @@
<p>
See below for more examples.
-<p>
-Note: If you can't see this and the following examples your browser
-can't display PNG pictures. I'm sorry but there's not much I can do
-about this. GD (and thus CL-GD) can't create GIF images due to <a
-href="http://www.boutell.com/gd/faq.html">the Unisys LZW
-patent</a>. And for most examples it wouldn't make much sense to use
-JPEGs instead. (Update: But see the <a href="#gif">note below</a> about
-GIF support.)
<br>&nbsp;<br><h3><a class=none name="contents">Contents</a></h3>
<ul>
@@ -123,15 +117,15 @@
<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>
- <li><a href="#color-component"><code>color-component</code></a>
- <li><a href="#color-components"><code>color-components</code></a>
</ul>
<li><a href="#colors">Styles, brushes, tiles, anti-aliased lines</a>
<ul>
@@ -190,14 +184,14 @@
<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.tgz">http://weitz.de/files/cl-gd.tgz</a>. The
-current version is 0.3.1. 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://b9.com/">Kevin Rosenberg</a>, so if you're on Debian you should have no problems installing CL-GD. There's also a port
+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.15, 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.tgz"><code>cl-gd.tgz</code></a>, unzip and untar the file and put the resulting directory wherever you want, then cd into this directory.
+<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
@@ -234,22 +228,15 @@
tests seem to depend on the versions of the C&nbsp;libraries which are
used.
<p>
-<a name="gif" class=none>Note about GIF support:</a> The original GD library doesn't support the <a
-href="http://burnallgifs.org/">GIF file format</a> due to the <a
-href="http://www.unisys.com/about__unisys/lzw">patent</a> Unisys holds
-on the LZW compression algorithm. However, some distributions (notably
-the FreeBSD port for non-US users) do include the ability to read and write GIF
-files. Hans Hübner has patched CL-GD to use this ability. If you want
-GIF support first make sure that you have a corresponding version of
-GD installed and then
-<pre>
-(push :cl-gd-gif *features*)
-</pre>
-<em>before</em> you compile and load CL-GD. Also, compile <code>cl-gd-glue-gif.c</code> instead of <code>cl-gd-glue.c</code>.
-<p>
-Note to Windows users: I've heard that it's possible to compile and use GD with <a href="http://www.cygwin.com/">Cygwin</a>. I haven't tried it myself but if you succeed in using CL-GD on Windows it'd be nice if you could send some notes so I can add them to this document. Thanks. Addendum: Jeff Caldwell notes that <a href="http://mapserver.gis.umn.edu/doc35/mapserver-cygwin-howto.html">this website</a> has good explanations about how to install GD and its supporting libraries.
+<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>
-<b>It is recommended that you at least skim over the <a href="http://www.boutell.com/gd/manual2.0.15.html">original GD documentation</a> before you start using CL-GD.</b>
+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>
@@ -290,11 +277,9 @@
<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>: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
+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.
-<p>
-If you have built CL-GD <a href="#gif">with GIF support</a> <code><i>type</i></code> can also be <code>:GIF</code>.
</blockquote>
<p><br>[Function]
@@ -460,8 +445,6 @@
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.
-<p>
-This function is only available if you've managed to build CL-GD <a href="#gif">with GIF support</a>.
</blockquote>
<p><br>[Function]
@@ -481,12 +464,10 @@
<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>: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
+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.
-<p>
-If you have built CL-GD <a href="#gif">with GIF support</a> <code><i>type</i></code> can also be <code>:GIF</code>.
</blockquote>
<p><br>[Function]
@@ -1069,7 +1050,7 @@
<br><i>(setf (<b>current-thickness</b> <i><tt>&amp;optional</tt> image</i>) thickness)</i></a>
<blockquote><br>
-Get and sets the current <em>thickness</em> of <code><i>image</i></code> in pixels. This determines the width of lines drawn with the <a href="#drawing">drawing</a> functions. <code><i>thickness</i></code> has to be an integer. See also <a href="with-thickness"><code>WITH-THICKNESS</code></a>.
+Get and sets the current <em>thickness</em> of <code><i>image</i></code> in pixels. This determines the width of lines drawn with the <a href="#drawing">drawing</a> functions. <code><i>thickness</i></code> has to be an integer. See also <a href="#with-thickness"><code>WITH-THICKNESS</code></a>.
</blockquote>
<p><br>[Macro]
@@ -1408,9 +1389,9 @@
for <a href="http://uffi.b9.com/">UFFI</a> 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 <a href="http://huebner.org/">Hans
-H&uuml;bner</a> for the GIF patches.
+H&uuml;bner</a> for the GIF patches. Thanks to <a href='http://bl0rg.net/'>Manuel Odendahl</a> for lots of useful patches.
<p>
-$Header: /home/manuel/bknr-cvs/cvs/thirdparty/cl-gd/doc/index.html,v 1.1 2004/06/23 08:27:10 hans Exp $
+$Header: /usr/local/cvsrep/gd/doc/index.html,v 1.48 2005/03/16 15:31:40 edi Exp $
<p><a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a>
</body>
View
80 drawing.lisp
@@ -1,7 +1,7 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*-
-;;; $Header: /home/manuel/bknr-cvs/cvs/thirdparty/cl-gd/drawing.lisp,v 1.2 2004/09/29 17:59:00 david Exp $
+;;; $Header: /usr/local/cvsrep/gd/drawing.lisp,v 1.24 2005/03/09 14:17:56 edi Exp $
-;;; Copyright (c) 2003, Dr. Edmund Weitz. All rights reserved.
+;;; 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
@@ -29,14 +29,6 @@
(in-package :cl-gd)
-(defun get-pixel (x y &key (image *default-image*))
- "Return the color of the pixel at 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)
@@ -143,22 +135,22 @@ only the corresponding part of VERTICES is used as input."))
(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))
+ (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)))))
+ (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)
@@ -169,26 +161,26 @@ only the corresponding part of VERTICES is used as input."))
(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))
+ (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)))))
+ (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
View
8 gd-uffi.lisp
@@ -1,7 +1,7 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*-
-;;; $Header: /home/manuel/bknr-cvs/cvs/thirdparty/cl-gd/gd-uffi.lisp,v 1.1 2004/06/23 08:27:10 hans Exp $
+;;; $Header: /usr/local/cvsrep/gd/gd-uffi.lisp,v 1.27 2005/03/09 14:17:56 edi Exp $
-;;; Copyright (c) 2003, Dr. Edmund Weitz. All rights reserved.
+;;; 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
@@ -64,7 +64,7 @@
(aal-x1 :int)
(aal-y1 :int)
(aal-x2 :int)
- (aal-y1 :int)
+ (aal-y2 :int)
(aal-bx-ax :int)
(aal-by-ay :int)
(aal-lab-2 :int)
@@ -180,7 +180,6 @@
:returning gd-image-ptr
:module "gd")
-#+:cl-gd-gif
(def-function ("gdImageCreateFromGifFile" gd-image-create-from-gif-file)
((filename :cstring)
(err (* :int)))
@@ -226,7 +225,6 @@
:returning :pointer-void
:module "gd")
-#+:cl-gd-gif
(def-function ("gdImageGifPtr" gd-image-gif-ptr)
((im gd-image-ptr)
(size (* :int)))
View
58 gd/CHANGELOG
@@ -0,0 +1,58 @@
+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
65 gd/README
@@ -0,0 +1,65 @@
+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
2 cl-gd-glue-gif.c → gd/cl-gd-glue.c
@@ -1,4 +1,4 @@
-/* Copyright (c) 2003, Dr. Edmund Weitz. All rights reserved.
+/* 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
View
45 gd/cl-gd-test.asd
@@ -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.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 gd/cl-gd-test.lisp
@@ -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.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 gd/cl-gd.asd
@@ -0,0 +1,56 @@
+;;; -*- 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 gd/colors-aux.lisp
@@ -0,0 +1,168 @@
+;;; -*- 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 gd/colors.lisp
@@ -0,0 +1,247 @@
+;;; -*- 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
0 test/anti-aliased-lines.png → gd/doc/anti-aliased-lines.png
File renamed without changes
View
0 test/brushed-arc.png → gd/doc/brushed-arc.png
File renamed without changes
View
BIN gd/doc/chart.png
Sorry, something went wrong. Reload?
Sorry, we cannot display this file.
Sorry, this file is invalid so it cannot be displayed.
View
0 test/clipped-tangent.png → gd/doc/clipped-tangent.png
File renamed without changes
View
BIN gd/doc/demooutp.png
Sorry, something went wrong. Reload?
Sorry, we cannot display this file.
Sorry, this file is invalid so it cannot be displayed.
View
169 gd/doc/gddemo.c
@@ -0,0 +1,169 @@
+
+#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 gd/doc/index.html
@@ -0,0 +1,1398 @@
+<!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="#d