Re-export WITH-GRAPHICS-STATE in vectometry.
[vecto.git] / graphics-state.lisp
blob7de2dc2be39726779320ceded016ad5a8e435e70
1 ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved
2 ;;;
3 ;;; Redistribution and use in source and binary forms, with or without
4 ;;; modification, are permitted provided that the following conditions
5 ;;; are met:
6 ;;;
7 ;;; * Redistributions of source code must retain the above copyright
8 ;;; notice, this list of conditions and the following disclaimer.
9 ;;;
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.
14 ;;;
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.
26 ;;;
27 ;;; $Id: graphics-state.lisp,v 1.15 2007/10/01 02:24:44 xach Exp $
29 (in-package #:vecto)
31 (defconstant +png-channels+ 4)
32 (defconstant +png-color-type+ :truecolor-alpha)
33 (defvar *default-character-spacing* 1.0d0)
35 (defclass graphics-state ()
36 ((paths
37 :initarg :paths
38 :accessor paths)
39 (path
40 :initarg :path
41 :accessor path)
42 (height
43 :initarg :height
44 :accessor height)
45 (width
46 :initarg :width
47 :accessor width)
48 (image
49 :initarg :image
50 :accessor image)
51 (stroke-color
52 :initarg :stroke-color
53 :accessor stroke-color)
54 (line-width
55 :initarg :line-width
56 :accessor line-width)
57 (dash-vector
58 :initarg :dash-vector
59 :accessor dash-vector)
60 (dash-phase
61 :initarg :dash-phase
62 :accessor dash-phase)
63 (fill-color
64 :initarg :fill-color
65 :accessor fill-color)
66 (fill-source
67 :initarg :fill-source
68 :accessor fill-source)
69 (join-style
70 :initarg :join-style
71 :accessor join-style)
72 (cap-style
73 :initarg :cap-style
74 :accessor cap-style)
75 (transform-matrix
76 :initarg :transform-matrix
77 :accessor transform-matrix)
78 (clipping-path
79 :initarg :clipping-path
80 :accessor clipping-path)
81 (after-paint-fun
82 :initarg :after-paint-fun
83 :accessor after-paint-fun)
84 (font-loaders
85 :initarg :font-loaders
86 :accessor font-loaders)
87 (font
88 :initarg :font
89 :accessor font)
90 (character-spacing
91 :initarg :character-spacing
92 :accessor character-spacing))
93 (:default-initargs
94 :paths nil
95 :path nil
96 :stroke-color (make-instance 'rgba-color)
97 :line-width 1.0
98 :dash-vector nil
99 :dash-phase 0
100 :fill-color (make-instance 'rgba-color)
101 :fill-source nil
102 :join-style :miter
103 :cap-style :butt
104 :transform-matrix (scaling-matrix 1.0 -1.0)
105 :after-paint-fun (constantly nil)
106 :font-loaders (make-hash-table :test 'equal)
107 :font nil
108 :character-spacing *default-character-spacing*))
110 (defgeneric image-data (state)
111 (:method (state)
112 (zpng:image-data (image state))))
114 (defgeneric transform-function (state)
115 (:documentation "Return a function that takes x, y coordinates
116 and returns them transformed by STATE's current transformation
117 matrix as multiple values.")
118 (:method (state)
119 (make-transform-function (transform-matrix state))))
122 (defgeneric call-after-painting (state fun)
123 (:documentation
124 "Call FUN after painting, and reset the post-painting fun to a no-op.")
125 (:method (state fun)
126 (setf (after-paint-fun state)
127 (lambda ()
128 (funcall fun)
129 (setf (after-paint-fun state) (constantly nil))))))
131 (defgeneric after-painting (state)
132 (:documentation "Invoke the post-painting function.")
133 (:method (state)
134 (funcall (after-paint-fun state))))
137 (defgeneric apply-matrix (state matrix)
138 (:documentation "Replace the current transform matrix of STATE
139 with the result of premultiplying it with MATRIX.")
140 (:method (state matrix)
141 (let ((old (transform-matrix state)))
142 (setf (transform-matrix state) (mult matrix old)))))
144 (defgeneric clear-paths (state)
145 (:documentation "Clear out any paths in STATE.")
146 (:method (state)
147 (setf (paths state) nil
148 (path state) nil
149 (after-paint-fun state) (constantly nil))))
151 (defmethod (setf paths) :after (new-value (state graphics-state))
152 (setf (path state) (first new-value)))
154 (defun state-image (state width height)
155 "Set the backing image of the graphics state to an image of the
156 specified dimensions."
157 (setf (image state)
158 (make-instance 'zpng:png
159 :width width
160 :height height
161 :color-type +png-color-type+)
162 (width state) width
163 (height state) height
164 (clipping-path state) (make-clipping-path width height))
165 (apply-matrix state (translation-matrix 0 (- height))))
168 (defun find-font-loader (state file)
169 (let* ((cache (font-loaders state))
170 (key (namestring (truename file))))
171 (or (gethash key cache)
172 (setf (gethash key cache) (zpb-ttf:open-font-loader file)))))
174 (defgeneric close-font-loaders (state)
175 (:documentation "Close any font loaders that were obtained with GET-FONT.")
176 (:method (state)
177 (maphash (lambda (filename loader)
178 (declare (ignore filename))
179 (ignore-errors (zpb-ttf:close-font-loader loader)))
180 (font-loaders state))))
182 (defgeneric clear-state (state)
183 (:documentation "Clean up any state in STATE.")
184 (:method ((state graphics-state))
185 (close-font-loaders state)))
187 (defun clear-fill-source (state)
188 (setf (fill-source state) nil))
190 (defmethod copy ((state graphics-state))
191 (make-instance 'graphics-state
192 :paths (paths state)
193 :path (path state)
194 :height (height state)
195 :width (width state)
196 :image (image state)
197 :stroke-color (copy (stroke-color state))
198 :line-width (line-width state)
199 :dash-vector (copy-seq (dash-vector state))
200 :dash-phase (dash-phase state)
201 :fill-color (copy (fill-color state))
202 :fill-source (fill-source state)
203 :join-style (join-style state)
204 :cap-style (cap-style state)
205 :transform-matrix (copy-seq (transform-matrix state))
206 :clipping-path (copy (clipping-path state))
207 :after-paint-fun (after-paint-fun state)
208 :font-loaders (font-loaders state)
209 :font (font state)
210 :character-spacing (character-spacing state)))