1 ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved
3 ;;; Redistribution and use in source and binary forms, with or without
4 ;;; modification, are permitted provided that the following conditions
7 ;;; * Redistributions of source code must retain the above copyright
8 ;;; notice, this list of conditions and the following disclaimer.
10 ;;; * Redistributions in binary form must reproduce the above
11 ;;; copyright notice, this list of conditions and the following
12 ;;; disclaimer in the documentation and/or other materials
13 ;;; provided with the distribution.
15 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
16 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
17 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
18 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
19 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
20 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
21 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
22 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
23 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
24 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
25 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
27 ;;; $Id: graphics-state.lisp,v 1.15 2007/10/01 02:24:44 xach Exp $
31 (defconstant +png-channels
+ 4)
32 (defconstant +png-color-type
+ :truecolor-alpha
)
34 (defclass graphics-state
()
51 :initarg
:stroke-color
52 :accessor stroke-color
)
58 :accessor dash-vector
)
72 :initarg
:transform-matrix
73 :accessor transform-matrix
)
75 :initarg
:clipping-path
76 :accessor clipping-path
)
78 :initarg
:after-paint-fun
79 :accessor after-paint-fun
)
81 :initarg
:font-loaders
82 :accessor font-loaders
)
89 :stroke-color
(make-instance 'rgba-color
)
93 :fill-color
(make-instance 'rgba-color
)
96 :transform-matrix
(scaling-matrix 1.0 -
1.0)
97 :after-paint-fun
(constantly nil
)
98 :font-loaders
(make-hash-table :test
'equal
)
101 (defgeneric image-data
(state)
103 (zpng:image-data
(image state
))))
105 (defgeneric transform-function
(state)
106 (:documentation
"Return a function that takes x, y coordinates
107 and returns them transformed by STATE's current transformation
108 matrix as multiple values.")
110 (make-transform-function (transform-matrix state
))))
113 (defgeneric call-after-painting
(state fun
)
115 "Call FUN after painting, and reset the post-painting fun to a no-op.")
117 (setf (after-paint-fun state
)
120 (setf (after-paint-fun state
) (constantly nil
))))))
122 (defgeneric after-painting
(state)
123 (:documentation
"Invoke the post-painting function.")
125 (funcall (after-paint-fun state
))))
128 (defgeneric apply-matrix
(state matrix
)
129 (:documentation
"Replace the current transform matrix of STATE
130 with the result of premultiplying it with MATRIX.")
131 (:method
(state matrix
)
132 (let ((old (transform-matrix state
)))
133 (setf (transform-matrix state
) (mult matrix old
)))))
135 (defgeneric clear-paths
(state)
136 (:documentation
"Clear out any paths in STATE.")
138 (setf (paths state
) nil
140 (after-paint-fun state
) (constantly nil
))))
142 (defmethod (setf paths
) :after
(new-value (state graphics-state
))
143 (setf (path state
) (first new-value
)))
145 (defun state-image (state width height
)
146 "Set the backing image of the graphics state to an image of the
147 specified dimensions."
149 (make-instance 'zpng
:png
152 :color-type
+png-color-type
+)
154 (height state
) height
155 (clipping-path state
) (make-clipping-path width height
))
156 (apply-matrix state
(translation-matrix 0 (- height
))))
159 (defun find-font-loader (state file
)
160 (let* ((cache (font-loaders state
))
161 (key (namestring (truename file
))))
162 (or (gethash key cache
)
163 (setf (gethash key cache
) (zpb-ttf:open-font-loader file
)))))
165 (defgeneric close-font-loaders
(state)
166 (:documentation
"Close any font loaders that were obtained with GET-FONT.")
168 (maphash (lambda (filename loader
)
169 (declare (ignore filename
))
170 (ignore-errors (zpb-ttf:close-font-loader loader
)))
171 (font-loaders state
))))
173 (defgeneric clear-state
(state)
174 (:documentation
"Clean up any state in STATE.")
175 (:method
((state graphics-state
))
176 (close-font-loaders state
)))
179 (defmethod copy ((state graphics-state
))
180 (make-instance 'graphics-state
183 :height
(height state
)
186 :stroke-color
(copy (stroke-color state
))
187 :line-width
(line-width state
)
188 :dash-vector
(copy-seq (dash-vector state
))
189 :dash-phase
(dash-phase state
)
190 :fill-color
(copy (fill-color state
))
191 :join-style
(join-style state
)
192 :cap-style
(cap-style state
)
193 :transform-matrix
(copy-seq (transform-matrix state
))
194 :clipping-path
(copy (clipping-path state
))
195 :after-paint-fun
(after-paint-fun state
)
196 :font-loaders
(font-loaders state
)