Mercurial > hg > indyvon
view src/net/kryshen/indyvon/layers.clj @ 105:24e98602b37e
Use Guava MapMaker to cache text layouts.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Tue, 24 May 2011 18:43:49 +0400 |
| parents | 9b81174f0511 |
| children | f42e2b9e1ad9 |
line source
1 ;;
2 ;; Copyright 2010, 2011 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 (net.kryshen.indyvon.core Size Location)
26 (java.lang.ref SoftReference)
27 (java.awt Font Cursor Image Toolkit Point)
28 java.awt.image.ImageObserver
29 (java.awt.geom AffineTransform Point2D$Double)
30 (java.awt.font FontRenderContext TextLayout)
31 java.util.concurrent.TimeUnit
32 com.google.common.collect.MapMaker
33 com.google.common.base.Function))
35 ;; Define as macro to avoid unnecessary calculation of inner and outer
36 ;; sizes in the first case.
37 (defmacro align-xy [inner outer align first center last]
38 `(case ~align
39 ~first 0
40 ~center (/ (- ~outer ~inner) 2)
41 ~last (- ~outer ~inner)))
43 (defmacro align-x [inner outer align]
44 `(align-xy ~inner ~outer ~align :left :center :right))
46 (defmacro align-y [inner outer align]
47 `(align-xy ~inner ~outer ~align :top :center :bottom))
49 (defmacro decorate-layer
50 "Decorate Layer and Anchored replacing render! implementation."
51 [layer & render-tail]
52 `(reify
53 Layer
54 (render! ~@render-tail)
55 (layer-size [t#] (layer-size ~layer))
56 Anchored
57 (anchor [t# xa# ya#] (anchor ~layer xa# ya#))))
59 (defn padding
60 "Decorates layer adding padding."
61 ([content pad]
62 (padding content pad pad pad pad))
63 ([content top left bottom right]
64 (if (== 0 top left bottom right)
65 content
66 (reify
67 Layer
68 (render! [l]
69 (draw! content
70 left top
71 (- *width* left right)
72 (- *height* top bottom)))
73 (layer-size [l]
74 (let [s (layer-size content)]
75 (Size. (+ (:width s) left right)
76 (+ (:height s) top bottom))))))))
78 (defn border
79 "Decorate layer with a border."
80 ([content]
81 (border content 1))
82 ([content width]
83 (border content width 0))
84 ([content width gap]
85 (let [layer (padding content (+ width gap))]
86 (decorate-layer layer [_]
87 (let [bw (int width)
88 w (int *width*)
89 h (int *height*)
90 iw (- w bw)
91 ih (- h bw)]
92 (with-color :border-color
93 (doto *graphics*
94 (.fillRect 0 0 iw bw)
95 (.fillRect iw 0 bw ih)
96 (.fillRect bw ih iw bw)
97 (.fillRect 0 bw bw ih))))
98 (render! layer)))))
100 ;; TODO: opacity and blur.
101 (defn shadow
102 "Add shadow to content layer."
103 ([content]
104 (shadow content 1 1))
105 ([content x-offset y-offset]
106 (let [x (if (neg? x-offset) (- x-offset) 0)
107 y (if (neg? y-offset) (- y-offset) 0)
108 abs-x (if (neg? x-offset) (- x-offset) x-offset)
109 abs-y (if (neg? y-offset) (- y-offset) y-offset)
110 shadow-x (+ x-offset x)
111 shadow-y (+ y-offset y)]
112 (reify
113 ;; TODO: Anchored
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 (layer-size [_]
122 (let [s (layer-size content)]
123 (Size. (+ (:width s) abs-x)
124 (+ (:height s) abs-y))))))))
126 (defn panel
127 "Opaque layer using theme's alt-back-color."
128 ([content]
129 (panel content 0))
130 ([content gap]
131 (let [layer (padding content gap)]
132 (decorate-layer layer [_]
133 (with-color :alt-back-color
134 (.fillRect *graphics* 0 0 *width* *height*))
135 (render! layer)))))
137 (defn hbox
138 "Creates layer that draws the specified content layers placing them
139 horizontally."
140 [& contents]
141 (reify
142 Layer
143 (render! [_]
144 (let [widths (map #(:width (layer-size %)) contents)
145 xs (cons 0 (reductions + widths))
146 widths-sum (last xs)
147 scale (/ *width* widths-sum)]
148 (doseq [[c w x] (map vector contents widths xs)]
149 (draw! c x 0 w *height*))))
150 (layer-size [_]
151 (reduce #(Size. (+ (:width %1) (:width %2))
152 (max (:height %1) (:height %2)))
153 (Size. 0 0)
154 (map layer-size contents)))))
156 (defn vbox
157 "Creates layer that draws the specified content layers placing them
158 vertically."
159 [& contents]
160 (reify
161 Layer
162 (render! [_]
163 (let [heights (map #(:height (layer-size %)) contents)
164 ys (cons 0 (reductions + heights))
165 heights-sum (last ys)
166 scale (/ *height* heights-sum)]
167 (doseq [[c h y] (map vector contents heights ys)]
168 (draw! c 0 y *width* h))))
169 (layer-size [_]
170 (reduce #(Size. (max (:width %1) (:width %2))
171 (+ (:height %1) (:height %2)))
172 (Size. 0 0)
173 (map layer-size contents)))))
175 (defn- re-split [^java.util.regex.Pattern re s]
176 (seq (.split re s)))
178 (def ^{:private true} text-layout-cache
179 (-> (MapMaker.)
180 (.softValues)
181 (.expireAfterAccess (long 1) TimeUnit/SECONDS)
182 (.makeComputingMap
183 (reify Function
184 (apply [_ k]
185 (TextLayout. ^String (k 0)
186 ^Font (k 1)
187 ^FontRenderContext (k 2)))))))
189 (defn- get-text-layout [line font font-context]
190 (get text-layout-cache [line font font-context]))
192 (defn- layout-text
193 [lines ^Font font ^FontRenderContext font-context]
194 (map #(get-text-layout % font font-context) lines))
196 (defn- text-width [layouts]
197 (reduce (fn [w ^TextLayout tl] (max w (.getAdvance tl))) 0 layouts))
199 (defn- text-height [layouts]
200 (reduce (fn [w ^TextLayout tl]
201 (+ w (.getAscent tl)
202 (.getDescent tl)
203 (.getLeading tl)))
204 0 layouts))
206 (defn label
207 "Creates a layer to display multiline text."
208 ([text]
209 (label text :left :top))
210 ([text h-align v-align]
211 (let [lines (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" (str text))]
212 (reify Layer
213 (render! [layer]
214 (let [w *width*
215 h *height*
216 font (.getFont *graphics*)
217 layouts (layout-text lines font *font-context*)
218 y (align-y (text-height layouts) h v-align)]
219 (loop [layouts layouts, y y]
220 (when-first [^TextLayout layout layouts]
221 (let [ascent (.getAscent layout)
222 lh (+ ascent (.getDescent layout) (.getLeading layout))
223 x (align-x (.getAdvance layout) w h-align)]
224 (.draw layout *graphics* x (+ y ascent))
225 (recur (next layouts) (+ y lh)))))))
226 (layer-size [layer]
227 (let [layouts (layout-text lines (:font *theme*) *font-context*)
228 width (text-width layouts)
229 height (text-height layouts)]
230 (Size. width height)))))))
232 (defn- ^ImageObserver image-observer [layer]
233 (reify
234 ImageObserver
235 (imageUpdate [this img infoflags x y width height]
236 (update layer)
237 (zero? (bit-and infoflags
238 (bit-or ImageObserver/ALLBITS
239 ImageObserver/ABORT))))))
241 (defn image-layer
242 [image-or-uri]
243 (let [^Image image (if (instance? Image image-or-uri)
244 image-or-uri
245 (.getImage (Toolkit/getDefaultToolkit)
246 ^java.net.URL image-or-uri))]
247 (.prepareImage (Toolkit/getDefaultToolkit) image -1 -1 nil)
248 (reify
249 Layer
250 (render! [layer]
251 (repaint-on-update layer)
252 (.drawImage *graphics* image 0 0 (image-observer layer)))
253 (layer-size [layer]
254 (let [observer (image-observer layer)
255 width (.getWidth image observer)
256 height (.getHeight image observer)
257 width (if (pos? width) width 1)
258 height (if (pos? height) height 1)]
259 (Size. width height))))))
261 (def ^{:dynamic true} *miniature-thread-priority* 2)
263 (defn- scaling
264 [width height max-width max-height]
265 (min (/ max-width width)
266 (/ max-height height)))
268 (defn miniature
269 "Creates layer that asynchronously renders view of the content
270 scaled to the specified size."
271 [content width height]
272 (async-layer
273 (reify
274 Layer
275 (render! [this]
276 (let [size (layer-size content)
277 s (scaling (:width size) (:height size) width height)]
278 (.scale *graphics* s s)
279 (draw! content
280 (align-x (:width size) (/ width s) :center)
281 (align-y (:height size) (/ height s) :center)
282 (:width size) (:height size))))
283 (layer-size [this]
284 (Size. width height)))
285 ;; (let [size (layer-size content)
286 ;; s (scaling (:width size) (:height size) width height)]
287 ;; (Size. (* (:width size) s) (* (:height size) s)))))
288 width height *miniature-thread-priority*))
290 ;;(defn- translate [^AffineTransform transform ^double x ^double y]
291 ;; (doto ^AffineTransform (.clone transform)
292 ;; (.translate x y)))
294 (defn- scale [^AffineTransform transform ^double sx ^double sy]
295 (doto ^AffineTransform (.clone transform)
296 (.scale sx sy)))
298 (defn- pre-translate [^AffineTransform transform ^double x ^double y]
299 (if (== 0.0 x y)
300 transform
301 (doto (AffineTransform/getTranslateInstance x y)
302 (.concatenate transform))))
304 (def ^{:dynamic true} *viewport-scaling-step* (double 3/4))
305 (def ^{:dynamic true} *viewport-min-scale* 1E-6)
306 (def ^{:dynamic true} *viewport-max-scale* 1E6)
308 (defrecord Viewport [content h-align v-align
309 ;; State (refs)
310 transform
311 fix-x fix-y
312 last-width last-height last-anchor]
313 Layer
314 (render! [layer]
315 (repaint-on-update layer)
316 (with-handlers layer
317 (let [anchor (anchor content h-align v-align)]
318 (dosync
319 (let [ax1 (align-x @last-width *width* h-align)
320 ay1 (align-y @last-height *height* v-align)
321 ax2 (- (:x @last-anchor) (:x anchor))
322 ay2 (- (:y @last-anchor) (:y anchor))]
323 (if-not (and (zero? ax1) (zero? ay1) (zero? ax2) (zero? ay2))
324 (ref-set transform
325 (doto (AffineTransform/getTranslateInstance ax1 ay1)
326 (.concatenate @transform)
327 (.translate ax2 ay2)))))
328 (ref-set last-width *width*)
329 (ref-set last-height *height*)
330 (ref-set last-anchor anchor))
331 ;; TODO: notify observers when size changes.
332 (with-transform @transform
333 (draw! content 0 0 false)))
334 (:mouse-pressed e
335 (dosync
336 (ref-set fix-x (:x-on-screen e))
337 (ref-set fix-y (:y-on-screen e)))
338 (when *target*
339 (->> Cursor/MOVE_CURSOR Cursor. (.setCursor *target*))))
340 (:mouse-released e
341 (when *target*
342 (->> Cursor/DEFAULT_CURSOR Cursor. (.setCursor *target*))))
343 (:mouse-dragged e
344 (dosync
345 (alter transform pre-translate
346 (- (:x-on-screen e) @fix-x)
347 (- (:y-on-screen e) @fix-y))
348 (ref-set fix-x (:x-on-screen e))
349 (ref-set fix-y (:y-on-screen e)))
350 (update layer))
351 (:mouse-wheel e
352 (dosync
353 (let [s (Math/pow *viewport-scaling-step* (:wheel-rotation e))
354 x (- (:x e) (* (:x e) s))
355 y (- (:y e) (* (:y e) s))
356 scaled (doto (AffineTransform/getTranslateInstance x y)
357 (.scale s s)
358 (.concatenate @transform))
359 sx (.getScaleX scaled)
360 sy (.getScaleY scaled)]
361 (if (<= *viewport-min-scale*
362 (min sx sy)
363 (max sx sy)
364 *viewport-max-scale*)
365 (ref-set transform scaled))))
366 (update layer))))
367 (layer-size [layer]
368 (layer-size content)))
370 (defn viewport
371 "Creates scrollable viewport layer."
372 ([content]
373 (viewport content :left :top))
374 ([content h-align v-align]
375 (Viewport. content h-align v-align
376 (ref (AffineTransform.)) ; transform
377 (ref 0) (ref 0) ; fix-x fix-y
378 (ref 0) (ref 0) ; last-width last-height
379 (ref (Location. 0 0))))) ; last-anchor
381 (defn reset-viewport [viewport]
382 (dosync
383 (ref-set (:last-width viewport) 0)
384 (ref-set (:last-height viewport) 0)
385 (ref-set (:last-anchor viewport) (Location. 0 0))
386 (ref-set (:transform viewport) (AffineTransform.)))
387 (update viewport))
389 (defn viewport-miniature
390 "Creates miniature view of the viewport's contents."
391 [viewport width height]
392 (let [miniature (miniature (:content viewport) width height)]
393 (decorate-layer miniature [l]
394 (repaint-on-update viewport)
395 (let [size (layer-size (:content viewport))
396 s (scaling (:width size) (:height size) width height)
397 [vp-tr w h] (dosync
398 [@(:transform viewport)
399 @(:last-width viewport)
400 @(:last-height viewport)])
401 vp-inverse (.createInverse ^AffineTransform vp-tr)
402 ox (align-x (:width size) (/ width s) :center)
403 oy (align-y (:height size) (/ height s) :center)
404 transform (doto (AffineTransform.)
405 (.scale s s)
406 (.translate ox oy)
407 (.concatenate vp-inverse))
408 move-vp (fn [x y]
409 (dosync
410 (let [x (- (/ x s) ox)
411 y (- (/ y s) oy)
412 [x y] (transform-point @(:transform viewport)
413 x y)
414 x (- x (/ @(:last-width viewport) 2))
415 y (- y (/ @(:last-height viewport) 2))]
416 (alter (:transform viewport)
417 pre-translate (- x) (- y))))
418 (update viewport))]
419 (with-color :alt-back-color
420 (.fillRect *graphics* 0 0 *width* *height*))
421 (with-transform transform
422 (with-color :back-color
423 (.fillRect *graphics* 0 0 w h)))
424 (with-handlers l
425 (draw! miniature)
426 (:mouse-pressed e (move-vp (:x e) (:y e)))
427 (:mouse-dragged e (move-vp (:x e) (:y e))))
428 (with-transform transform
429 (with-color :border-color
430 (.drawRect *graphics* 0 0 w h)))))))
432 (defn ref-layer
433 [layer-ref]
434 (let [l (reify
435 Layer
436 (render! [l]
437 (repaint-on-update l)
438 (if-let [layer @layer-ref]
439 (render! layer)))
440 (layer-size [_]
441 (if-let [layer @layer-ref]
442 (layer-size layer)
443 (Size. 1 1)))
444 Anchored
445 (anchor [_ x-align y-align]
446 (if-let [layer @layer-ref]
447 (anchor layer x-align y-align)
448 (Location. 0 0))))]
449 (add-watch layer-ref l (fn [_ _ _ _] (update l)))
450 l))
452 ;;
453 ;; Layer context decorators.
454 ;;
456 (defmacro handler [layer & handlers]
457 "Decorate layer to handle events."
458 `(let [layer# ~layer]
459 (decorate-layer layer# [t#]
460 (with-handlers t#
461 (render! layer#)
462 ~@handlers))))
464 (defn themed [layer & map-or-keyvals]
465 (let [theme (if (== (count map-or-keyvals) 1)
466 (first map-or-keyvals)
467 (apply array-map map-or-keyvals))]
468 (reify
469 Layer
470 (render! [t]
471 (with-theme theme
472 (render! layer)))
473 (layer-size [t]
474 (with-theme theme
475 (layer-size layer)))
476 Anchored
477 (anchor [t xa ya]
478 (with-theme theme
479 (anchor layer xa ya))))))
481 (defn hinted [layer & map-or-keyvals]
482 (let [hints (if (== (count map-or-keyvals) 1)
483 (first map-or-keyvals)
484 (apply array-map map-or-keyvals))]
485 (decorate-layer layer [_]
486 (with-hints* hints render! layer))))
488 ;;
489 ;; Measuring time
490 ;;
492 (def ^{:dynamic true} *interval*)
494 (defn interval-layer
495 "Creates layer that measures time between repaints ant draws it's
496 content with the *interval* var bound to the measured time."
497 [content]
498 (let [last-time (atom nil)]
499 (decorate-layer content [_]
500 (compare-and-set! last-time nil *time*)
501 (let [lt @last-time]
502 (binding [*interval* (if (compare-and-set! last-time lt *time*)
503 (- *time* lt)
504 0)] ; already measured on parallel thread
505 (render! content))))))
507 (defn- fps-label [text]
508 (padding (label text :right :bottom) 5))
510 (defn fps-layer
511 "Creates layer that draws content and displays
512 the frames per seconds rate."
513 [content]
514 (let [update-interval 2E8 ; 0.2 s in nanoseconds
515 frames (ref 0)
516 prev-time (ref nil)
517 display (ref (fps-label "fps n/a"))]
518 (decorate-layer content [_]
519 (draw! content)
520 (draw!
521 (dosync
522 (alter frames inc)
523 (if @prev-time
524 (let [elapsed (- *time* @prev-time)]
525 (when (> elapsed update-interval)
526 (let [fps (/ @frames (/ elapsed 1E9))]
527 (ref-set display (fps-label (format "%.1f" fps)))
528 (ref-set frames 0)
529 (ref-set prev-time *time*))))
530 (ref-set prev-time *time*))
531 @display)))))
533 ;;
534 ;; Overlayer.
535 ;;
537 (def ^{:private true :dynamic true} *above*)
539 (defn- overlay* [f & args]
540 (var-set #'*above* (conj *above* (apply partial f args))))
542 (defn- ^Point to-graphics-coords
543 [^AffineTransform transform x y]
544 (let [p (Point. x y)]
545 (.transform transform p p)
546 (.transform (.createInverse (.getTransform *graphics*)) p p)
547 p))
549 (defn- draw-relative!
550 ([layer transform x y]
551 (let [p (to-graphics-coords transform x y)]
552 (draw! layer (.x p) (.y p))))
553 ([layer transform x y w h]
554 (let [p (to-graphics-coords transform x y)]
555 (draw! layer (.x p) (.y p) w h))))
557 (defn overlay!
558 "Draws layer in the overlayer context above the other layers."
559 ([layer]
560 (overlay* draw-relative! layer (.getTransform *graphics*) 0 0))
561 ([layer x y]
562 (overlay* draw-relative! layer (.getTransform *graphics*) x y))
563 ([layer x y w h]
564 (overlay* draw-relative! layer (.getTransform *graphics*) x y w h)))
566 (defn overlayer
567 [content]
568 (decorate-layer content [_]
569 (binding [*above* []]
570 (render! content)
571 (doseq [f *above*]
572 (f)))))