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