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