view src/net/kryshen/indyvon/layers.clj @ 107:5fdb0bb99f75

Updated dependencies: Clojure 1.3.0, Guava 10.0. Use new CacheBuilder API.
author Mikhail Kryshen <mikhail@kryshen.net>
date Thu, 06 Oct 2011 16:49:14 +0300
parents f42e2b9e1ad9
children f3dedece38f3
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 (java.lang.ref SoftReference)
26 (java.awt Font Cursor Image Toolkit Point)
27 java.awt.image.ImageObserver
28 (java.awt.geom AffineTransform 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 (defn padding
57 "Decorates layer adding padding."
58 ([content pad]
59 (padding content pad pad pad pad))
60 ([content top left bottom right]
61 (if (== 0 top left bottom right)
62 content
63 (reify
64 Layer
65 (render! [l]
66 (draw! content
67 left top
68 (- *width* left right)
69 (- *height* top bottom)))
70 (geometry [l]
71 (->NestedGeometry (geometry content) top left bottom right))))))
73 (defn border
74 "Decorate layer with a border."
75 ([content]
76 (border content 1))
77 ([content width]
78 (border content width 0))
79 ([content width gap]
80 (let [layer (padding content (+ width gap))]
81 (decorate-layer layer [_]
82 (let [bw (int width)
83 w (int *width*)
84 h (int *height*)
85 iw (- w bw)
86 ih (- h bw)]
87 (with-color :border-color
88 (doto *graphics*
89 (.fillRect 0 0 iw bw)
90 (.fillRect iw 0 bw ih)
91 (.fillRect bw ih iw bw)
92 (.fillRect 0 bw bw ih))))
93 (render! layer)))))
95 ;; TODO: opacity and blur.
96 (defn shadow
97 "Add shadow to content layer."
98 ([content]
99 (shadow content 1 1))
100 ([content x-offset y-offset]
101 (let [x (if (neg? x-offset) (- x-offset) 0)
102 y (if (neg? y-offset) (- y-offset) 0)
103 abs-x (if (neg? x-offset) (- x-offset) x-offset)
104 abs-y (if (neg? y-offset) (- y-offset) y-offset)
105 shadow-x (+ x-offset x)
106 shadow-y (+ y-offset y)]
107 (reify
108 Layer
109 (render! [_]
110 (let [w (- *width* abs-x)
111 h (- *height* abs-y)]
112 (with-color :shadow-color
113 (.fillRect *graphics* shadow-x shadow-y w h))
114 (draw! content x y w h)))
115 (geometry [_]
116 (->NestedGeometry (geometry content)
117 y x shadow-y shadow-x))))))
119 (defn panel
120 "Opaque layer using theme's alt-back-color."
121 ([content]
122 (panel content 0))
123 ([content gap]
124 (let [layer (padding content gap)]
125 (decorate-layer layer [_]
126 (with-color :alt-back-color
127 (.fillRect *graphics* 0 0 *width* *height*))
128 (render! layer)))))
130 (defn hbox
131 "Creates layer that draws the specified content layers placing them
132 horizontally."
133 [& contents]
134 (reify
135 Layer
136 (render! [_]
137 (let [widths (map #(width (geometry %)) contents)
138 xs (cons 0 (reductions + widths))
139 widths-sum (last xs)
140 scale (/ *width* widths-sum)]
141 (doseq [[c w x] (map vector contents widths xs)]
142 (draw! c x 0 w *height*))))
143 (geometry [_]
144 (reduce #(->Size (+ (width %1) (width %2))
145 (max (height %1) (height %2)))
146 (->Size 0 0)
147 (map geometry contents)))))
149 (defn vbox
150 "Creates layer that draws the specified content layers placing them
151 vertically."
152 [& contents]
153 (reify
154 Layer
155 (render! [_]
156 (let [heights (map #(height (geometry %)) contents)
157 ys (cons 0 (reductions + heights))
158 heights-sum (last ys)
159 scale (/ *height* heights-sum)]
160 (doseq [[c h y] (map vector contents heights ys)]
161 (draw! c 0 y *width* h))))
162 (geometry [_]
163 (reduce #(->Size (max (width %1) (width %2))
164 (+ (height %1) (height %2)))
165 (->Size 0 0)
166 (map geometry contents)))))
168 (defn- re-split [^java.util.regex.Pattern re s]
169 (seq (.split re s)))
171 (def ^:private ^Cache text-layout-cache
172 (-> (CacheBuilder/newBuilder)
173 (.softValues)
174 (.expireAfterAccess (long 1) TimeUnit/SECONDS)
175 (.build
176 (proxy [CacheLoader] []
177 (load [[^String s ^Font f ^FontRenderContext frc]]
178 (TextLayout. s f frc))))))
180 (defn- get-text-layout [line font font-context]
181 (.get text-layout-cache [line font font-context]))
183 (defn- layout-text
184 [lines ^Font font ^FontRenderContext font-context]
185 (map #(get-text-layout % font font-context) lines))
187 (defn- text-width [layouts]
188 (reduce (fn [w ^TextLayout tl] (max w (.getAdvance tl))) 0 layouts))
190 (defn- text-height [layouts]
191 (reduce (fn [w ^TextLayout tl]
192 (+ w (.getAscent tl)
193 (.getDescent tl)
194 (.getLeading tl)))
195 0 layouts))
197 (defn label
198 "Creates a layer to display multiline text."
199 ([text]
200 (label text :left :top))
201 ([text h-align v-align]
202 (let [lines (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" (str text))]
203 (reify Layer
204 (render! [layer]
205 (let [w *width*
206 h *height*
207 font (.getFont *graphics*)
208 layouts (layout-text lines font *font-context*)
209 y (align-y (text-height layouts) h v-align)]
210 (loop [layouts layouts, y y]
211 (when-first [^TextLayout layout layouts]
212 (let [ascent (.getAscent layout)
213 lh (+ ascent (.getDescent layout) (.getLeading layout))
214 x (align-x (.getAdvance layout) w h-align)]
215 (.draw layout *graphics* x (+ y ascent))
216 (recur (next layouts) (+ y lh)))))))
217 (geometry [layer]
218 (let [layouts (layout-text lines (:font *theme*) *font-context*)
219 w (text-width layouts)
220 h (text-height layouts)]
221 (->Size w h)))))))
223 (defn- ^ImageObserver image-observer [layer]
224 (reify
225 ImageObserver
226 (imageUpdate [this img infoflags x y width height]
227 (update layer)
228 (zero? (bit-and infoflags
229 (bit-or ImageObserver/ALLBITS
230 ImageObserver/ABORT))))))
232 (defn image-layer
233 [image-or-uri]
234 (let [^Image image (if (instance? Image image-or-uri)
235 image-or-uri
236 (.getImage (Toolkit/getDefaultToolkit)
237 ^java.net.URL image-or-uri))]
238 (.prepareImage (Toolkit/getDefaultToolkit) image -1 -1 nil)
239 (reify
240 Layer
241 (render! [layer]
242 (repaint-on-update layer)
243 (.drawImage *graphics* image 0 0 (image-observer layer)))
244 (geometry [layer]
245 (let [observer (image-observer layer)
246 width (.getWidth image observer)
247 height (.getHeight image observer)
248 width (if (pos? width) width 1)
249 height (if (pos? height) height 1)]
250 (->Size width height))))))
252 (def ^{:dynamic true} *miniature-thread-priority* 2)
254 (defn- scaling
255 [width height max-width max-height]
256 (min (/ max-width width)
257 (/ max-height height)))
259 (defn miniature
260 "Creates layer that asynchronously renders view of the content
261 scaled to the specified size."
262 [content mw mh]
263 (async-layer
264 (reify
265 Layer
266 (render! [this]
267 (let [geom (geometry content)
268 cw (width geom)
269 ch (height geom)
270 s (scaling cw ch mw mh)]
271 (.scale *graphics* s s)
272 (draw! content
273 (align-x cw (/ mw s) :center)
274 (align-y ch (/ mh s) :center)
275 cw ch)))
276 (geometry [_]
277 (->Size mw mh)))
278 mw mh *miniature-thread-priority*))
280 ;;(defn- translate [^AffineTransform transform ^double x ^double y]
281 ;; (doto ^AffineTransform (.clone transform)
282 ;; (.translate x y)))
284 (defn- scale [^AffineTransform transform ^double sx ^double sy]
285 (doto ^AffineTransform (.clone transform)
286 (.scale sx sy)))
288 (defn- pre-translate [^AffineTransform transform ^double x ^double y]
289 (if (== 0.0 x y)
290 transform
291 (doto (AffineTransform/getTranslateInstance x y)
292 (.concatenate transform))))
294 (def ^{:dynamic true} *viewport-scaling-step* (double 3/4))
295 (def ^{:dynamic true} *viewport-min-scale* 1E-6)
296 (def ^{:dynamic true} *viewport-max-scale* 1E6)
298 (defrecord Viewport [content h-align v-align
299 ;; State (refs)
300 transform
301 fix-x fix-y
302 last-width last-height
303 last-anchor-x last-anchor-y]
304 Layer
305 (render! [layer]
306 (repaint-on-update layer)
307 (with-handlers layer
308 (let [geom (geometry content)
309 cw (width geom)
310 ch (height geom)
311 ax (anchor-x geom h-align cw)
312 ay (anchor-y geom v-align ch)]
313 (dosync
314 (let [ax1 (align-x @last-width *width* h-align)
315 ay1 (align-y @last-height *height* v-align)
316 ax2 (- @last-anchor-x ax)
317 ay2 (- @last-anchor-y ay)]
318 (if-not (and (zero? ax1) (zero? ay1) (zero? ax2) (zero? ay2))
319 (ref-set transform
320 (doto (AffineTransform/getTranslateInstance ax1 ay1)
321 (.concatenate @transform)
322 (.translate ax2 ay2)))))
323 (ref-set last-width *width*)
324 (ref-set last-height *height*)
325 (ref-set last-anchor-x ax)
326 (ref-set last-anchor-y ay))
327 ;; TODO: notify observers when size changes.
328 (with-transform @transform
329 (draw! content 0 0 cw ch false)))
330 (:mouse-pressed e
331 (dosync
332 (ref-set fix-x (:x-on-screen e))
333 (ref-set fix-y (:y-on-screen e)))
334 (when *target*
335 (->> Cursor/MOVE_CURSOR Cursor. (.setCursor *target*))))
336 (:mouse-released e
337 (when *target*
338 (->> Cursor/DEFAULT_CURSOR Cursor. (.setCursor *target*))))
339 (:mouse-dragged e
340 (dosync
341 (alter transform pre-translate
342 (- (:x-on-screen e) @fix-x)
343 (- (:y-on-screen e) @fix-y))
344 (ref-set fix-x (:x-on-screen e))
345 (ref-set fix-y (:y-on-screen e)))
346 (update layer))
347 (:mouse-wheel e
348 (dosync
349 (let [s (Math/pow *viewport-scaling-step* (:wheel-rotation e))
350 x (- (:x e) (* (:x e) s))
351 y (- (:y e) (* (:y e) s))
352 scaled (doto (AffineTransform/getTranslateInstance x y)
353 (.scale s s)
354 (.concatenate @transform))
355 sx (.getScaleX scaled)
356 sy (.getScaleY scaled)]
357 (if (<= *viewport-min-scale*
358 (min sx sy)
359 (max sx sy)
360 *viewport-max-scale*)
361 (ref-set transform scaled))))
362 (update layer))))
363 (geometry [_]
364 (geometry content)))
366 (defn viewport
367 "Creates scrollable viewport layer."
368 ([content]
369 (viewport content :left :top))
370 ([content h-align v-align]
371 (Viewport. content h-align v-align
372 (ref (AffineTransform.)) ; transform
373 (ref 0) (ref 0) ; fix-x fix-y
374 (ref 0) (ref 0) ; last-width last-height
375 (ref 0) (ref 0)))) ; last-anchor-x last-anchor-y
377 (defn reset-viewport [viewport]
378 (dosync
379 (ref-set (:last-width viewport) 0)
380 (ref-set (:last-height viewport) 0)
381 (ref-set (:last-anchor-x viewport) 0)
382 (ref-set (:last-anchor-y viewport) 0)
383 (ref-set (:transform viewport) (AffineTransform.)))
384 (update viewport))
386 (defn viewport-miniature
387 "Creates miniature view of the viewport's contents."
388 [viewport m-width m-height]
389 (let [miniature (miniature (:content viewport) m-width m-height)]
390 (decorate-layer miniature [l]
391 (repaint-on-update viewport)
392 (let [geom (geometry (:content viewport))
393 s (scaling (width geom) (height geom) m-width m-height)
394 [vp-tr w h] (dosync
395 [@(:transform viewport)
396 @(:last-width viewport)
397 @(:last-height viewport)])
398 vp-inverse (.createInverse ^AffineTransform vp-tr)
399 ox (align-x (width geom) (/ m-width s) :center)
400 oy (align-y (height geom) (/ m-height s) :center)
401 transform (doto (AffineTransform.)
402 (.scale s s)
403 (.translate ox oy)
404 (.concatenate vp-inverse))
405 move-vp (fn [x y]
406 (dosync
407 (let [x (- (/ x s) ox)
408 y (- (/ y s) oy)
409 [x y] (transform-point @(:transform viewport)
410 x y)
411 x (- x (/ @(:last-width viewport) 2))
412 y (- y (/ @(:last-height viewport) 2))]
413 (alter (:transform viewport)
414 pre-translate (- x) (- y))))
415 (update viewport))]
416 (with-color :alt-back-color
417 (.fillRect *graphics* 0 0 *width* *height*))
418 (with-transform transform
419 (with-color :back-color
420 (.fillRect *graphics* 0 0 w h)))
421 (with-handlers l
422 (draw! miniature)
423 (:mouse-pressed e (move-vp (:x e) (:y e)))
424 (:mouse-dragged e (move-vp (:x e) (:y e))))
425 (with-transform transform
426 (with-color :border-color
427 (.drawRect *graphics* 0 0 w h)))))))
429 (defn ref-layer
430 [layer-ref]
431 (let [l (reify
432 Layer
433 (render! [l]
434 (repaint-on-update l)
435 (if-let [layer @layer-ref]
436 (render! layer)))
437 (geometry [_]
438 (if-let [layer @layer-ref]
439 (geometry layer)
440 (->Size 1 1))))]
441 (add-watch layer-ref l (fn [_ _ _ _] (update l)))
442 l))
444 ;;
445 ;; Layer context decorators.
446 ;;
448 (defmacro handler [layer & handlers]
449 "Decorate layer to handle events."
450 `(let [layer# ~layer]
451 (decorate-layer layer# [t#]
452 (with-handlers t#
453 (render! layer#)
454 ~@handlers))))
456 (defn themed [layer & map-or-keyvals]
457 (let [theme (if (== (count map-or-keyvals) 1)
458 (first map-or-keyvals)
459 (apply array-map map-or-keyvals))]
460 (reify
461 Layer
462 (render! [_]
463 (with-theme theme
464 (render! layer)))
465 (geometry [_]
466 (with-theme theme
467 (geometry layer))))))
469 (defn hinted [layer & map-or-keyvals]
470 (let [hints (if (== (count map-or-keyvals) 1)
471 (first map-or-keyvals)
472 (apply array-map map-or-keyvals))]
473 (decorate-layer layer [_]
474 (with-hints* hints render! layer))))
476 ;;
477 ;; Measuring time
478 ;;
480 (def ^{:dynamic true} *interval*)
482 (defn interval-layer
483 "Creates layer that measures time between repaints ant draws it's
484 content with the *interval* var bound to the measured time."
485 [content]
486 (let [last-time (atom nil)]
487 (decorate-layer content [_]
488 (compare-and-set! last-time nil *time*)
489 (let [lt @last-time]
490 (binding [*interval* (if (compare-and-set! last-time lt *time*)
491 (- *time* lt)
492 0)] ; already measured on parallel thread
493 (render! content))))))
495 (defn- fps-label [text]
496 (padding (label text :right :bottom) 5))
498 (defn fps-layer
499 "Creates layer that draws content and displays
500 the frames per seconds rate."
501 [content]
502 (let [update-interval 2E8 ; 0.2 s in nanoseconds
503 frames (ref 0)
504 prev-time (ref nil)
505 display (ref (fps-label "fps n/a"))]
506 (decorate-layer content [_]
507 (draw! content)
508 (draw!
509 (dosync
510 (alter frames inc)
511 (if @prev-time
512 (let [elapsed (- *time* @prev-time)]
513 (when (> elapsed update-interval)
514 (let [fps (/ @frames (/ elapsed 1E9))]
515 (ref-set display (fps-label (format "%.1f" fps)))
516 (ref-set frames 0)
517 (ref-set prev-time *time*))))
518 (ref-set prev-time *time*))
519 @display)))))
521 ;;
522 ;; Overlayer.
523 ;;
525 (def ^{:private true :dynamic true} *above*)
527 (defn- overlay* [f & args]
528 (var-set #'*above* (conj *above* (apply partial f args))))
530 (defn- ^Point to-graphics-coords
531 [^AffineTransform transform x y]
532 (let [p (Point. x y)]
533 (.transform transform p p)
534 (.transform (.createInverse (.getTransform *graphics*)) p p)
535 p))
537 (defn- draw-relative!
538 ([layer transform x y]
539 (let [p (to-graphics-coords transform x y)]
540 (draw! layer (.x p) (.y p))))
541 ([layer transform x y w h]
542 (let [p (to-graphics-coords transform x y)]
543 (draw! layer (.x p) (.y p) w h))))
545 (defn- draw-relative-aligned!
546 [layer transform h-align v-align x y]
547 (let [geom (geometry layer)
548 w (width geom)
549 h (height geom)
550 p (to-graphics-coords transform x y)
551 x (- (.x p) (anchor-x geom h-align w))
552 y (- (.y p) (anchor-y geom v-align h))]
553 (draw! layer x y w h)))
555 (defn overlay!
556 "Draws layer in the overlayer context above the other layers."
557 ([layer]
558 (overlay* draw-relative! layer (.getTransform *graphics*) 0 0))
559 ([layer x y]
560 (overlay* draw-relative! layer (.getTransform *graphics*) x y))
561 ([layer x y w h]
562 (overlay* draw-relative! layer (.getTransform *graphics*) x y w h)))
564 (defn overlay-aligned! [layer h-align v-align x y]
565 (overlay* draw-relative-aligned!
566 layer (.getTransform *graphics*)
567 h-align v-align x y))
569 (defn overlayer
570 [content]
571 (decorate-layer content [_]
572 (binding [*above* []]
573 (render! content)
574 (doseq [f *above*]
575 (f)))))
577 (defn overlayer*
578 [content]
579 (decorate-layer content [_]
580 (binding [*above* []]
581 (render! content)
582 (loop [above *above*]
583 (when (seq above)
584 (var-set #'*above* [])
585 (doseq [f above]
586 (f))
587 (recur *above*))))))