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