Mercurial > hg > indyvon
view src/indyvon/views.clj @ 182:fefcd73386c2
Workaround to allow empty text lines in labels.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Tue, 01 Dec 2015 19:31:17 +0300 |
| parents | fc9c674a4d54 |
| children | 292d885a5a7b |
line source
1 ;;
2 ;; Copyright 2010-2015 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 indyvon.views
21 "Implementations of the View protocol."
22 (:use
23 (indyvon core async))
24 (:import
25 (java.awt Font Image Toolkit)
26 java.awt.image.ImageObserver
27 (java.awt.geom Area AffineTransform Rectangle2D Rectangle2D$Double
28 Point2D Point2D$Double)
29 (java.awt.font FontRenderContext TextLayout)
30 java.util.concurrent.TimeUnit
31 (com.google.common.cache Cache CacheBuilder CacheLoader)))
33 (defrecord Decorator [render-fn geometry-fn content]
34 View
35 (render! [decorator]
36 (render-fn decorator content))
37 (geometry [decorator]
38 (geometry-fn decorator content)))
40 (defn- decorator-content-geometry [_ content]
41 (geometry content))
43 (defn decorator
44 "Creates a decorator view. Functions render-fn and geometry-fn will
45 be called with the decorator and content as arguments. Use this in
46 preference to (reify View) as it creates a defrecord instance
47 instead of an opaque reify object. Prefer to pass render-fn and
48 geometry-fn as Vars to allow the view to be printed and read back."
49 ([render-fn content]
50 (decorator render-fn #'decorator-content-geometry content))
51 ([render-fn geometry-fn content]
52 (->Decorator render-fn geometry-fn content)))
54 (defrecord Empty []
55 View
56 (render! [_])
57 (geometry [_]
58 (->Size 0 0)))
60 (def empty-view (->Empty))
62 (defrecord Padding [top left bottom right content]
63 View
64 (render! [l]
65 (draw! content
66 left top
67 (- *width* left right)
68 (- *height* top bottom)
69 false))
70 (geometry [l]
71 (->NestedGeometry (geometry content) top left bottom right)))
73 (defn padding
74 "Adds padding to the content view."
75 ([distance content]
76 (padding distance distance distance distance content))
77 ([top left bottom right content]
78 (if (== 0 top left bottom right)
79 content
80 (->Padding top left bottom right content))))
82 (defrecord Border [^double thickness content]
83 View
84 (render! [_]
85 (render! content)
86 (with-color :border-color
87 (let [w (double *width*)
88 h (double *height*)
89 t thickness
90 outer (Area. (Rectangle2D$Double. 0.0 0.0 w h))
91 inner (Area. (Rectangle2D$Double. t t (- w t t) (- h t t)))]
92 (.subtract outer inner)
93 (.fill *graphics* outer))))
94 (geometry [_] (geometry content)))
96 (defn border
97 "Adds a border to the content view."
98 ([content]
99 (border 1 content))
100 ([thickness content]
101 (border thickness 0 content))
102 ([thickness gap content]
103 (->Border thickness (padding (+ thickness gap) content))))
105 ;; TODO: opacity and blur.
106 (defrecord Shadow [^double x ^double y content]
107 View
108 (render! [_]
109 (let [w (- *width* (Math/abs x))
110 h (- *height* (Math/abs y))]
111 (with-color :shadow-color
112 (.fillRect *graphics* (max x 0.0) (max y 0.0) w h))
113 (draw! content (max (- x) 0.0) (max (- y) 0.0) w h)))
114 (geometry [_]
115 (->NestedGeometry (geometry content)
116 (max (- y) 0.0) ;; top
117 (max (- x) 0.0) ;; left
118 (max y 0.0) ;; bottom
119 (max x 0.0)))) ;; right
120 (defn shadow
121 "Adds a shadow to the content view."
122 ([content]
123 (shadow 1 1 content))
124 ([x-offset y-offset content]
125 (->Shadow x-offset y-offset content)))
127 (defrecord Panel [back-color content]
128 View
129 (render! [_]
130 (with-color back-color
131 (.fill *graphics* (Rectangle2D$Double. 0.0 0.0 *width* *height*)))
132 (render! content))
133 (geometry [_] (geometry content)))
135 (defn panel
136 "An opaque view using theme's alt-back-color or a custom background
137 color."
138 ([content]
139 (panel :alt-back-color content))
140 ([back-color content]
141 (->Panel back-color content)))
143 (defrecord Box [proportional? translate-geometry contents]
144 View
145 (render! [_]
146 (let [context-size (translate-geometry (->Size *width* *height*))
147 dimxs (map (comp width translate-geometry geometry) contents)
148 xs (cons 0 (reductions + dimxs))
149 dimxs-sum (last xs)
150 scale (if proportional? (/ (width context-size) dimxs-sum) 1)]
151 (doseq [[c w x] (map vector contents dimxs xs)]
152 (draw-aligned! c
153 (translate-geometry
154 (->FixedGeometry (- (* scale x)) 0
155 (* scale w) (height context-size)))
156 :left :top
157 0 0))))
158 (geometry [_]
159 (translate-geometry
160 (reduce #(->Size (+ (width %1) (width %2))
161 (max (height %1) (height %2)))
162 (->Size 0 0)
163 (map (comp translate-geometry geometry) contents)))))
165 (defn- hbox* [proportional? contents]
166 (->Box proportional? #'identity contents))
168 (defn- vbox* [proportional? contents]
169 (->Box proportional? #'->TransposedGeometry contents))
171 (defn hbox
172 "Creates a view that draws the specified content views placing them
173 horizontally."
174 [& contents]
175 (hbox* false contents))
177 (defn hbox-proportional
178 "Like hbox, but proportionally distributes the available space."
179 [& contents]
180 (hbox* true contents))
182 (defn vbox
183 "Creates a view that draws the specified content views placing them
184 horizontally."
185 [& contents]
186 (vbox* false contents))
188 (defn vbox-proportional
189 "Like vbox, but proportionally distributes the available space."
190 [& contents]
191 (vbox* true contents))
193 (defrecord BorderBox [north west south east center]
194 View
195 (render! [_]
196 (let [w *width*
197 h *height*
198 t (height (geometry north) w)
199 b (height (geometry south) w)
200 ch (- h t b)
201 l (width (geometry west) ch)
202 r (width (geometry east) ch)
203 cw (- w l r)]
204 (draw! north 0 0 w t)
205 (draw! west 0 t l ch)
206 (draw! south 0 (- h b) w b)
207 (draw! east (- w r) t r ch)
208 (draw! center l t cw ch)))
209 (geometry [_]
210 (let [ng (geometry north)
211 wg (geometry west)
212 sg (geometry south)
213 eg (geometry east)
214 cg (geometry center)
215 cw (width cg)
216 ch (max (height cg) (height wg) (height eg))
217 l (width wg ch)
218 r (width eg ch)
219 w (max (+ cw l r) (width ng) (width sg))
220 t (height ng w)
221 b (height sg w)
222 h (+ ch t b)]
223 (->Size w h))))
225 (defn border-box
226 "reginonviews => region-key view
227 Returns a View that organizes specified Views in five
228 regions (:north, :south, :east, :west, and
229 :center). Each region may contain no more than one View."
230 [& regionviews]
231 (let [regions (apply array-map regionviews)]
232 (->BorderBox (:north regions empty-view)
233 (:west regions empty-view)
234 (:south regions empty-view)
235 (:east regions empty-view)
236 (:center regions empty-view))))
238 (defn- re-split [^java.util.regex.Pattern re s]
239 (seq (.split re s)))
241 (def ^:private ^Cache text-layout-cache
242 (-> (CacheBuilder/newBuilder)
243 (.softValues)
244 (.expireAfterAccess (long 1) TimeUnit/SECONDS)
245 (.build)))
247 (defn- get-text-layout
248 [^String line ^Font font ^FontRenderContext font-context]
249 ;; XXX: TextLayout fails on empty strings, use zero-width space as a
250 ;; workaround.
251 (let [line (if (.isEmpty line) "\u200b" line)]
252 (.get text-layout-cache [line font font-context]
253 #(TextLayout. line font font-context))))
255 (defn- layout-text
256 [lines font font-context]
257 (map #(get-text-layout % font font-context) lines))
259 (defn- text-width [layouts]
260 (reduce (fn [w ^TextLayout tl] (max w (.getAdvance tl))) 0 layouts))
262 (defn- text-height [layouts]
263 (reduce (fn [w ^TextLayout tl]
264 (+ w (.getAscent tl)
265 (.getDescent tl)
266 (.getLeading tl)))
267 0 layouts))
269 (defrecord Label [h-align v-align lines]
270 View
271 (render! [view]
272 (let [w *width*
273 h *height*
274 font (.getFont *graphics*)
275 layouts (layout-text lines font (font-context))
276 y (align-y v-align (text-height layouts) h)]
277 (loop [layouts layouts, y y]
278 (when-first [^TextLayout layout layouts]
279 (let [ascent (.getAscent layout)
280 lh (+ ascent (.getDescent layout) (.getLeading layout))
281 x (align-x h-align (.getAdvance layout) w)]
282 (.draw layout *graphics* x (+ y ascent))
283 (recur (next layouts) (+ y lh)))))))
284 (geometry [view]
285 (let [layouts (layout-text lines (theme-get :font) (font-context))
286 w (text-width layouts)
287 h (text-height layouts)]
288 (->Size w h))))
290 (defn label
291 "Creates a view to display multiline text."
292 ([text]
293 (label :left :top text))
294 ([h-align v-align text]
295 (->Label h-align
296 v-align
297 (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" (str text)))))
299 (defrecord ImageView [^Image image]
300 View
301 (render! [view]
302 (repaint-on-update! view)
303 (.drawImage *graphics* image 0 0 view))
304 (geometry [view]
305 (let [width (.getWidth image view)
306 height (.getHeight image view)
307 width (if (pos? width) width 1)
308 height (if (pos? height) height 1)]
309 (->Size width height)))
310 ImageObserver
311 (imageUpdate [view img infoflags x y width height]
312 (notify! view)
313 (zero? (bit-and infoflags
314 (bit-or ImageObserver/ALLBITS
315 ImageObserver/ABORT)))))
317 (defn image-view
318 [image-or-uri]
319 (let [^Image image (if (instance? Image image-or-uri)
320 image-or-uri
321 (.getImage (Toolkit/getDefaultToolkit)
322 ^java.net.URL image-or-uri))]
323 (.prepareImage (Toolkit/getDefaultToolkit) image -1 -1 nil)
324 (->ImageView image)))
326 (defrecord RefView [reference view-delay-atom]
327 View
328 (render! [v]
329 (repaint-on-update! v)
330 (when-let [view @@view-delay-atom]
331 (render! view)))
332 (geometry [v]
333 (if-let [view @@view-delay-atom]
334 (geometry view)
335 (->Size 1 1))))
337 (defn ref-view
338 ([reference]
339 (ref-view reference #'identity))
340 ([reference view-fn]
341 ;; The reference may update multiple times before repaint happens,
342 ;; delay is used to avoid unnecessary invocations of view-fn.
343 (let [view-delay-atom (atom (delay (view-fn @reference)))
344 v (->RefView reference view-delay-atom)]
345 (add-watch reference v (fn [_ _ _ n]
346 (reset! view-delay-atom (delay (view-fn n)))
347 (notify! v)))
348 v)))
350 ;;
351 ;; View context decorators
352 ;;
354 (defrecord Active [handlers content]
355 View
356 (render! [v]
357 (with-handlers* v handlers render! content))
358 (geometry [_]
359 (geometry content)))
361 (defmacro add-handlers
362 "Adds event handling to the view."
363 [view & event-handlers]
364 `(->Active (handlers ~@event-handlers) ~view))
366 (defrecord Themed [theme view]
367 View
368 (render! [_]
369 (with-theme theme
370 (apply-theme)
371 (render! view)))
372 (geometry [_]
373 (with-theme* theme geometry view)))
375 (defn themed [theme view]
376 (->Themed theme view))
378 (defrecord Hinted [hints view]
379 View
380 (render! [_]
381 (with-hints* hints render! view))
382 (geometry [_]
383 (if (bound? #'*graphics*)
384 (with-hints* hints geometry view)
385 (geometry view))))
387 (defn hinted [hints view]
388 (->Hinted hints view))
390 (defn- transform-bounds
391 ^Rectangle2D [^AffineTransform tr ^double w ^double h]
392 (.getBounds2D
393 (.createTransformedShape tr (Rectangle2D$Double. 0 0 w h))))
395 (defrecord Transform [transform view]
396 View
397 (render! [v]
398 (let [g (geometry view)
399 w (double (width g))
400 h (double (height g))
401 ^Rectangle2D bounds (transform-bounds transform w h)
402 g *graphics*]
403 (.translate g (- (.getX bounds)) (- (.getY bounds)))
404 (.transform g transform)
405 ;; TODO: scale w and h to fit *width* and *height*.
406 (draw! view 0 0 w h)))
407 (geometry [_]
408 (let [g (geometry view)
409 w (double (width g))
410 h (double (height g))
411 ^Rectangle2D bounds (transform-bounds transform w h)]
412 (->Size (.getWidth bounds) (.getHeight bounds)))))
414 (defn transform [tr view]
415 (->Transform tr view))
417 (defn rotate [^double degrees view]
418 (transform
419 (AffineTransform/getRotateInstance (Math/toRadians degrees))
420 view))
422 ;;
423 ;; Measuring time
424 ;;
426 (def ^:dynamic *interval*)
428 (defrecord IntervalView [last-time content]
429 View
430 (render! [_]
431 (compare-and-set! last-time nil *time*)
432 (let [lt @last-time]
433 (binding [*interval* (if (compare-and-set! last-time lt *time*)
434 (- *time* lt)
435 0)] ; already measured on parallel thread
436 (render! content))))
437 (geometry [_]
438 (geometry content)))
440 (defn interval-view
441 "Creates a view that measures time between repaints and draws it's
442 content with the *interval* var bound to the measured time."
443 [content]
444 (->IntervalView (atom nil) content))
446 (defn- fps-label [text]
447 (padding 5 (label :right :bottom text)))
449 (defrecord FPSView [update-interval frames prev-time display content]
450 View
451 (render! [_]
452 (draw! content)
453 (draw!
454 (dosync
455 (alter frames inc)
456 (if @prev-time
457 (let [elapsed (- *time* @prev-time)]
458 (when (> elapsed update-interval)
459 (let [fps (/ @frames (/ elapsed 1E9))]
460 (ref-set display (fps-label (format "%.1f" fps)))
461 (ref-set frames 0)
462 (ref-set prev-time *time*))))
463 (ref-set prev-time *time*))
464 @display)))
465 (geometry [_] (geometry content)))
467 (defn fps-view
468 "Creates a view that draws content and displays the
469 frames per second rate."
470 [content]
471 ;; 2E8 ns = 0.2 s.
472 (->FPSView 2E8 (ref 0) (ref nil) (ref (fps-label "fps n/a")) content))
474 ;;
475 ;; Overlays
476 ;;
478 (def ^:private ^:dynamic *above*)
480 (defn- overlay* [f & args]
481 (var-set #'*above* (conj *above* (apply partial f args))))
483 (defn- ^Point2D to-graphics-coords
484 [^AffineTransform transform x y]
485 (let [p (Point2D$Double. x y)]
486 (.transform transform p p)
487 (.transform (.createInverse (.getTransform *graphics*)) p p)
488 p))
490 (defn- draw-relative!
491 ([view transform x y]
492 (let [p (to-graphics-coords transform x y)]
493 (draw! view (.getX p) (.getY p))))
494 ([view transform x y w h]
495 (let [p (to-graphics-coords transform x y)]
496 (draw! view (.getX p) (.getY p) w h))))
498 (defn- draw-relative-aligned!
499 [view transform h-align v-align x y]
500 (let [geom (geometry view)
501 w (width geom)
502 h (height geom)
503 p (to-graphics-coords transform x y)
504 x (- (.getX p) (anchor-x geom h-align w))
505 y (- (.getY p) (anchor-y geom v-align h))]
506 (draw! view x y w h)))
508 (defn overlay!
509 "Draws view in the overlay context above the current layer."
510 ([view]
511 (overlay* draw-relative! view (.getTransform *graphics*) 0 0))
512 ([view x y]
513 (overlay* draw-relative! view (.getTransform *graphics*) x y))
514 ([view x y w h]
515 (overlay* draw-relative! view (.getTransform *graphics*) x y w h)))
517 (defn overlay-aligned! [view h-align v-align x y]
518 (overlay* draw-relative-aligned!
519 view
520 (.getTransform *graphics*)
521 h-align v-align
522 x y))
524 (defn with-overlays* [recursive? f & args]
525 (binding [*above* []]
526 (apply f args)
527 (if recursive?
528 (loop [above *above*]
529 (when (seq above)
530 (var-set #'*above* [])
531 (doseq [of above]
532 (of))
533 (recur *above*)))
534 (doseq [of *above*]
535 (of)))))
537 (defmacro with-overlays [recursive? & body]
538 `(with-overlays* ~recursive? (fn [] ~@body)))
540 (defrecord Layered [recursive? content]
541 View
542 (render! [_]
543 (with-overlays* recursive? render! content))
544 (geometry [_ ]
545 (geometry content)))
547 (defn layered
548 "Allows content view to display pop-ups on top of itself."
549 ([content]
550 (layered true content))
551 ([recursive? content]
552 (->Layered recursive? content)))