Mercurial > hg > indyvon
view src/net/kryshen/indyvon/layers.clj @ 139:173616375eb5
Refactoring. Moved viewport functions into separate namespace.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Mon, 07 Jan 2013 19:52:23 +0400 |
| parents | 1a5fd362114d |
| children | 479019bba20a |
line source
1 ;;
2 ;; Copyright 2010, 2011, 2012 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 ;;
20 (ns net.kryshen.indyvon.layers
21 "Implementations of Layer protocol."
22 (:use
23 (net.kryshen.indyvon core async))
24 (:import
25 (java.awt Font Image Toolkit)
26 java.awt.image.ImageObserver
27 (java.awt.geom Area AffineTransform Rectangle2D$Double Point2D
28 Point2D$Double)
29 (java.awt.font FontRenderContext TextLayout)
30 java.util.concurrent.TimeUnit
31 (com.google.common.cache Cache CacheBuilder CacheLoader)))
33 ;; Define as macro to avoid unnecessary calculation of inner and outer
34 ;; sizes in the first case.
35 (defmacro align-xy [inner outer align first center last]
36 `(case ~align
37 ~first 0
38 ~center (/ (- ~outer ~inner) 2)
39 ~last (- ~outer ~inner)))
41 (defmacro align-x [inner outer align]
42 `(align-xy ~inner ~outer ~align :left :center :right))
44 (defmacro align-y [inner outer align]
45 `(align-xy ~inner ~outer ~align :top :center :bottom))
47 (defmacro decorate-layer
48 "Decorate Layer replacing render! implementation."
49 [layer & render-tail]
50 `(let [layer# ~layer]
51 (reify
52 Layer
53 (render! ~@render-tail)
54 (geometry [t#] (geometry layer#)))))
56 (defrecord Empty []
57 Layer
58 (render! [_])
59 (geometry [_]
60 (->Size 0 0)))
62 (def empty-layer (->Empty))
64 (defn padding
65 "Decorates layer adding padding."
66 ([content pad]
67 (padding content pad pad pad pad))
68 ([content top left bottom right]
69 (if (== 0 top left bottom right)
70 content
71 (reify
72 Layer
73 (render! [l]
74 (draw! content
75 left top
76 (- *width* left right)
77 (- *height* top bottom)
78 false))
79 (geometry [l]
80 (->NestedGeometry (geometry content) top left bottom right))))))
82 (defn border
83 "Decorate layer with a border."
84 ([content]
85 (border content 1))
86 ([content thikness]
87 (border content thikness 0))
88 ([content thikness gap]
89 (let [layer (padding content (+ thikness gap))
90 t (double thikness)]
91 (decorate-layer layer [_]
92 (render! layer)
93 (with-color :border-color
94 (let [w (double *width*)
95 h (double *height*)
96 outer (Area. (Rectangle2D$Double. 0.0 0.0 w h))
97 inner (Area. (Rectangle2D$Double. t t (- w t t) (- h t t)))]
98 (.subtract outer inner)
99 (.fill *graphics* outer)))))))
101 ;; TODO: opacity and blur.
102 (defn shadow
103 "Add shadow to content layer."
104 ([content]
105 (shadow content 1 1))
106 ([content x-offset y-offset]
107 (let [x (if (neg? x-offset) (- x-offset) 0)
108 y (if (neg? y-offset) (- y-offset) 0)
109 abs-x (if (neg? x-offset) (- x-offset) x-offset)
110 abs-y (if (neg? y-offset) (- y-offset) y-offset)
111 shadow-x (+ x-offset x)
112 shadow-y (+ y-offset y)]
113 (reify
114 Layer
115 (render! [_]
116 (let [w (- *width* abs-x)
117 h (- *height* abs-y)]
118 (with-color :shadow-color
119 (.fillRect *graphics* shadow-x shadow-y w h))
120 (draw! content x y w h)))
121 (geometry [_]
122 (->NestedGeometry (geometry content)
123 y x shadow-y shadow-x))))))
125 (defn panel
126 "Opaque layer using theme's alt-back-color."
127 ([content]
128 (panel content 0))
129 ([content gap]
130 (panel content gap gap gap gap))
131 ([content top left bottom right]
132 (let [layer (padding content top left bottom right)]
133 (decorate-layer layer [_]
134 (with-color :alt-back-color
135 (.fill *graphics* (Rectangle2D$Double. 0.0 0.0 *width* *height*)))
136 (render! layer)))))
138 (defn hbox
139 "Creates layer that draws the specified content layers placing them
140 horizontally."
141 [& contents]
142 (reify
143 Layer
144 (render! [_]
145 (let [widths (map #(width (geometry %)) contents)
146 xs (cons 0 (reductions + widths))
147 widths-sum (last xs)
148 scale (/ *width* widths-sum)]
149 (doseq [[c w x] (map vector contents widths xs)]
150 (draw! c x 0 w *height*))))
151 (geometry [_]
152 (reduce #(->Size (+ (width %1) (width %2))
153 (max (height %1) (height %2)))
154 (->Size 0 0)
155 (map geometry contents)))))
157 (defn vbox
158 "Creates layer that draws the specified content layers placing them
159 vertically."
160 [& contents]
161 (reify
162 Layer
163 (render! [_]
164 (let [heights (map #(height (geometry %)) contents)
165 ys (cons 0 (reductions + heights))
166 heights-sum (last ys)
167 scale (/ *height* heights-sum)]
168 (doseq [[c h y] (map vector contents heights ys)]
169 (draw! c 0 y *width* h))))
170 (geometry [_]
171 (reduce #(->Size (max (width %1) (width %2))
172 (+ (height %1) (height %2)))
173 (->Size 0 0)
174 (map geometry contents)))))
176 (defn- re-split [^java.util.regex.Pattern re s]
177 (seq (.split re s)))
179 (def ^:private ^Cache text-layout-cache
180 (-> (CacheBuilder/newBuilder)
181 (.softValues)
182 (.expireAfterAccess (long 1) TimeUnit/SECONDS)
183 (.build)))
185 (defn- get-text-layout
186 [^String line ^Font font ^FontRenderContext font-context]
187 (.get text-layout-cache [line font font-context]
188 #(TextLayout. line font font-context)))
190 (defn- layout-text
191 [lines font font-context]
192 (map #(get-text-layout % font font-context) lines))
194 (defn- text-width [layouts]
195 (reduce (fn [w ^TextLayout tl] (max w (.getAdvance tl))) 0 layouts))
197 (defn- text-height [layouts]
198 (reduce (fn [w ^TextLayout tl]
199 (+ w (.getAscent tl)
200 (.getDescent tl)
201 (.getLeading tl)))
202 0 layouts))
204 (defn label
205 "Creates a layer to display multiline text."
206 ([text]
207 (label text :left :top))
208 ([text h-align v-align]
209 (let [lines (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" (str text))]
210 (reify Layer
211 (render! [layer]
212 (let [w *width*
213 h *height*
214 font (.getFont *graphics*)
215 layouts (layout-text lines font (font-context))
216 y (align-y (text-height layouts) h v-align)]
217 (loop [layouts layouts, y y]
218 (when-first [^TextLayout layout layouts]
219 (let [ascent (.getAscent layout)
220 lh (+ ascent (.getDescent layout) (.getLeading layout))
221 x (align-x (.getAdvance layout) w h-align)]
222 (.draw layout *graphics* x (+ y ascent))
223 (recur (next layouts) (+ y lh)))))))
224 (geometry [layer]
225 (let [layouts (layout-text lines (:font *theme*) (font-context))
226 w (text-width layouts)
227 h (text-height layouts)]
228 (->Size w h)))))))
230 (defn- ^ImageObserver image-observer [layer]
231 (reify
232 ImageObserver
233 (imageUpdate [this img infoflags x y width height]
234 (update layer)
235 (zero? (bit-and infoflags
236 (bit-or ImageObserver/ALLBITS
237 ImageObserver/ABORT))))))
239 (defn image-layer
240 [image-or-uri]
241 (let [^Image image (if (instance? Image image-or-uri)
242 image-or-uri
243 (.getImage (Toolkit/getDefaultToolkit)
244 ^java.net.URL image-or-uri))]
245 (.prepareImage (Toolkit/getDefaultToolkit) image -1 -1 nil)
246 (reify
247 Layer
248 (render! [layer]
249 (repaint-on-update layer)
250 (.drawImage *graphics* image 0 0 (image-observer layer)))
251 (geometry [layer]
252 (let [observer (image-observer layer)
253 width (.getWidth image observer)
254 height (.getHeight image observer)
255 width (if (pos? width) width 1)
256 height (if (pos? height) height 1)]
257 (->Size width height))))))
259 (def ^:dynamic *miniature-thread-priority* 2)
261 (defn ref-layer
262 [layer-ref]
263 (let [l (reify
264 Layer
265 (render! [l]
266 (repaint-on-update l)
267 (if-let [layer @layer-ref]
268 (render! layer)))
269 (geometry [_]
270 (if-let [layer @layer-ref]
271 (geometry layer)
272 (->Size 1 1))))]
273 (add-watch layer-ref l (fn [_ _ _ _] (update l)))
274 l))
276 ;;
277 ;; Layer context decorators.
278 ;;
280 (defmacro handler [layer & handlers]
281 "Decorate layer to handle events."
282 `(let [layer# ~layer]
283 (decorate-layer layer# [t#]
284 (with-handlers t#
285 (render! layer#)
286 ~@handlers))))
288 (defn themed [layer & map-or-keyvals]
289 (let [theme (if (== (count map-or-keyvals) 1)
290 (first map-or-keyvals)
291 (apply array-map map-or-keyvals))]
292 (reify
293 Layer
294 (render! [_]
295 (with-theme theme
296 (render! layer)))
297 (geometry [_]
298 (with-theme theme
299 (geometry layer))))))
301 (defn hinted [layer & map-or-keyvals]
302 (let [hints (if (== (count map-or-keyvals) 1)
303 (first map-or-keyvals)
304 (apply array-map map-or-keyvals))]
305 (decorate-layer layer [_]
306 (with-hints* hints render! layer))))
308 ;;
309 ;; Measuring time
310 ;;
312 (def ^:dynamic *interval*)
314 (defn interval-layer
315 "Creates layer that measures time between repaints ant draws it's
316 content with the *interval* var bound to the measured time."
317 [content]
318 (let [last-time (atom nil)]
319 (decorate-layer content [_]
320 (compare-and-set! last-time nil *time*)
321 (let [lt @last-time]
322 (binding [*interval* (if (compare-and-set! last-time lt *time*)
323 (- *time* lt)
324 0)] ; already measured on parallel thread
325 (render! content))))))
327 (defn- fps-label [text]
328 (padding (label text :right :bottom) 5))
330 (defn fps-layer
331 "Creates layer that draws content and displays
332 the frames per seconds rate."
333 [content]
334 (let [update-interval 2E8 ; 0.2 s in nanoseconds
335 frames (ref 0)
336 prev-time (ref nil)
337 display (ref (fps-label "fps n/a"))]
338 (decorate-layer content [_]
339 (draw! content)
340 (draw!
341 (dosync
342 (alter frames inc)
343 (if @prev-time
344 (let [elapsed (- *time* @prev-time)]
345 (when (> elapsed update-interval)
346 (let [fps (/ @frames (/ elapsed 1E9))]
347 (ref-set display (fps-label (format "%.1f" fps)))
348 (ref-set frames 0)
349 (ref-set prev-time *time*))))
350 (ref-set prev-time *time*))
351 @display)))))
353 ;;
354 ;; Overlayer.
355 ;;
357 (def ^:private ^:dynamic *above*)
359 (defn- overlay* [f & args]
360 (var-set #'*above* (conj *above* (apply partial f args))))
362 (defn- ^Point2D to-graphics-coords
363 [^AffineTransform transform x y]
364 (let [p (Point2D$Double. x y)]
365 (.transform transform p p)
366 (.transform (.createInverse (.getTransform *graphics*)) p p)
367 p))
369 (defn- draw-relative!
370 ([layer transform x y]
371 (let [p (to-graphics-coords transform x y)]
372 (draw! layer (.getX p) (.getY p))))
373 ([layer transform x y w h]
374 (let [p (to-graphics-coords transform x y)]
375 (draw! layer (.getX p) (.getY p) w h))))
377 (defn- draw-relative-aligned!
378 [layer transform h-align v-align x y]
379 (let [geom (geometry layer)
380 w (width geom)
381 h (height geom)
382 p (to-graphics-coords transform x y)
383 x (- (.getX p) (anchor-x geom h-align w))
384 y (- (.getY p) (anchor-y geom v-align h))]
385 (draw! layer x y w h)))
387 (defn overlay!
388 "Draws layer in the overlayer context above the other layers."
389 ([layer]
390 (overlay* draw-relative! layer (.getTransform *graphics*) 0 0))
391 ([layer x y]
392 (overlay* draw-relative! layer (.getTransform *graphics*) x y))
393 ([layer x y w h]
394 (overlay* draw-relative! layer (.getTransform *graphics*) x y w h)))
396 (defn overlay-aligned! [layer h-align v-align x y]
397 (overlay* draw-relative-aligned!
398 layer (.getTransform *graphics*)
399 h-align v-align x y))
401 (defn with-overlays* [rec? f & args]
402 (binding [*above* []]
403 (apply f args)
404 (if rec?
405 (loop [above *above*]
406 (when (seq above)
407 (var-set #'*above* [])
408 (doseq [f above]
409 (f))
410 (recur *above*)))
411 (doseq [of *above*]
412 (of)))))
414 (defmacro with-overlays [rec? & body]
415 `(with-overlays* ~rec? (fn [] ~@body)))
417 (defn overlayer
418 ([content]
419 (overlayer content true))
420 ([content rec?]
421 (decorate-layer content [_]
422 (with-overlays* rec? render! content))))