view src/net/kryshen/indyvon/layers.clj @ 104:491152048c89

Added Scene record to enclose state retained between repaints.
author Mikhail Kryshen <mikhail@kryshen.net>
date Thu, 19 May 2011 20:10:45 +0400
parents 9b81174f0511
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 (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)))
32 ;; Define as macro to avoid unnecessary calculation of inner and outer
33 ;; sizes in the first case.
34 (defmacro align-xy [inner outer align first center last]
35 `(case ~align
36 ~first 0
37 ~center (/ (- ~outer ~inner) 2)
38 ~last (- ~outer ~inner)))
40 (defmacro align-x [inner outer align]
41 `(align-xy ~inner ~outer ~align :left :center :right))
43 (defmacro align-y [inner outer align]
44 `(align-xy ~inner ~outer ~align :top :center :bottom))
46 (defmacro decorate-layer
47 "Decorate Layer and Anchored replacing render! implementation."
48 [layer & render-tail]
49 `(reify
50 Layer
51 (render! ~@render-tail)
52 (layer-size [t#] (layer-size ~layer))
53 Anchored
54 (anchor [t# xa# ya#] (anchor ~layer xa# ya#))))
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 (layer-size [l]
71 (let [s (layer-size content)]
72 (Size. (+ (:width s) left right)
73 (+ (:height s) top bottom))))))))
75 (defn border
76 "Decorate layer with a border."
77 ([content]
78 (border content 1))
79 ([content width]
80 (border content width 0))
81 ([content width gap]
82 (let [layer (padding content (+ width gap))]
83 (decorate-layer layer [_]
84 (let [bw (int width)
85 w (int *width*)
86 h (int *height*)
87 iw (- w bw)
88 ih (- h bw)]
89 (with-color :border-color
90 (doto *graphics*
91 (.fillRect 0 0 iw bw)
92 (.fillRect iw 0 bw ih)
93 (.fillRect bw ih iw bw)
94 (.fillRect 0 bw bw ih))))
95 (render! layer)))))
97 ;; TODO: opacity and blur.
98 (defn shadow
99 "Add shadow to content layer."
100 ([content]
101 (shadow content 1 1))
102 ([content x-offset y-offset]
103 (let [x (if (neg? x-offset) (- x-offset) 0)
104 y (if (neg? y-offset) (- y-offset) 0)
105 abs-x (if (neg? x-offset) (- x-offset) x-offset)
106 abs-y (if (neg? y-offset) (- y-offset) y-offset)
107 shadow-x (+ x-offset x)
108 shadow-y (+ y-offset y)]
109 (reify
110 ;; TODO: Anchored
111 Layer
112 (render! [_]
113 (let [w (- *width* abs-x)
114 h (- *height* abs-y)]
115 (with-color :shadow-color
116 (.fillRect *graphics* shadow-x shadow-y w h))
117 (draw! content x y w h)))
118 (layer-size [_]
119 (let [s (layer-size content)]
120 (Size. (+ (:width s) abs-x)
121 (+ (:height s) abs-y))))))))
123 (defn panel
124 "Opaque layer using theme's alt-back-color."
125 ([content]
126 (panel content 0))
127 ([content gap]
128 (let [layer (padding content gap)]
129 (decorate-layer layer [_]
130 (with-color :alt-back-color
131 (.fillRect *graphics* 0 0 *width* *height*))
132 (render! layer)))))
134 (defn hbox
135 "Creates layer that draws the specified content layers placing them
136 horizontally."
137 [& contents]
138 (reify
139 Layer
140 (render! [_]
141 (let [widths (map #(:width (layer-size %)) contents)
142 xs (cons 0 (reductions + widths))
143 widths-sum (last xs)
144 scale (/ *width* widths-sum)]
145 (doseq [[c w x] (map vector contents widths xs)]
146 (draw! c x 0 w *height*))))
147 (layer-size [_]
148 (reduce #(Size. (+ (:width %1) (:width %2))
149 (max (:height %1) (:height %2)))
150 (Size. 0 0)
151 (map layer-size contents)))))
153 (defn vbox
154 "Creates layer that draws the specified content layers placing them
155 vertically."
156 [& contents]
157 (reify
158 Layer
159 (render! [_]
160 (let [heights (map #(:height (layer-size %)) contents)
161 ys (cons 0 (reductions + heights))
162 heights-sum (last ys)
163 scale (/ *height* heights-sum)]
164 (doseq [[c h y] (map vector contents heights ys)]
165 (draw! c 0 y *width* h))))
166 (layer-size [_]
167 (reduce #(Size. (max (:width %1) (:width %2))
168 (+ (:height %1) (:height %2)))
169 (Size. 0 0)
170 (map layer-size contents)))))
172 (defn- re-split [^java.util.regex.Pattern re s]
173 (seq (.split re s)))
175 (def ^:private text-layout-cache (atom {}))
177 (defn- get-text-layout
178 [^String line ^Font font ^FontRenderContext font-context]
179 (let [key [line font font-context]]
180 (or (if-let [^SoftReference softref (@text-layout-cache key)]
181 (.get softref)
182 (do (swap! text-layout-cache dissoc key)
183 false))
184 (let [layout (TextLayout. line font font-context)]
185 ;;(println "text-layout-cache miss" line)
186 (swap! text-layout-cache assoc key (SoftReference. layout))
187 layout))))
189 (defn- layout-text
190 [lines ^Font font ^FontRenderContext font-context]
191 (map #(get-text-layout % font font-context) lines))
192 ;;(map #(TextLayout. ^String % font font-context) lines))
194 (defn- text-width [layouts]
195 (reduce (fn [w ^TextLayout tl] (max w (.getAdvance tl))) 0 layouts))
197 (defn- text-height [layouts]
198 (reduce (fn [w ^TextLayout tl]
199 (+ w (.getAscent tl)
200 (.getDescent tl)
201 (.getLeading tl)))
202 0 layouts))
204 (defn label
205 "Creates a layer to display multiline text."
206 ([text]
207 (label text :left :top))
208 ([text h-align v-align]
209 (let [lines (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" (str text))]
210 (reify Layer
211 (render! [layer]
212 (let [w *width*
213 h *height*
214 font (.getFont *graphics*)
215 layouts (layout-text lines font *font-context*)
216 y (align-y (text-height layouts) h v-align)]
217 (loop [layouts layouts, y y]
218 (when-first [^TextLayout layout layouts]
219 (let [ascent (.getAscent layout)
220 lh (+ ascent (.getDescent layout) (.getLeading layout))
221 x (align-x (.getAdvance layout) w h-align)]
222 (.draw layout *graphics* x (+ y ascent))
223 (recur (next layouts) (+ y lh)))))))
224 (layer-size [layer]
225 (let [layouts (layout-text lines (:font *theme*) *font-context*)
226 width (text-width layouts)
227 height (text-height layouts)]
228 (Size. width height)))))))
230 (defn- ^ImageObserver image-observer [layer]
231 (reify
232 ImageObserver
233 (imageUpdate [this img infoflags x y width height]
234 (update layer)
235 (zero? (bit-and infoflags
236 (bit-or ImageObserver/ALLBITS
237 ImageObserver/ABORT))))))
239 (defn image-layer
240 [image-or-uri]
241 (let [^Image image (if (instance? Image image-or-uri)
242 image-or-uri
243 (.getImage (Toolkit/getDefaultToolkit)
244 ^java.net.URL image-or-uri))]
245 (.prepareImage (Toolkit/getDefaultToolkit) image -1 -1 nil)
246 (reify
247 Layer
248 (render! [layer]
249 (repaint-on-update layer)
250 (.drawImage *graphics* image 0 0 (image-observer layer)))
251 (layer-size [layer]
252 (let [observer (image-observer layer)
253 width (.getWidth image observer)
254 height (.getHeight image observer)
255 width (if (pos? width) width 1)
256 height (if (pos? height) height 1)]
257 (Size. width height))))))
259 (def ^{:dynamic true} *miniature-thread-priority* 2)
261 (defn- scaling
262 [width height max-width max-height]
263 (min (/ max-width width)
264 (/ max-height height)))
266 (defn miniature
267 "Creates layer that asynchronously renders view of the content
268 scaled to the specified size."
269 [content width height]
270 (async-layer
271 (reify
272 Layer
273 (render! [this]
274 (let [size (layer-size content)
275 s (scaling (:width size) (:height size) width height)]
276 (.scale *graphics* s s)
277 (draw! content
278 (align-x (:width size) (/ width s) :center)
279 (align-y (:height size) (/ height s) :center)
280 (:width size) (:height size))))
281 (layer-size [this]
282 (Size. width height)))
283 ;; (let [size (layer-size content)
284 ;; s (scaling (:width size) (:height size) width height)]
285 ;; (Size. (* (:width size) s) (* (:height size) s)))))
286 width height *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 true} *viewport-scaling-step* (double 3/4))
303 (def ^{:dynamic true} *viewport-min-scale* 1E-6)
304 (def ^{:dynamic true} *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 last-anchor]
311 Layer
312 (render! [layer]
313 (repaint-on-update layer)
314 (with-handlers layer
315 (let [anchor (anchor content h-align v-align)]
316 (dosync
317 (let [ax1 (align-x @last-width *width* h-align)
318 ay1 (align-y @last-height *height* v-align)
319 ax2 (- (:x @last-anchor) (:x anchor))
320 ay2 (- (:y @last-anchor) (:y anchor))]
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 anchor))
329 ;; TODO: notify observers when size changes.
330 (with-transform @transform
331 (draw! content 0 0 false)))
332 (:mouse-pressed e
333 (dosync
334 (ref-set fix-x (:x-on-screen e))
335 (ref-set fix-y (:y-on-screen e)))
336 (set-cursor! (Cursor. Cursor/MOVE_CURSOR)))
337 (:mouse-released e
338 (set-cursor! (Cursor. Cursor/DEFAULT_CURSOR)))
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 (layer-size [layer]
364 (layer-size 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 (Location. 0 0))))) ; last-anchor
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 viewport) (Location. 0 0))
382 (ref-set (:transform viewport) (AffineTransform.)))
383 (update viewport))
385 (defn viewport-miniature
386 "Creates miniature view of the viewport's contents."
387 [viewport width height]
388 (let [miniature (miniature (:content viewport) width height)]
389 (decorate-layer miniature [l]
390 (repaint-on-update viewport)
391 (let [size (layer-size (:content viewport))
392 s (scaling (:width size) (:height size) width height)
393 [vp-tr w h] (dosync
394 [@(:transform viewport)
395 @(:last-width viewport)
396 @(:last-height viewport)])
397 vp-inverse (.createInverse ^AffineTransform vp-tr)
398 ox (align-x (:width size) (/ width s) :center)
399 oy (align-y (:height size) (/ height s) :center)
400 transform (doto (AffineTransform.)
401 (.scale s s)
402 (.translate ox oy)
403 (.concatenate vp-inverse))
404 move-vp (fn [x y]
405 (dosync
406 (let [x (- (/ x s) ox)
407 y (- (/ y s) oy)
408 [x y] (transform-point @(:transform viewport)
409 x y)
410 x (- x (/ @(:last-width viewport) 2))
411 y (- y (/ @(:last-height viewport) 2))]
412 (alter (:transform viewport)
413 pre-translate (- x) (- y))))
414 (update viewport))]
415 (with-color :alt-back-color
416 (.fillRect *graphics* 0 0 *width* *height*))
417 (with-transform transform
418 (with-color :back-color
419 (.fillRect *graphics* 0 0 w h)))
420 (with-handlers l
421 (draw! miniature)
422 (:mouse-pressed e (move-vp (:x e) (:y e)))
423 (:mouse-dragged e (move-vp (:x e) (:y e))))
424 (with-transform transform
425 (with-color :border-color
426 (.drawRect *graphics* 0 0 w h)))))))
428 (defn ref-layer
429 [layer-ref]
430 (let [l (reify
431 Layer
432 (render! [l]
433 (repaint-on-update l)
434 (if-let [layer @layer-ref]
435 (render! layer)))
436 (layer-size [_]
437 (if-let [layer @layer-ref]
438 (layer-size layer)
439 (Size. 1 1)))
440 Anchored
441 (anchor [_ x-align y-align]
442 (if-let [layer @layer-ref]
443 (anchor layer x-align y-align)
444 (Location. 0 0))))]
445 (add-watch layer-ref l (fn [_ _ _ _] (update l)))
446 l))
448 ;;
449 ;; Layer context decorators.
450 ;;
452 (defmacro handler [layer & handlers]
453 "Decorate layer to handle events."
454 `(let [layer# ~layer]
455 (decorate-layer layer# [t#]
456 (with-handlers t#
457 (render! layer#)
458 ~@handlers))))
460 (defn themed [layer & map-or-keyvals]
461 (let [theme (if (== (count map-or-keyvals) 1)
462 (first map-or-keyvals)
463 (apply array-map map-or-keyvals))]
464 (reify
465 Layer
466 (render! [t]
467 (with-theme theme
468 (render! layer)))
469 (layer-size [t]
470 (with-theme theme
471 (layer-size layer)))
472 Anchored
473 (anchor [t xa ya]
474 (with-theme theme
475 (anchor layer xa ya))))))
477 (defn hinted [layer & map-or-keyvals]
478 (let [hints (if (== (count map-or-keyvals) 1)
479 (first map-or-keyvals)
480 (apply array-map map-or-keyvals))]
481 (decorate-layer layer [_]
482 (with-hints* hints render! layer))))
484 ;;
485 ;; Measuring time
486 ;;
488 (def ^{:dynamic true} *interval*)
490 (defn interval-layer
491 "Creates layer that measures time between repaints ant draws it's
492 content with the *interval* var bound to the measured time."
493 [content]
494 (let [last-time (atom nil)]
495 (decorate-layer content [_]
496 (compare-and-set! last-time nil *time*)
497 (let [lt @last-time]
498 (binding [*interval* (if (compare-and-set! last-time lt *time*)
499 (- *time* lt)
500 0)] ; already measured on parallel thread
501 (render! content))))))
503 (defn- fps-label [text]
504 (padding (label text :right :bottom) 5))
506 (defn fps-layer
507 "Creates layer that draws content and displays
508 the frames per seconds rate."
509 [content]
510 (let [update-interval 2E8 ; 0.2 s in nanoseconds
511 frames (ref 0)
512 prev-time (ref nil)
513 display (ref (fps-label "fps n/a"))]
514 (decorate-layer content [_]
515 (draw! content)
516 (draw!
517 (dosync
518 (alter frames inc)
519 (if @prev-time
520 (let [elapsed (- *time* @prev-time)]
521 (when (> elapsed update-interval)
522 (let [fps (/ @frames (/ elapsed 1E9))]
523 (ref-set display (fps-label (format "%.1f" fps)))
524 (ref-set frames 0)
525 (ref-set prev-time *time*))))
526 (ref-set prev-time *time*))
527 @display)))))
529 ;;
530 ;; Overlayer.
531 ;;
533 (def ^{:private true :dynamic true} *above*)
535 (defn- overlay* [f & args]
536 (var-set #'*above* (conj *above* (apply partial f args))))
538 (defn- ^Point to-graphics-coords
539 [^AffineTransform transform x y]
540 (let [p (Point. x y)]
541 (.transform transform p p)
542 (.transform (.createInverse (.getTransform *graphics*)) p p)
543 p))
545 (defn- draw-relative!
546 ([layer transform x y]
547 (let [p (to-graphics-coords transform x y)]
548 (draw! layer (.x p) (.y p))))
549 ([layer transform x y w h]
550 (let [p (to-graphics-coords transform x y)]
551 (draw! layer (.x p) (.y p) w h))))
553 (defn overlay!
554 "Draws layer in the overlayer context above the other layers."
555 ([layer]
556 (overlay* draw-relative! layer (.getTransform *graphics*) 0 0))
557 ([layer x y]
558 (overlay* draw-relative! layer (.getTransform *graphics*) x y))
559 ([layer x y w h]
560 (overlay* draw-relative! layer (.getTransform *graphics*) x y w h)))
562 (defn overlayer
563 [content]
564 (decorate-layer content [_]
565 (binding [*above* []]
566 (render! content)
567 (doseq [f *above*]
568 (f)))))