transform.lisp

Revision 2428, 9.5 kB (checked in by hhubner, 1 year ago)
Update cl-gd.

Line
1	;;; -- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 --
2	;;; $Header: /usr/local/cvsrep/gd/transform.lisp,v 1.21 2007/07/29 16:37:13 edi Exp $
3
4	;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved.
5
6	;;; Redistribution and use in source and binary forms, with or without
7	;;; modification, are permitted provided that the following conditions
8	;;; are met:
9
10	;;; * Redistributions of source code must retain the above copyright
11	;;; notice, this list of conditions and the following disclaimer.
12
13	;;; * Redistributions in binary form must reproduce the above
14	;;; copyright notice, this list of conditions and the following
15	;;; disclaimer in the documentation and/or other materials
16	;;; provided with the distribution.
17
18	;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
19	;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20	;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21	;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
22	;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23	;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
24	;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25	;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26	;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27	;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28	;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29
30	(in-package :cl-gd)
31
32	(defclass transformer ()
33	((image :initarg :image
34	:reader image)
35	(w-transformer :initarg :w-transformer
36	:reader w-transformer
37	:type function)
38	(h-transformer :initarg :h-transformer
39	:reader h-transformer
40	:type function)
41	(x-transformer :initarg :x-transformer
42	:reader x-transformer
43	:type function)
44	(y-transformer :initarg :y-transformer
45	:reader y-transformer
46	:type function)
47	(w-inv-transformer :initarg :w-inv-transformer
48	:reader w-inv-transformer
49	:type function)
50	(h-inv-transformer :initarg :h-inv-transformer
51	:reader h-inv-transformer
52	:type function)
53	(x-inv-transformer :initarg :x-inv-transformer
54	:reader x-inv-transformer
55	:type function)
56	(y-inv-transformer :initarg :y-inv-transformer
57	:reader y-inv-transformer
58	:type function)
59	(angle-transformer :initarg :angle-transformer
60	:reader angle-transformer
61	:type function))
62	(:documentation "Class used internally for WITH-TRANSFORMATION
63	macro."))
64
65	(defmacro without-transformations (&body body)
66	"Executes BODY without any transformations applied."
67	`(let (transformers)
68	,@body))
69
70	(declaim (inline round-to-c-int))
71	(defun round-to-signed-byte-32 (x)
72	"Like ROUND but make sure result isn't longer than 32 bits."
73	(mod (round x) +most-positive-unsigned-byte-32+))
74
75	(defmacro with-transformation ((&key x1 x2 width y1 y2 height reverse-x reverse-y (radians t) (image 'default-image)) &body body)
76	"Executes BODY such that all points and width/height data are
77	subject to a simple affine transformation defined by the keyword
78	parameters. The new x-axis of IMAGE will start at X1 and end at X2 and
79	have length WIDTH. The new y-axis of IMAGE will start at Y1 and end at
80	Y2 and have length HEIGHT. In both cases it suffices to provide two of
81	the three values - if you provide all three they have to match. If
82	REVERSE-X is false the x-axis will be oriented as usual in Cartesian
83	coordinates, otherwise its direction will be reversed. The same
84	applies to REVERSE-Y, of course. If RADIANS is true angles inside of
85	BODY will be assumed to be provided in radians, otherwise in degrees."
86	(with-rebinding (x1 x2 width y1 y2 height reverse-x reverse-y radians image)
87	(with-unique-names (image-width image-height
88	stretch-x stretch-y
89	w-transformer h-transformer
90	x-transformer y-transformer
91	w-inv-transformer h-inv-transformer
92	x-inv-transformer y-inv-transformer
93	angle-transformer)
94	;; rebind for thread safety
95	`(let ((transformers transformers))
96	(unless (<= 2 (count-if #'identity (list ,x1 ,x2 ,width)))
97	(error "You must provide at least two of X1, X2, and WIDTH."))
98	(unless (<= 2 (count-if #'identity (list ,y1 ,y2 ,height)))
99	(error "You must provide at least two of Y1, Y2, and HEIGHT."))
100	(when (and ,x1 ,x2 ,width
101	(/= ,width (- ,x2 ,x1)))
102	(error "X1, X2, and WIDTH don't match. Try to provide just two of the three arguments."))
103	(when (and ,y1 ,y2 ,height
104	(/= ,height (- ,y2 ,y1)))
105	(error "Y1, Y2, and HEIGHT don't match. Try to provide just two of the three arguments."))
106	;; kludgy code to keep SBCL quiet
107	(unless ,x1 (setq ,x1 (- ,x2 ,width)))
108	(unless ,x2 (setq ,x2 (+ ,x1 ,width)))
109	(unless ,width (setq ,width (- ,x2 ,x1)))
110	(unless ,y1 (setq ,y1 (- ,y2 ,height)))
111	(unless ,y2 (setq ,y2 (+ ,y1 ,height)))
112	(unless ,height (setq ,height (- ,y2 ,y1)))
113	(multiple-value-bind (,image-width ,image-height)
114	(without-transformations
115	(image-size ,image))
116	(let* ((,stretch-x (/ ,image-width ,width))
117	(,stretch-y (/ ,image-height ,height))
118	(,w-transformer (lambda (w)
119	(round-to-signed-byte-32
120	(* w ,stretch-x))))
121	(,w-inv-transformer (lambda (w)
122	(/ w ,stretch-x)))
123	(,h-transformer (lambda (h)
124	(round-to-signed-byte-32
125	(* h ,stretch-y))))
126	(,h-inv-transformer (lambda (h)
127	(/ h ,stretch-y)))
128	(,x-transformer (if ,reverse-x
129	(lambda (x)
130	(round-to-signed-byte-32
131	(* (- ,x2 x) ,stretch-x)))
132	(lambda (x)
133	(round-to-signed-byte-32
134	(* (- x ,x1) ,stretch-x)))))
135	(,x-inv-transformer (if ,reverse-x
136	(lambda (x)
137	(- ,x2 (/ x ,stretch-x)))
138	(lambda (x)
139	(+ ,x1 (/ x ,stretch-x)))))
140	(,y-transformer (if ,reverse-y
141	(lambda (y)
142	(round-to-signed-byte-32
143	(* (- y ,y1) ,stretch-y)))
144	(lambda (y)
145	(round-to-signed-byte-32
146	(* (- ,y2 y) ,stretch-y)))))
147	(,y-inv-transformer (if ,reverse-y
148	(lambda (y)
149	(+ ,y1 (/ y ,stretch-y)))
150	(lambda (y)
151	(- ,y2 (/ y ,stretch-y)))))
152	(,angle-transformer (cond (,radians
153	(lambda (angle)
154	(round-to-signed-byte-32
155	(* angle
156	+radians-to-degree-factor+))))
157	(t
158	#'identity))))
159	(push (make-instance 'transformer
160	:image ,image
161	:w-transformer ,w-transformer
162	:h-transformer ,h-transformer
163	:x-transformer ,x-transformer
164	:y-transformer ,y-transformer
165	:w-inv-transformer ,w-inv-transformer
166	:h-inv-transformer ,h-inv-transformer
167	:x-inv-transformer ,x-inv-transformer
168	:y-inv-transformer ,y-inv-transformer
169	:angle-transformer ,angle-transformer)
170	transformers)
171	(unwind-protect
172	(progn
173	,@body)
174	(pop transformers))))))))
175
176	(defmacro with-transformed-alternative ((&rest transformations) &body body)
177	"Internal macro used to make functions
178	transformation-aware. TRANSFORMATION is a list of (EXPR
179	TRANSFORMATION) pairs where each EXPR will be replaced by the
180	transformation denoted by TRANSFORMATION."
181	(with-unique-names (transformer)
182	(let ((transformations-alist
183	(loop for (expr transformation) in transformations
184	collect `(,expr . (funcall (,transformation ,transformer) ,expr)))))
185	;; note that we always use the name 'IMAGE' - no problem because
186	;; this is a private macro
187	`(let ((,transformer (find image transformers :key #'image)))
188	(cond (,transformer
189	,(sublis transformations-alist
190	`(progn ,@body)
191	:test #'equal))
192	(t (progn
193	,@body)))))))

Note: See TracBrowser for help on using the browser.

Download in other formats:

Original Format