Mercurial > hg > indyvon
view src/net/kryshen/indyvon/layers.clj @ 106:f42e2b9e1ad9
Removed Anchored protocol, "layer-size" function in Layer replaced with "geometry" which returns a structure describing both layer size and anchor point.
Indyvon now requires Clojure 1.3.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Wed, 21 Sep 2011 02:27:11 +0300 |
| parents | 24e98602b37e |
| children | 5fdb0bb99f75 |
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.collect.MapMaker
32 com.google.common.base.Function))
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 (defn padding
58 "Decorates layer adding padding."
59 ([content pad]
60 (padding content pad pad pad pad))
61 ([content top left bottom right]
62 (if (== 0 top left bottom right)
63 content
64 (reify
65 Layer
66 (render! [l]
67 (draw! content
68 left top
69 (- *width* left right)
70 (- *height* top bottom)))
71 (geometry [l]
72 (->NestedGeometry (geometry content) top left bottom right))))))
74 (defn border
75 "Decorate layer with a border."
76 ([content]
77 (border content 1))
78 ([content width]
79 (border content width 0))
80 ([content width gap]
81 (let [layer (padding content (+ width gap))]
82 (decorate-layer layer [_]
83 (let [bw (int width)
84 w (int *width*)
85 h (int *height*)
86 iw (- w bw)
87 ih (- h bw)]
88 (with-color :border-color
89 (doto *graphics*
90 (.fillRect 0 0 iw bw)
91 (.fillRect iw 0 bw ih)
92 (.fillRect bw ih iw bw)
93 (.fillRect 0 bw bw ih))))
94 (render! layer)))))
96 ;; TODO: opacity and blur.
97 (defn shadow
98 "Add shadow to content layer."
99 ([content]
100 (shadow content 1 1))
101 ([content x-offset y-offset]
102 (let [x (if (neg? x-offset) (- x-offset) 0)
103 y (if (neg? y-offset) (- y-offset) 0)
104 abs-x (if (neg? x-offset) (- x-offset) x-offset)
105 abs-y (if (neg? y-offset) (- y-offset) y-offset)
106 shadow-x (+ x-offset x)
107 shadow-y (+ y-offset y)]
108 (reify
109 Layer
110 (render! [_]
111 (let [w (- *width* abs-x)
112 h (- *height* abs-y)]
113 (with-color :shadow-color
114 (.fillRect *graphics* shadow-x shadow-y w h))
115 (draw! content x y w h)))
116 (geometry [_]
117 (->NestedGeometry (geometry content)
118 y x shadow-y shadow-x))))))
120 (defn panel
121 "Opaque layer using theme's alt-back-color."
122 ([content]
123 (panel content 0))
124 ([content gap]
125 (let [layer (padding content gap)]
126 (decorate-layer layer [_]
127 (with-color :alt-back-color
128 (.fillRect *graphics* 0 0 *width* *height*))
129 (render! layer)))))
131 (defn hbox
132 "Creates layer that draws the specified content layers placing them
133 horizontally."
134 [& contents]
135 (reify
136 Layer
137 (render! [_]
138 (let [widths (map #(width (geometry %)) contents)
139 xs (cons 0 (reductions + widths))
140 widths-sum (last xs)
141 scale (/ *width* widths-sum)]
142 (doseq [[c w x] (map vector contents widths xs)]
143 (draw! c x 0 w *height*))))
144 (geometry [_]
145 (reduce #(->Size (+ (width %1) (width %2))
146 (max (height %1) (height %2)))
147 (->Size 0 0)
148 (map geometry contents)))))
150 (defn vbox
151 "Creates layer that draws the specified content layers placing them
152 vertically."
153 [& contents]
154 (reify
155 Layer
156 (render! [_]
157 (let [heights (map #(height (geometry %)) contents)
158 ys (cons 0 (reductions + heights))
159 heights-sum (last ys)
160 scale (/ *height* heights-sum)]
161 (doseq [[c h y] (map vector contents heights ys)]
162 (draw! c 0 y *width* h))))
163 (geometry [_]
164 (reduce #(->Size (max (width %1) (width %2))
165 (+ (height %1) (height %2)))
166 (->Size 0 0)
167 (map geometry contents)))))
169 (defn- re-split [^java.util.regex.Pattern re s]
170 (seq (.split re s)))
172 (def ^{:private true} text-layout-cache
173 (-> (MapMaker.)
174 (.softValues)
175 (.expireAfterAccess (long 1) TimeUnit/SECONDS)
176 (.makeComputingMap
177 (reify Function
178 (apply [_ k]
179 (TextLayout. ^String (k 0)
180 ^Font (k 1)
181 ^FontRenderContext (k 2)))))))
183 (defn- get-text-layout [line font font-context]
184 (get text-layout-cache [line font font-context]))
186 (defn- layout-text
187 [lines ^Font font ^FontRenderContext font-context]
188 (map #(get-text-layout % font font-context) lines))
190 (defn- text-width [layouts]
191 (reduce (fn [w ^TextLayout tl] (max w (.getAdvance tl))) 0 layouts))
193 (defn- text-height [layouts]
194 (reduce (fn [w ^TextLayout tl]
195 (+ w (.getAscent tl)
196 (.getDescent tl)
197 (.getLeading tl)))
198 0 layouts))
200 (defn label
201 "Creates a layer to display multiline text."
202 ([text]
203 (label text :left :top))
204 ([text h-align v-align]
205 (let [lines (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" (str text))]
206 (reify Layer
207 (render! [layer]
208 (let [w *width*
209 h *height*
210 font (.getFont *graphics*)
211 layouts (layout-text lines font *font-context*)
212 y (align-y (text-height layouts) h v-align)]
213 (loop [layouts layouts, y y]
214 (when-first [^TextLayout layout layouts]
215 (let [ascent (.getAscent layout)
216 lh (+ ascent (.getDescent layout) (.getLeading layout))
217 x (align-x (.getAdvance layout) w h-align)]
218 (.draw layout *graphics* x (+ y ascent))
219 (recur (next layouts) (+ y lh)))))))
220 (geometry [layer]
221 (let [layouts (layout-text lines (:font *theme*) *font-context*)
222 w (text-width layouts)
223 h (text-height layouts)]
224 (->Size w h)))))))
226 (defn- ^ImageObserver image-observer [layer]
227 (reify
228 ImageObserver
229 (imageUpdate [this img infoflags x y width height]
230 (update layer)
231 (zero? (bit-and infoflags
232 (bit-or ImageObserver/ALLBITS
233 ImageObserver/ABORT))))))
235 (defn image-layer
236 [image-or-uri]
237 (let [^Image image (if (instance? Image image-or-uri)
238 image-or-uri
239 (.getImage (Toolkit/getDefaultToolkit)
240 ^java.net.URL image-or-uri))]
241 (.prepareImage (Toolkit/getDefaultToolkit) image -1 -1 nil)
242 (reify
243 Layer
244 (render! [layer]
245 (repaint-on-update layer)
246 (.drawImage *graphics* image 0 0 (image-observer layer)))
247 (geometry [layer]
248 (let [observer (image-observer layer)
249 width (.getWidth image observer)
250 height (.getHeight image observer)
251 width (if (pos? width) width 1)
252 height (if (pos? height) height 1)]
253 (->Size width height))))))
255 (def ^{:dynamic true} *miniature-thread-priority* 2)
257 (defn- scaling
258 [width height max-width max-height]
259 (min (/ max-width width)
260 (/ max-height height)))
262 (defn miniature
263 "Creates layer that asynchronously renders view of the content
264 scaled to the specified size."
265 [content mw mh]
266 (async-layer
267 (reify
268 Layer
269 (render! [this]
270 (let [geom (geometry content)
271 cw (width geom)
272 ch (height geom)
273 s (scaling cw ch mw mh)]
274 (.scale *graphics* s s)
275 (draw! content
276 (align-x cw (/ mw s) :center)
277 (align-y ch (/ mh s) :center)
278 cw ch)))
279 (geometry [_]
280 (->Size mw mh)))
281 mw mh *miniature-thread-priority*))
283 ;;(defn- translate [^AffineTransform transform ^double x ^double y]
284 ;; (doto ^AffineTransform (.clone transform)
285 ;; (.translate x y)))
287 (defn- scale [^AffineTransform transform ^double sx ^double sy]
288 (doto ^AffineTransform (.clone transform)
289 (.scale sx sy)))
291 (defn- pre-translate [^AffineTransform transform ^double x ^double y]
292 (if (== 0.0 x y)
293 transform
294 (doto (AffineTransform/getTranslateInstance x y)
295 (.concatenate transform))))
297 (def ^{:dynamic true} *viewport-scaling-step* (double 3/4))
298 (def ^{:dynamic true} *viewport-min-scale* 1E-6)
299 (def ^{:dynamic true} *viewport-max-scale* 1E6)
301 (defrecord Viewport [content h-align v-align
302 ;; State (refs)
303 transform
304 fix-x fix-y
305 last-width last-height
306 last-anchor-x last-anchor-y]
307 Layer
308 (render! [layer]
309 (repaint-on-update layer)
310 (with-handlers layer
311 (let [geom (geometry content)
312 cw (width geom)
313 ch (height geom)
314 ax (anchor-x geom h-align cw)
315 ay (anchor-y geom v-align ch)]
316 (dosync
317 (let [ax1 (align-x @last-width *width* h-align)
318 ay1 (align-y @last-height *height* v-align)
319 ax2 (- @last-anchor-x ax)
320 ay2 (- @last-anchor-y ay)]
321 (if-not (and (zero? ax1) (zero? ay1) (zero? ax2) (zero? ay2))
322 (ref-set transform
323 (doto (AffineTransform/getTranslateInstance ax1 ay1)
324 (.concatenate @transform)
325 (.translate ax2 ay2)))))
326 (ref-set last-width *width*)
327 (ref-set last-height *height*)
328 (ref-set last-anchor-x ax)
329 (ref-set last-anchor-y ay))
330 ;; TODO: notify observers when size changes.
331 (with-transform @transform
332 (draw! content 0 0 cw ch false)))
333 (:mouse-pressed e
334 (dosync
335 (ref-set fix-x (:x-on-screen e))
336 (ref-set fix-y (:y-on-screen e)))
337 (when *target*
338 (->> Cursor/MOVE_CURSOR Cursor. (.setCursor *target*))))
339 (:mouse-released e
340 (when *target*
341 (->> Cursor/DEFAULT_CURSOR Cursor. (.setCursor *target*))))
342 (:mouse-dragged e
343 (dosync
344 (alter transform pre-translate
345 (- (:x-on-screen e) @fix-x)
346 (- (:y-on-screen e) @fix-y))
347 (ref-set fix-x (:x-on-screen e))
348 (ref-set fix-y (:y-on-screen e)))
349 (update layer))
350 (:mouse-wheel e
351 (dosync
352 (let [s (Math/pow *viewport-scaling-step* (:wheel-rotation e))
353 x (- (:x e) (* (:x e) s))
354 y (- (:y e) (* (:y e) s))
355 scaled (doto (AffineTransform/getTranslateInstance x y)
356 (.scale s s)
357 (.concatenate @transform))
358 sx (.getScaleX scaled)
359 sy (.getScaleY scaled)]
360 (if (<= *viewport-min-scale*
361 (min sx sy)
362 (max sx sy)
363 *viewport-max-scale*)
364 (ref-set transform scaled))))
365 (update layer))))
366 (geometry [_]
367 (geometry content)))
369 (defn viewport
370 "Creates scrollable viewport layer."
371 ([content]
372 (viewport content :left :top))
373 ([content h-align v-align]
374 (Viewport. content h-align v-align
375 (ref (AffineTransform.)) ; transform
376 (ref 0) (ref 0) ; fix-x fix-y
377 (ref 0) (ref 0) ; last-width last-height
378 (ref 0) (ref 0)))) ; last-anchor-x last-anchor-y
380 (defn reset-viewport [viewport]
381 (dosync
382 (ref-set (:last-width viewport) 0)
383 (ref-set (:last-height viewport) 0)
384 (ref-set (:last-anchor-x viewport) 0)
385 (ref-set (:last-anchor-y viewport) 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 m-width m-height]
392 (let [miniature (miniature (:content viewport) m-width m-height)]
393 (decorate-layer miniature [l]
394 (repaint-on-update viewport)
395 (let [geom (geometry (:content viewport))
396 s (scaling (width geom) (height geom) m-width m-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 geom) (/ m-width s) :center)
403 oy (align-y (height geom) (/ m-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 (geometry [_]
441 (if-let [layer @layer-ref]
442 (geometry layer)
443 (->Size 1 1))))]
444 (add-watch layer-ref l (fn [_ _ _ _] (update l)))
445 l))
447 ;;
448 ;; Layer context decorators.
449 ;;
451 (defmacro handler [layer & handlers]
452 "Decorate layer to handle events."
453 `(let [layer# ~layer]
454 (decorate-layer layer# [t#]
455 (with-handlers t#
456 (render! layer#)
457 ~@handlers))))
459 (defn themed [layer & map-or-keyvals]
460 (let [theme (if (== (count map-or-keyvals) 1)
461 (first map-or-keyvals)
462 (apply array-map map-or-keyvals))]
463 (reify
464 Layer
465 (render! [_]
466 (with-theme theme
467 (render! layer)))
468 (geometry [_]
469 (with-theme theme
470 (geometry layer))))))
472 (defn hinted [layer & map-or-keyvals]
473 (let [hints (if (== (count map-or-keyvals) 1)
474 (first map-or-keyvals)
475 (apply array-map map-or-keyvals))]
476 (decorate-layer layer [_]
477 (with-hints* hints render! layer))))
479 ;;
480 ;; Measuring time
481 ;;
483 (def ^{:dynamic true} *interval*)
485 (defn interval-layer
486 "Creates layer that measures time between repaints ant draws it's
487 content with the *interval* var bound to the measured time."
488 [content]
489 (let [last-time (atom nil)]
490 (decorate-layer content [_]
491 (compare-and-set! last-time nil *time*)
492 (let [lt @last-time]
493 (binding [*interval* (if (compare-and-set! last-time lt *time*)
494 (- *time* lt)
495 0)] ; already measured on parallel thread
496 (render! content))))))
498 (defn- fps-label [text]
499 (padding (label text :right :bottom) 5))
501 (defn fps-layer
502 "Creates layer that draws content and displays
503 the frames per seconds rate."
504 [content]
505 (let [update-interval 2E8 ; 0.2 s in nanoseconds
506 frames (ref 0)
507 prev-time (ref nil)
508 display (ref (fps-label "fps n/a"))]
509 (decorate-layer content [_]
510 (draw! content)
511 (draw!
512 (dosync
513 (alter frames inc)
514 (if @prev-time
515 (let [elapsed (- *time* @prev-time)]
516 (when (> elapsed update-interval)
517 (let [fps (/ @frames (/ elapsed 1E9))]
518 (ref-set display (fps-label (format "%.1f" fps)))
519 (ref-set frames 0)
520 (ref-set prev-time *time*))))
521 (ref-set prev-time *time*))
522 @display)))))
524 ;;
525 ;; Overlayer.
526 ;;
528 (def ^{:private true :dynamic true} *above*)
530 (defn- overlay* [f & args]
531 (var-set #'*above* (conj *above* (apply partial f args))))
533 (defn- ^Point to-graphics-coords
534 [^AffineTransform transform x y]
535 (let [p (Point. x y)]
536 (.transform transform p p)
537 (.transform (.createInverse (.getTransform *graphics*)) p p)
538 p))
540 (defn- draw-relative!
541 ([layer transform x y]
542 (let [p (to-graphics-coords transform x y)]
543 (draw! layer (.x p) (.y p))))
544 ([layer transform x y w h]
545 (let [p (to-graphics-coords transform x y)]
546 (draw! layer (.x p) (.y p) w h))))
548 (defn- draw-relative-aligned!
549 [layer transform h-align v-align x y]
550 (let [geom (geometry layer)
551 w (width geom)
552 h (height geom)
553 p (to-graphics-coords transform x y)
554 x (- (.x p) (anchor-x geom h-align w))
555 y (- (.y p) (anchor-y geom v-align h))]
556 (draw! layer x y w h)))
558 (defn overlay!
559 "Draws layer in the overlayer context above the other layers."
560 ([layer]
561 (overlay* draw-relative! layer (.getTransform *graphics*) 0 0))
562 ([layer x y]
563 (overlay* draw-relative! layer (.getTransform *graphics*) x y))
564 ([layer x y w h]
565 (overlay* draw-relative! layer (.getTransform *graphics*) x y w h)))
567 (defn overlay-aligned! [layer h-align v-align x y]
568 (overlay* draw-relative-aligned!
569 layer (.getTransform *graphics*)
570 h-align v-align x y))
572 (defn overlayer
573 [content]
574 (decorate-layer content [_]
575 (binding [*above* []]
576 (render! content)
577 (doseq [f *above*]
578 (f)))))
580 (defn overlayer*
581 [content]
582 (decorate-layer content [_]
583 (binding [*above* []]
584 (render! content)
585 (loop [above *above*]
586 (when (seq above)
587 (var-set #'*above* [])
588 (doseq [f above]
589 (f))
590 (recur *above*))))))