Permalink
Find file
Fetching contributors…
Cannot retrieve contributors at this time
192 lines (180 sloc) 9.64 KB
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/gd/transform.lisp,v 1.23 2009/11/23 17:05:39 edi Exp $
;;; Copyright (c) 2003-2009, 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)
(defclass transformer ()
((image :initarg :image
:reader image)
(w-transformer :initarg :w-transformer
:reader w-transformer
:type function)
(h-transformer :initarg :h-transformer
:reader h-transformer
:type function)
(x-transformer :initarg :x-transformer
:reader x-transformer
:type function)
(y-transformer :initarg :y-transformer
:reader y-transformer
:type function)
(w-inv-transformer :initarg :w-inv-transformer
:reader w-inv-transformer
:type function)
(h-inv-transformer :initarg :h-inv-transformer
:reader h-inv-transformer
:type function)
(x-inv-transformer :initarg :x-inv-transformer
:reader x-inv-transformer
:type function)
(y-inv-transformer :initarg :y-inv-transformer
:reader y-inv-transformer
:type function)
(angle-transformer :initarg :angle-transformer
:reader angle-transformer
:type function))
(:documentation "Class used internally for WITH-TRANSFORMATION
macro."))
(defmacro without-transformations (&body body)
"Executes BODY without any transformations applied."
`(let (*transformers*)
,@body))
(declaim (inline round-to-c-int))
(defun round-to-signed-byte-32 (x)
"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 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
have length WIDTH. The new y-axis of IMAGE will start at Y1 and end at
Y2 and have length HEIGHT. In both cases it suffices to provide two of
the three values - if you provide all three they have to match. If
REVERSE-X is false the x-axis will be oriented as usual in Cartesian
coordinates, otherwise its direction will be reversed. The same
applies to REVERSE-Y, of course. If RADIANS is true angles inside of
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)
;; rebind for thread safety
`(let ((*transformers* *transformers*))
(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 "Two of ~c1, ~:*~c2, or ~a must be provided." ,c ,lbl)))
(unless (> ,aspan 0)
(error "~c1 must be smaller than ~:*~c2." ,c))
(unless (< (abs (/ (- ,a2 (+ ,a1 ,aspan)) ,aspan)) 1.e-5)
(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
(* 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)
(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
#'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*))))))))
(defmacro with-transformed-alternative ((&rest transformations) &body body)
"Internal macro used to make functions
transformation-aware. TRANSFORMATION is a list of (EXPR
TRANSFORMATION) pairs where each EXPR will be replaced by the
transformation denoted by TRANSFORMATION."
(with-unique-names (transformer)
(let ((transformations-alist
(loop for (expr transformation) in transformations
collect `(,expr . (funcall (,transformation ,transformer) ,expr)))))
;; note that we always use the name 'IMAGE' - no problem because
;; this is a private macro
`(let ((,transformer (find image *transformers* :key #'image)))
(cond (,transformer
,(sublis transformations-alist
`(progn ,@body)
:test #'equal))
(t (progn
,@body)))))))