Mercurial > hg > indyvon

view src/net/kryshen/indyvon/viewport.clj @ 146:dc437b4ceeea

find changesets by author, revision, files, or words in the commit message
Refactored align-x and align-y macros.
author Mikhail Kryshen <mikhail@kryshen.net>
date Thu, 25 Apr 2013 02:41:50 +0400
parents 173616375eb5
children cb108c6fa079
line source
1 ;;
2 ;; Copyright 2010, 2011, 2012, 2013 Mikhail Kryshen <mikhail@kryshen.net>
3 ;;
4 ;; This file is part of Indyvon.
5 ;;
6 ;; Indyvon is free software: you can redistribute it and/or modify it
7 ;; under the terms of the GNU Lesser General Public License version 3
8 ;; only, as published by the Free Software Foundation.
9 ;;
10 ;; Indyvon is distributed in the hope that it will be useful, but
11 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;; Lesser General Public License for more details.
14 ;;
15 ;; You should have received a copy of the GNU Lesser General Public
16 ;; License along with Indyvon. If not, see
17 ;; <http://www.gnu.org/licenses/>.
18 ;;
19
20 (ns net.kryshen.indyvon.viewport
21 "Scrollable viewport and miniature."
22 (:use
23 (net.kryshen.indyvon core async layers))
24 (:import
25 java.awt.Cursor
26 java.awt.geom.AffineTransform))
27
28 ;;(defn- translate [^AffineTransform transform ^double x ^double y]
29 ;; (doto ^AffineTransform (.clone transform)
30 ;; (.translate x y)))
31
32 (defn- scale [^AffineTransform transform ^double sx ^double sy]
33 (doto ^AffineTransform (.clone transform)
34 (.scale sx sy)))
35
36 (defn- pre-translate [^AffineTransform transform ^double x ^double y]
37 (if (== 0.0 x y)
38 transform
39 (doto (AffineTransform/getTranslateInstance x y)
40 (.concatenate transform))))
41
42 (def ^:dynamic *viewport-scaling-step* (double 3/4))
43 (def ^:dynamic *viewport-min-scale* 1E-6)
44 (def ^:dynamic *viewport-max-scale* 1E6)
45
46 (def ^:dynamic *viewport* nil)
47 (def ^:dynamic ^AffineTransform *viewport-transform*)
48
49 (declare scale-viewport!)
50
51 (defrecord ViewportState [transform
52 fix-x fix-y
53 last-width last-height
54 last-anchor-x last-anchor-y])
55
56 (defn- update-viewport [state content-geom h-align v-align]
57 (let [w *width*
58 h *height*
59 cw (width content-geom)
60 ch (height content-geom)
61 ax (anchor-x content-geom h-align cw)
62 ay (anchor-y content-geom v-align ch)
63 ax1 (align-x h-align (:last-width state) w)
64 ay1 (align-y v-align (:last-height state) h)
65 ax2 (- (:last-anchor-x state) ax)
66 ay2 (- (:last-anchor-y state) ay)
67 transform (:transform state)
68 transform (if (and (zero? ax1) (zero? ay1)
69 (zero? ax2) (zero? ay2))
70 transform
71 (doto
72 (AffineTransform/getTranslateInstance ax1 ay1)
73 (.concatenate transform)
74 (.translate ax2 ay2)))]
75 (assoc state
76 :last-width w
77 :last-height h
78 :last-anchor-x ax
79 :last-anchor-y ay
80 :transform transform)))
81
82 (defrecord Viewport [content h-align v-align state]
83 Layer
84 (render! [layer]
85 (repaint-on-update layer)
86 (with-handlers layer
87 (let [geom (geometry content)
88 new-state (swap! state update-viewport geom h-align v-align)
89 transform (:transform new-state)]
90 ;; TODO: notify observers when size changes.
91 (binding [*viewport* layer
92 *viewport-transform* transform]
93 (with-transform transform
94 (draw! content 0 0 (width geom) (height geom) false))))
95 (:mouse-pressed e
96 (swap! state assoc
97 :fix-x (:x-on-screen e)
98 :fix-y (:y-on-screen e))
99 (set-cursor! (Cursor. Cursor/MOVE_CURSOR)))
100 (:mouse-released e
101 (set-cursor! (Cursor. Cursor/DEFAULT_CURSOR)))
102 (:mouse-dragged e
103 (swap! state
104 (fn [s]
105 (assoc s
106 :transform (pre-translate
107 (:transform s)
108 (- (:x-on-screen e) (:fix-x s))
109 (- (:y-on-screen e) (:fix-y s)))
110 :fix-x (:x-on-screen e)
111 :fix-y (:y-on-screen e))))
112 (update layer))
113 (:mouse-wheel e
114 (scale-viewport!
115 layer
116 (Math/pow *viewport-scaling-step* (:wheel-rotation e))
117 true (:x e) (:y e)))))
118 (geometry [_]
119 (geometry content)))
120
121 (def ^:private viewport-initial-state
122 (->ViewportState
123 (AffineTransform.) ; transform
124 0 0 ; fix-x fix-y
125 0 0 ; last-width last-height
126 0 0))
127
128 (defn viewport
129 "Creates scrollable viewport layer."
130 ([content]
131 (viewport content :left :top))
132 ([content h-align v-align]
133 (->Viewport content h-align v-align (atom viewport-initial-state))))
134
135 (defn- scale-viewport [state vp s relative? x y]
136 (let [^AffineTransform tr (:transform state)
137 sx (if relative? s (/ s (.getScaleX tr)))
138 sy (if relative? s (/ s (.getScaleY tr)))
139 x (or x (align-x (:h-align vp) (:last-width state)))
140 y (or y (align-y (:v-align vp) (:last-height state)))
141 x (- x (* x sx))
142 y (- y (* y sy))
143 scaled (doto (AffineTransform/getTranslateInstance x y)
144 (.scale sx sy)
145 (.concatenate tr))
146 sx (.getScaleX scaled)
147 sy (.getScaleY scaled)]
148 (if (<= *viewport-min-scale*
149 (min sx sy)
150 (max sx sy)
151 *viewport-max-scale*)
152 (assoc state
153 :transform scaled)
154 state)))
155
156 (defn scale-viewport!
157 ([viewport s]
158 (scale-viewport! viewport s true))
159 ([viewport s relative?]
160 (scale-viewport! viewport s relative? nil nil))
161 ([viewport s relative? x y]
162 (swap! (:state viewport) scale-viewport viewport s relative? x y)
163 (update viewport)))
164
165 (defn reset-viewport! [viewport]
166 (reset! (:state viewport) viewport-initial-state)
167 (update viewport))
168
169 (defn ^AffineTransform viewport-transform [viewport]
170 (:transform @(:state viewport)))
171
172 (defn- scaling
173 [width height max-width max-height]
174 (min (/ max-width width)
175 (/ max-height height)))
176
177 (defn miniature
178 "Creates layer that asynchronously renders view of the content
179 scaled to the specified size."
180 [content mw mh]
181 (async-layer
182 (reify
183 Layer
184 (render! [this]
185 (let [geom (geometry content)
186 cw (width geom)
187 ch (height geom)
188 s (scaling cw ch mw mh)]
189 (.scale *graphics* s s)
190 (draw! content
191 (align-x :center cw (/ mw s))
192 (align-y :center ch (/ mh s))
193 cw ch)))
194 (geometry [_]
195 (->Size mw mh)))
196 mw mh *miniature-thread-priority*))
197
198 (defn viewport-miniature
199 "Creates miniature view of the viewport's contents."
200 [viewport m-width m-height]
201 (let [miniature (miniature (:content viewport) m-width m-height)]
202 (decorate-layer miniature [l]
203 (repaint-on-update viewport)
204 (let [geom (geometry (:content viewport))
205 s (scaling (width geom) (height geom) m-width m-height)
206 vp-state @(:state viewport)
207 {:keys [transform last-width last-height]} @(:state viewport)
208 ox (align-x :center (width geom) (/ m-width s))
209 oy (align-y :center (height geom) (/ m-height s))
210 inverse (.createInverse ^AffineTransform transform)
211 transform (doto (AffineTransform.)
212 (.scale s s)
213 (.translate ox oy)
214 (.concatenate inverse))
215 move-vp (fn [state x y]
216 (let [x (- (/ x s) ox)
217 y (- (/ y s) oy)
218 tr (:transform state)
219 [x y] (transform-point tr x y)
220 x (- x (/ (:last-width state) 2))
221 y (- y (/ (:last-height state) 2))]
222 (assoc state
223 :transform (pre-translate tr (- x) (- y)))))
224 move-vp! (fn [x y]
225 (swap! (:state viewport) move-vp x y)
226 (update viewport))]
227 (with-color :alt-back-color
228 (.fillRect *graphics* 0 0 *width* *height*))
229 (with-transform transform
230 (with-color :back-color
231 (.fillRect *graphics* 0 0 last-width last-height)))
232 (with-handlers l
233 (draw! miniature)
234 (:mouse-pressed e (move-vp! (:x e) (:y e)))
235 (:mouse-dragged e (move-vp! (:x e) (:y e))))
236 (with-transform transform
237 (with-color :border-color
238 (.drawRect *graphics* 0 0 last-width last-height)))))))