/[cl-gd]/cl-gd/cl-gd-test.lisp
ViewVC logotype

Contents of /cl-gd/cl-gd-test.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Sun Apr 25 20:34:01 2004 UTC (10 years ago) by eweitz
Branch: MAIN
CVS Tags: HEAD
Changes since 1.2: +2 -2 lines
pre-0.3.2 with bugfix for LW bivalent streams
1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*-
2 ;;; $Header: /tiger/var/lib/cvsroots/cl-gd/cl-gd/cl-gd-test.lisp,v 1.3 2004/04/25 20:34:01 eweitz Exp $
3
4 ;;; Copyright (c) 2003, Dr. Edmund Weitz. All rights reserved.
5
6 ;;; Redistribution and use in source and binary forms, with or without
7 ;;; modification, are permitted provided that the following conditions
8 ;;; are met:
9
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
12
13 ;;; * Redistributions in binary form must reproduce the above
14 ;;; copyright notice, this list of conditions and the following
15 ;;; disclaimer in the documentation and/or other materials
16 ;;; provided with the distribution.
17
18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29
30 (in-package :cl-user)
31
32 (defpackage #:cl-gd-test
33 (:use #:cl
34 #:cl-gd)
35 (:export #:test))
36
37 (in-package :cl-gd-test)
38
39 (defparameter *test-directory*
40 (merge-pathnames (make-pathname :directory '(:relative "test"))
41 (make-pathname :name nil
42 :type :unspecific
43 :version :unspecific
44 :defaults cl-gd.system:*cl-gd-directory*))
45
46 "Where test files are put.")
47
48 (defun test-file-location (name &optional (type :unspecific))
49 "Create test file location from NAME and TYPE component."
50 (make-pathname :name name
51 :type type
52 :defaults *test-directory*))
53
54 (defun compare-files (file &key type expected-result)
55 "Compare test file FILE to orginal file in subdirectory ORIG."
56 (with-image-from-file (image file)
57 (with-image-from-file (orig (merge-pathnames
58 (make-pathname :type
59 (or type (pathname-type file))
60 :directory
61 '(:relative "orig"))
62 file))
63 (equal (differentp image orig)
64 expected-result))))
65
66 (defun test-001 ()
67 (let ((file (test-file-location "one-pixel" "png")))
68 ;; 40x40 image
69 (with-image* (40 40)
70 ;; white background
71 (allocate-color 255 255 255)
72 ;; black pixel in the middle
73 (set-pixel 20 20 :color (allocate-color 0 0 0))
74 ;; write to PNG target
75 (write-image-to-file file :if-exists :supersede))
76 ;; compare to existing file
77 (compare-files file)))
78
79 (defun test-002 ()
80 (let ((file (test-file-location "one-pixel" "jpg")))
81 ;; 40x40 image
82 (with-image* (40 40)
83 ;; white background
84 (allocate-color 255 255 255)
85 ;; black pixel in the middle
86 (set-pixel 20 20 :color (allocate-color 0 0 0))
87 ;; write to JPEG target
88 (write-image-to-file file :if-exists :supersede))
89 ;; compare to existing file
90 (compare-files file)))
91
92 (defun test-003 ()
93 (let ((file (test-file-location "one-line" "png")))
94 ;; 40x40 image
95 (with-image* (40 40)
96 ;; white background
97 (allocate-color 255 255 255)
98 ;; anti-aliased black line
99 (draw-line 20 20 30 30
100 :color (make-anti-aliased
101 (allocate-color 0 0 0)))
102 ;; write to PNG target
103 (write-image-to-file file :if-exists :supersede))
104 ;; compare to existing file
105 (compare-files file)))
106
107 (defun test-004 ()
108 (let ((file (test-file-location "one-line" "jpg")))
109 ;; 40x40 image
110 (with-image* (40 40)
111 ;; white background
112 (allocate-color 255 255 255)
113 ;; anti-aliased black line
114 (draw-line 20 20 30 30
115 :color (make-anti-aliased
116 (allocate-color 0 0 0)))
117 ;; write to JPEG target
118 (write-image-to-file file :if-exists :supersede))
119 ;; compare to existing PNG file
120 (compare-files file)))
121
122 (defun test-005 ()
123 (with-image-from-file* ((test-file-location "one-pixel" "png"))
124 (let ((num (number-of-colors)))
125 (find-color 255 255 255 :resolve t)
126 (multiple-value-bind (width height)
127 (image-size)
128 (and (= width 40)
129 (= height 40)
130 ;; FIND-COLOR should not have changed the number of
131 ;; colors
132 (= num (number-of-colors)))))))
133
134 (defun test-006 ()
135 (with-image-from-file* ((test-file-location "one-pixel" "png"))
136 (with-transformation (:x1 0.1 :x2 0.5 :y1 10.8 :y2 20.9)
137 (multiple-value-bind (width height)
138 (image-size)
139 ;; make sure WITH-TRANSFORMATION returns transformed size
140 (and (>= 0.0001 (abs (- 0.4 width)))
141 (>= 0.0001 (abs (- 10.1 height))))))))
142
143 (defun test-007 ()
144 (let ((file (test-file-location "circle" "png")))
145 (with-image* (40 40)
146 (allocate-color 255 255 255)
147 (let ((black (allocate-color 0 0 0)))
148 (with-default-color (black)
149 ;; move origin to center and stretch
150 (with-transformation (:x1 -100 :width 200 :y1 -100 :height 200)
151 (draw-filled-circle 0 0 50)
152 (write-image-to-file file
153 :if-exists :supersede)))))
154 (compare-files file)))
155
156 (defun test-008 ()
157 (with-image (image 40 40)
158 (allocate-color 255 255 255 :image image)
159 (with-default-color ((allocate-color 0 0 0 :image image))
160 ;; no transformation and use more general ellipse function
161 (draw-filled-ellipse 20 20 20 20 :image image)
162 (with-image-from-file (other-image
163 (test-file-location "circle" "png"))
164 (not (differentp image other-image))))))
165
166 (defun test-009 ()
167 (let ((file (test-file-location "chart" "png")))
168 ;; create 200x200 pixel image
169 (with-image* (200 200)
170 ;; background color
171 (allocate-color 68 70 85)
172 (let ((beige (allocate-color 222 200 81))
173 (brown (allocate-color 206 150 75))
174 (green (allocate-color 104 156 84))
175 (red (allocate-color 163 83 84))
176 (white (allocate-color 255 255 255))
177 (two-pi (* 2 pi)))
178 ;; move origin to center of image
179 (with-transformation (:x1 -100 :x2 100 :y1 -100 :y2 100 :radians t)
180 ;; draw some 'pie slices'
181 (draw-arc 0 0 130 130 0 (* .6 two-pi)
182 :center-connect t :filled t :color beige)
183 (draw-arc 0 0 130 130 (* .6 two-pi) (* .8 two-pi)
184 :center-connect t :filled t :color brown)
185 (draw-arc 0 0 130 130 (* .8 two-pi) (* .95 two-pi)
186 :center-connect t :filled t :color green)
187 (draw-arc 0 0 130 130 (* .95 two-pi) two-pi
188 :center-connect t :filled t :color red)
189 ;; use GD fonts
190 (with-default-color (white)
191 (with-default-font (:small)
192 (draw-string -8 -30 "60%")
193 (draw-string -20 40 "20%")
194 (draw-string 20 30 "15%"))
195 (draw-string -90 90 "Global Revenue"
196 :font :large))
197 (write-image-to-file file
198 :compression-level 6
199 :if-exists :supersede))))
200 (compare-files file)))
201
202 (defun test-010 ()
203 (let ((file (test-file-location "zappa-green" "jpg")))
204 ;; get JPEG from disk
205 (with-image-from-file (old (test-file-location "zappa" "jpg"))
206 (multiple-value-bind (width height)
207 (image-size old)
208 (with-image (new width height)
209 ;; green color for background
210 (allocate-color 0 255 0 :image new)
211 ;; merge with original JPEG
212 (copy-image old new 0 0 0 0 width height
213 :merge 50)
214 (write-image-to-file file
215 :image new
216 :if-exists :supersede))))
217 (compare-files file)))
218
219 (defun test-011 ()
220 ;; small image
221 (with-image* (10 10)
222 (loop for i below +max-colors+ do
223 ;; allocate enough colors (all gray) to fill the palette
224 (allocate-color i i i))
225 (and (= +max-colors+ (number-of-colors))
226 (null (find-color 255 0 0 :exact t))
227 (let ((match (find-color 255 0 0))) ; green
228 (and (= 85
229 (color-component :red match)
230 (color-component :green match)
231 (color-component :blue match)))))))
232
233 (defun test-012 ()
234 (let ((file (test-file-location "triangle" "png")))
235 (with-image* (100 100)
236 (allocate-color 255 255 255) ; white background
237 (let ((red (allocate-color 255 0 0))
238 (yellow (allocate-color 255 255 0))
239 (orange (allocate-color 255 165 0)))
240 ;; thin black border
241 (draw-rectangle* 0 0 99 99
242 :color (allocate-color 0 0 0))
243 ;; lines are five pixels thick
244 (with-thickness (5)
245 ;; colored triangle
246 (draw-polygon (list 10 10 90 50 50 90)
247 ;; styled color
248 :color (list red red red
249 yellow yellow yellow
250 nil nil nil
251 orange orange orange))
252 (write-image-to-file file
253 :compression-level 8
254 :if-exists :supersede))))))
255
256 (defun test-013 ()
257 (let ((file (test-file-location "brushed-arc" "png")))
258 (with-image* (200 100)
259 (allocate-color 255 165 0) ; orange background
260 (with-image (brush 6 6)
261 (let* ((black (allocate-color 0 0 0 :image brush)) ; black background
262 (red (allocate-color 255 0 0 :image brush))
263 (blue (allocate-color 0 0 255 :image brush)))
264 (setf (transparent-color brush) black) ; make background transparent
265 ;; now set the pixels in the brush
266 (set-pixels '(2 2 2 3 3 2 3 3)
267 :color blue :image brush)
268 (set-pixels '(1 2 1 3 4 2 4 3 2 1 3 1 2 4 3 4)
269 :color red :image brush)
270 ;; then use it to draw an arc
271 (draw-arc 100 50 180 80 180 300 :color (make-brush brush)))
272 (write-image-to-file file
273 :compression-level 7
274 :if-exists :supersede)))
275 (compare-files file)))
276
277 (defun test-014 ()
278 (let ((file (test-file-location "anti-aliased-lines" "png")))
279 (with-image* (150 50)
280 (let ((orange (allocate-color 255 165 0)) ; orange background
281 (white (allocate-color 255 255 255))
282 (red (allocate-color 255 0 0)))
283 ;; white background rectangle in the middle third
284 (draw-rectangle* 50 0 99 49
285 :filled t
286 :color white)
287 (with-thickness (2)
288 ;; just a red line
289 (draw-line 5 10 145 10 :color red)
290 ;; anti-aliased red line
291 (draw-line 5 25 145 25 :color (make-anti-aliased red))
292 ;; anti-aliased red line which should stand out against
293 ;; orange background
294 (draw-line 5 40 145 40 :color (make-anti-aliased red orange))))
295 (write-image-to-file file
296 :compression-level 3
297 :if-exists :supersede))
298 (compare-files file)))
299
300 (defun test-015 ()
301 (let ((file (test-file-location "clipped-tangent" "png")))
302 (with-image* (150 150)
303 (allocate-color 255 255 255) ; white background
304 ;; transform such that x axis ranges from (- PI) to PI and y
305 ;; axis ranges from -3 to 3
306 (with-transformation (:x1 (- pi) :width (* 2 pi) :y1 -3 :y2 3)
307 (let ((black (allocate-color 0 0 0))
308 (red (allocate-color 255 0 0))
309 (rectangle (list (- .4 pi) 2.5 (- pi .4) -2.5)))
310 (with-default-color (black)
311 ;; draw axes
312 (draw-line 0 -3 0 3 :color black)
313 (draw-line (- pi) 0 pi 0))
314 ;; show clipping rectangle (styled)
315 (draw-rectangle rectangle :color (list black black black nil black nil))
316 (with-clipping-rectangle (rectangle)
317 ;; draw tangent function
318 (loop for x from (- pi) below (* 2 pi) by (/ pi 75) do
319 (set-pixel x (tan x) :color red)))))
320 (write-image-to-file file
321 :if-exists :supersede))
322 (compare-files file)))
323
324 (defun gd-demo-picture (file random-state &optional write-file)
325 (with-image* ((+ 256 384) 384 t)
326 (let ((white (allocate-color 255 255 255))
327 (red (allocate-color 255 0 0))
328 (green (allocate-color 0 255 0))
329 (blue (allocate-color 0 0 255))
330 (vertices (list 64 0 0 128 128 128))
331 (image-width (image-width))
332 (image-height (image-height)))
333 (setf (transparent-color) white)
334 (draw-rectangle* 0 0 image-width image-height :color white)
335 (with-image-from-file (in-file (test-file-location "demoin" "png"))
336 (copy-image in-file *default-image*
337 0 0 32 32 192 192
338 :resize t
339 :dest-width 255
340 :dest-height 255
341 :resample t)
342 (multiple-value-bind (in-width in-height)
343 (image-size in-file)
344 (loop for a below 360 by 45 do
345 (copy-image in-file *default-image*
346 0 0
347 (+ 256 192 (* 128 (cos (* a .0174532925))))
348 (- 192 (* 128 (sin (* a .0174532925))))
349 in-width in-height
350 :rotate t
351 :angle a))
352 (with-default-color (green)
353 (with-thickness (4)
354 (draw-line 16 16 240 16)
355 (draw-line 240 16 240 240)
356 (draw-line 240 240 16 240)
357 (draw-line 16 240 16 16))
358 (draw-polygon vertices :filled t))
359 (dotimes (i 3)
360 (incf (nth (* 2 i) vertices) 128))
361 (draw-polygon vertices
362 :color (make-anti-aliased green)
363 :filled t)
364 (with-default-color (blue)
365 (draw-arc 128 128 60 20 0 720)
366 (draw-arc 128 128 40 40 90 270)
367 (fill-image 8 8))
368 (with-image (brush 16 16 t)
369 (copy-image in-file brush
370 0 0 0 0
371 in-width in-height
372 :resize t
373 :dest-width (image-width brush)
374 :dest-height (image-height brush))
375 (draw-line 0 255 255 0
376 :color (cons (make-brush brush)
377 (list nil nil nil nil nil nil nil t))))))
378 (with-default-color (red)
379 (draw-string 32 32 "hi" :font :giant)
380 (draw-string 64 64 "hi" :font :small))
381 (with-clipping-rectangle* (0 (- image-height 100) 100 image-height)
382 (with-default-color ((make-anti-aliased white))
383 (dotimes (i 100)
384 (draw-line (random image-width random-state)
385 (random image-height random-state)
386 (random image-width random-state)
387 (random image-height random-state))))))
388 (setf (interlacedp) t)
389 (true-color-to-palette)
390 (if write-file
391 (write-image-to-file file
392 :if-exists :supersede)
393 (with-image-from-file (demo-file file)
394 (not (differentp demo-file *default-image*))))))
395
396 (defun test-016 ()
397 (let* ((file (test-file-location "demooutp" "png"))
398 (random-state-1 (make-random-state t))
399 (random-state-2 (make-random-state random-state-1)))
400 (gd-demo-picture file random-state-1 t)
401 (gd-demo-picture file random-state-2)))
402
403 (defun test-017 ()
404 (let ((file (test-file-location "zappa-ellipse" "png")))
405 (with-image* (250 150)
406 (with-image-from-file (zappa (test-file-location "smallzappa" "png"))
407 (setf (transparent-color) (allocate-color 255 255 255))
408 (draw-filled-ellipse 125 75 250 150
409 :color (make-tile zappa)))
410 (write-image-to-file file
411 :if-exists :supersede))
412 (compare-files file)))
413
414 (defun test-018 ()
415 (let (result)
416 (with-image* (3 3)
417 (allocate-color 255 255 255)
418 (draw-line 0 0 2 2 :color (allocate-color 0 0 0))
419 (do-rows (y)
420 (let (row)
421 (do-pixels-in-row (x)
422 (push (list x y (raw-pixel)) row))
423 (push (nreverse row) result))))
424 (equal
425 (nreverse result)
426 '(((0 0 1) (1 0 0) (2 0 0))
427 ((0 1 0) (1 1 1) (2 1 0))
428 ((0 2 0) (1 2 0) (2 2 1))))))
429
430 (defun test-019 ()
431 (let (result)
432 (with-image* (3 3 t)
433 (draw-rectangle* 0 0 2 2 :color (allocate-color 0 0 0))
434 (draw-line 0 0 2 2 :color (allocate-color 255 255 255))
435 (do-pixels ()
436 (unless (zerop (raw-pixel))
437 (decf (raw-pixel) #xff)))
438 (do-rows (y)
439 (let (row)
440 (do-pixels-in-row (x)
441 (push (list x y (raw-pixel)) row))
442 (push (nreverse row) result))))
443 (equal
444 (nreverse result)
445 '(((0 0 #xffff00) (1 0 0) (2 0 0))
446 ((0 1 0) (1 1 #xffff00) (2 1 0))
447 ((0 2 0) (1 2 0) (2 2 #xffff00))))))
448
449 (defun test-020 (georgia)
450 ;; not used for test suite because of dependency on font
451 (with-image* (200 200)
452 ;; set background (white) and make it transparent
453 (setf (transparent-color)
454 (allocate-color 255 255 255))
455 (loop for angle from 0 to (* 2 pi) by (/ pi 6)
456 for blue downfrom 255 by 20 do
457 (draw-freetype-string 100 100 "Common Lisp"
458 :font-name georgia
459 :angle angle
460 ;; note that ALLOCATE-COLOR won't work
461 ;; here because the anti-aliasing uses
462 ;; up too much colors
463 :color (find-color 0 0 blue
464 :resolve t)))
465 (write-image-to-file (test-file-location "strings" "png")
466 :if-exists :supersede)))
467
468 (defun test% (georgia)
469 (loop for i from 1 to (if georgia 20 19) do
470 (handler-case
471 (format t "Test ~A ~:[failed~;succeeded~].~%" i
472 (let ((test-function
473 (intern (format nil "TEST-~3,'0d" i)
474 :cl-gd-test)))
475 (if (= i 20)
476 (funcall test-function georgia)
477 (funcall test-function))))
478 (error (condition)
479 (format t "Test ~A failed with the following error: ~A~%"
480 i condition)))
481 (force-output))
482 (format t "Done.~%"))
483
484 (defun test (&optional georgia)
485 #-:sbcl
486 (test% georgia)
487 #+:sbcl
488 (handler-bind ((sb-ext:compiler-note #'muffle-warning))
489 (test% georgia)))

  ViewVC Help
Powered by ViewVC 1.1.5