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