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

Contents of /cl-gd/transform.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Sun Apr 25 20:34:01 2004 UTC (9 years, 11 months ago) by eweitz
Branch: MAIN
CVS Tags: HEAD
Changes since 1.2: +0 -0 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/transform.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-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 (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 `(progn
95 (unless (<= 2 (count-if #'identity (list ,x1 ,x2 ,width)))
96 (error "You must provide at least two of X1, X2, and WIDTH."))
97 (unless (<= 2 (count-if #'identity (list ,y1 ,y2 ,height)))
98 (error "You must provide at least two of Y1, Y2, and HEIGHT."))
99 (when (and ,x1 ,x2 ,width
100 (/= ,width (- ,x2 ,x1)))
101 (error "X1, X2, and WIDTH don't match. Try to provide just two of the three arguments."))
102 (when (and ,y1 ,y2 ,height
103 (/= ,height (- ,y2 ,y1)))
104 (error "Y1, Y2, and HEIGHT don't match. Try to provide just two of the three arguments."))
105 ;; kludgy code to keep SBCL quiet
106 (unless ,x1 (setq ,x1 (- ,x2 ,width)))
107 (unless ,x2 (setq ,x2 (+ ,x1 ,width)))
108 (unless ,width (setq ,width (- ,x2 ,x1)))
109 (unless ,y1 (setq ,y1 (- ,y2 ,height)))
110 (unless ,y2 (setq ,y2 (+ ,y1 ,height)))
111 (unless ,height (setq ,height (- ,y2 ,y1)))
112 (multiple-value-bind (,image-width ,image-height)
113 (without-transformations
114 (image-size ,image))
115 (let* ((,stretch-x (/ ,image-width ,width))
116 (,stretch-y (/ ,image-height ,height))
117 (,w-transformer (lambda (w)
118 (round-to-signed-byte-32
119 (* w ,stretch-x))))
120 (,w-inv-transformer (lambda (w)
121 (/ w ,stretch-x)))
122 (,h-transformer (lambda (h)
123 (round-to-signed-byte-32
124 (* h ,stretch-y))))
125 (,h-inv-transformer (lambda (h)
126 (/ h ,stretch-y)))
127 (,x-transformer (if ,reverse-x
128 (lambda (x)
129 (round-to-signed-byte-32
130 (* (- ,x2 x) ,stretch-x)))
131 (lambda (x)
132 (round-to-signed-byte-32
133 (* (- x ,x1) ,stretch-x)))))
134 (,x-inv-transformer (if ,reverse-x
135 (lambda (x)
136 (- ,x2 (/ x ,stretch-x)))
137 (lambda (x)
138 (+ ,x1 (/ x ,stretch-x)))))
139 (,y-transformer (if ,reverse-y
140 (lambda (y)
141 (round-to-signed-byte-32
142 (* (- y ,y1) ,stretch-y)))
143 (lambda (y)
144 (round-to-signed-byte-32
145 (* (- ,y2 y) ,stretch-y)))))
146 (,y-inv-transformer (if ,reverse-y
147 (lambda (y)
148 (+ ,y1 (/ y ,stretch-y)))
149 (lambda (y)
150 (- ,y2 (/ y ,stretch-y)))))
151 (,angle-transformer (cond (,radians
152 (lambda (angle)
153 (round-to-signed-byte-32
154 (* angle
155 +radians-to-degree-factor+))))
156 (t
157 #'identity))))
158 (push (make-instance 'transformer
159 :image ,image
160 :w-transformer ,w-transformer
161 :h-transformer ,h-transformer
162 :x-transformer ,x-transformer
163 :y-transformer ,y-transformer
164 :w-inv-transformer ,w-inv-transformer
165 :h-inv-transformer ,h-inv-transformer
166 :x-inv-transformer ,x-inv-transformer
167 :y-inv-transformer ,y-inv-transformer
168 :angle-transformer ,angle-transformer)
169 *transformers*)
170 (unwind-protect
171 (progn
172 ,@body)
173 (pop *transformers*))))))))
174
175 (defmacro with-transformed-alternative ((&rest transformations) &body body)
176 "Internal macro used to make functions
177 transformation-aware. TRANSFORMATION is a list of (EXPR
178 TRANSFORMATION) pairs where each EXPR will be replaced by the
179 transformation denoted by TRANSFORMATION."
180 (with-unique-names (transformer)
181 (let ((transformations-alist
182 (loop for (expr transformation) in transformations
183 collect `(,expr . (funcall (,transformation ,transformer) ,expr)))))
184 ;; note that we always use the name 'IMAGE' - no problem because
185 ;; this is a private macro
186 `(let ((,transformer (find image *transformers* :key #'image)))
187 (cond (,transformer
188 ,(sublis transformations-alist
189 `(progn ,@body)
190 :test #'equal))
191 (t (progn
192 ,@body)))))))

  ViewVC Help
Powered by ViewVC 1.1.5