proposed patch for WITH-TRANSFORMATION macro
Jeff Cunningham <j.k.cunningham <at> comcast.net>
2009-11-09 03:58:16 GMT
Hi,
I use cl-gd extensively and decided to figure out how to eliminate the
incessant SBCL generated warnings that trace back to the
WITH-TRANSFORMATION macro. It looks like work has already been done
there. I came up with a pretty clean solution which removes the existing
argument checking, provides it through a different mechanism and
satisfies SBCL and backwards compatibility. I don't have any other
platforms to test with but I think it will run on anything. I've
attached the patch.
Regards,
Jeff Cunningham
--- cl-gd-0.5.6/transform.lisp 2007-07-29 09:37:13.000000000 -0700
+++ source/cl-gd-0.5.6/transform.lisp 2009-11-08 19:31:08.000000000 -0800
@@ -72,7 +72,10 @@
"Like ROUND but make sure result isn't longer than 32 bits."
(mod (round x) +most-positive-unsigned-byte-32+))
-(defmacro with-transformation ((&key x1 x2 width y1 y2 height reverse-x reverse-y (radians t) (image
'*default-image*)) &body body)
+(defmacro with-transformation ((&key (x1 0 x1set) (x2 0 x2set) (width 0 wset)
+ (y1 0 y1set) (y2 0 y2set) (height 0 hset)
+ reverse-x reverse-y (radians t) (image '*default-image*))
+ &body body)
"Executes BODY such that all points and width/height data are
subject to a simple affine transformation defined by the keyword
parameters. The new x-axis of IMAGE will start at X1 and end at X2 and
@@ -85,93 +88,91 @@
BODY will be assumed to be provided in radians, otherwise in degrees."
(with-rebinding (x1 x2 width y1 y2 height reverse-x reverse-y radians image)
(with-unique-names (image-width image-height
- stretch-x stretch-y
- w-transformer h-transformer
- x-transformer y-transformer
- w-inv-transformer h-inv-transformer
- x-inv-transformer y-inv-transformer
- angle-transformer)
+ stretch-x stretch-y
+ w-transformer h-transformer
+ x-transformer y-transformer
+ w-inv-transformer h-inv-transformer
+ x-inv-transformer y-inv-transformer
+ angle-transformer)
;; rebind for thread safety
`(let ((*transformers* *transformers*))
- (unless (<= 2 (count-if #'identity (list ,x1 ,x2 ,width)))
- (error "You must provide at least two of X1, X2, and WIDTH."))
- (unless (<= 2 (count-if #'identity (list ,y1 ,y2 ,height)))
- (error "You must provide at least two of Y1, Y2, and HEIGHT."))
- (when (and ,x1 ,x2 ,width
- (/= ,width (- ,x2 ,x1)))
- (error "X1, X2, and WIDTH don't match. Try to provide just two of the three arguments."))
- (when (and ,y1 ,y2 ,height
- (/= ,height (- ,y2 ,y1)))
- (error "Y1, Y2, and HEIGHT don't match. Try to provide just two of the three arguments."))
- ;; kludgy code to keep SBCL quiet
- (unless ,x1 (setq ,x1 (- ,x2 ,width)))
- (unless ,x2 (setq ,x2 (+ ,x1 ,width)))
- (unless ,width (setq ,width (- ,x2 ,x1)))
- (unless ,y1 (setq ,y1 (- ,y2 ,height)))
- (unless ,y2 (setq ,y2 (+ ,y1 ,height)))
- (unless ,height (setq ,height (- ,y2 ,y1)))
- (multiple-value-bind (,image-width ,image-height)
- (without-transformations
- (image-size ,image))
- (let* ((,stretch-x (/ ,image-width ,width))
- (,stretch-y (/ ,image-height ,height))
- (,w-transformer (lambda (w)
- (round-to-signed-byte-32
- (* w ,stretch-x))))
- (,w-inv-transformer (lambda (w)
- (/ w ,stretch-x)))
- (,h-transformer (lambda (h)
- (round-to-signed-byte-32
- (* h ,stretch-y))))
- (,h-inv-transformer (lambda (h)
- (/ h ,stretch-y)))
- (,x-transformer (if ,reverse-x
- (lambda (x)
+ (macrolet ((checkargs (a1 a1set a2 a2set aspan aspanset c lbl)
+ `(progn
+ (cond ((and ,a1set ,a2set) (setq ,aspan (- ,a2 ,a1)))
+ ((and ,a1set ,aspanset) (setq ,a2 (+ ,a1 ,aspan)))
+ ((and ,a2set ,aspanset) (setq ,a1 (- ,a2 ,aspan)))
+ (t (error "Require two of ~c1, ~:*~c2, or ~a to be set." ,c ,lbl)))
+ (unless (> ,aspan 0)
+ (format t "~&a1=~a a2=~a span=~a~%" ,a1 ,a2 ,aspan)
+ (error "Require ~c1 < ~:*~c2" ,c))
+ (unless (< (abs (/ (- ,a2 (+ ,a1 ,aspan)) ,aspan)) 1.e-5)
+ (format t "~&a1=~a a2=~a span=~a~%" ,a1 ,a2 ,aspan)
+ (format t "error=~a~%" (- ,aspan (- ,a2 ,a1)))
+ (error "~c1, ~:*~c2, and ~a don't match. Try to provide just two of the three arguments." ,c ,lbl)))))
+ (checkargs ,x1 ,x1set ,x2 ,x2set ,width ,wset #\x "width")
+ (checkargs ,y1 ,y1set ,y2 ,y2set ,height ,hset #\y "height"))
+ (multiple-value-bind (,image-width ,image-height)
+ (without-transformations
+ (image-size ,image))
+ (let* ((,stretch-x (/ ,image-width ,width))
+ (,stretch-y (/ ,image-height ,height))
+ (,w-transformer (lambda (w)
(round-to-signed-byte-32
- (* (- ,x2 x) ,stretch-x)))
- (lambda (x)
+ (* w ,stretch-x))))
+ (,w-inv-transformer (lambda (w)
+ (/ w ,stretch-x)))
+ (,h-transformer (lambda (h)
(round-to-signed-byte-32
- (* (- x ,x1) ,stretch-x)))))
- (,x-inv-transformer (if ,reverse-x
- (lambda (x)
- (- ,x2 (/ x ,stretch-x)))
- (lambda (x)
- (+ ,x1 (/ x ,stretch-x)))))
- (,y-transformer (if ,reverse-y
- (lambda (y)
- (round-to-signed-byte-32
- (* (- y ,y1) ,stretch-y)))
- (lambda (y)
- (round-to-signed-byte-32
- (* (- ,y2 y) ,stretch-y)))))
- (,y-inv-transformer (if ,reverse-y
- (lambda (y)
- (+ ,y1 (/ y ,stretch-y)))
- (lambda (y)
- (- ,y2 (/ y ,stretch-y)))))
- (,angle-transformer (cond (,radians
+ (* h ,stretch-y))))
+ (,h-inv-transformer (lambda (h)
+ (/ h ,stretch-y)))
+ (,x-transformer (if ,reverse-x
+ (lambda (x)
+ (round-to-signed-byte-32
+ (* (- ,x2 x) ,stretch-x)))
+ (lambda (x)
+ (round-to-signed-byte-32
+ (* (- x ,x1) ,stretch-x)))))
+ (,x-inv-transformer (if ,reverse-x
+ (lambda (x)
+ (- ,x2 (/ x ,stretch-x)))
+ (lambda (x)
+ (+ ,x1 (/ x ,stretch-x)))))
+ (,y-transformer (if ,reverse-y
+ (lambda (y)
+ (round-to-signed-byte-32
+ (* (- y ,y1) ,stretch-y)))
+ (lambda (y)
+ (round-to-signed-byte-32
+ (* (- ,y2 y) ,stretch-y)))))
+ (,y-inv-transformer (if ,reverse-y
+ (lambda (y)
+ (+ ,y1 (/ y ,stretch-y)))
+ (lambda (y)
+ (- ,y2 (/ y ,stretch-y)))))
+ (,angle-transformer (cond (,radians
(lambda (angle)
(round-to-signed-byte-32
(* angle
+radians-to-degree-factor+))))
- (t
+ (t
#'identity))))
- (push (make-instance 'transformer
- :image ,image
- :w-transformer ,w-transformer
- :h-transformer ,h-transformer
- :x-transformer ,x-transformer
- :y-transformer ,y-transformer
- :w-inv-transformer ,w-inv-transformer
- :h-inv-transformer ,h-inv-transformer
- :x-inv-transformer ,x-inv-transformer
- :y-inv-transformer ,y-inv-transformer
- :angle-transformer ,angle-transformer)
- *transformers*)
- (unwind-protect
- (progn
- ,@body)
- (pop *transformers*))))))))
+ (push (make-instance 'transformer
+ :image ,image
+ :w-transformer ,w-transformer
+ :h-transformer ,h-transformer
+ :x-transformer ,x-transformer
+ :y-transformer ,y-transformer
+ :w-inv-transformer ,w-inv-transformer
+ :h-inv-transformer ,h-inv-transformer
+ :x-inv-transformer ,x-inv-transformer
+ :y-inv-transformer ,y-inv-transformer
+ :angle-transformer ,angle-transformer)
+ *transformers*)
+ (unwind-protect
+ (progn
+ ,@body)
+ (pop *transformers*))))))))
(defmacro with-transformed-alternative ((&rest transformations) &body body)
"Internal macro used to make functions
RSS Feed