Mercurial > hg > indyvon
view src/indyvon/views.clj @ 185:83241889daac
BorderBox: properly wrap Geometry of the center view.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Tue, 21 Nov 2017 19:06:25 +0300 |
| parents | 292d885a5a7b |
| children |
line source
1 ;;
2 ;; Copyright 2010-2017 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 ^boolean center-anchor?]
195 View
196 (render! [_]
197 (let [w *width*
198 h *height*
199 t (height (geometry north) w)
200 b (height (geometry south) w)
201 ch (- h t b)
202 l (width (geometry west) ch)
203 r (width (geometry east) ch)
204 cw (- w l r)]
205 (draw! north 0 0 w t)
206 (draw! west 0 t l ch)
207 (draw! south 0 (- h b) w b)
208 (draw! east (- w r) t r ch)
209 (draw! center l t cw ch)))
210 (geometry [_]
211 (let [ng (geometry north)
212 wg (geometry west)
213 sg (geometry south)
214 eg (geometry east)
215 cg (geometry center)
216 cw0 (width cg)
217 ch0 (height cg)
218 ch (max ch0 (height wg) (height eg))
219 l (width wg ch)
220 r (width eg ch)
221 w (max (+ cw0 l r) (width ng) (width sg))
222 t (height ng w)
223 b (height sg w)
224 h (+ ch t b)]
225 (if center-anchor?
226 (->NestedGeometry cg t l (- h ch0 t) (- w cw0 l))
227 (->Size w h)))))
229 (defn border-box
230 "reginonviews => region-key view
231 Returns a View that organizes specified Views in five
232 regions (:north, :south, :east, :west, and
233 :center). Each region may contain no more than one View."
234 [& regionviews]
235 (let [opts (apply array-map regionviews)]
236 (->BorderBox (:north opts empty-view)
237 (:west opts empty-view)
238 (:south opts empty-view)
239 (:east opts empty-view)
240 (:center opts empty-view)
241 (:center-anchor? opts false))))
243 (defn- re-split [^java.util.regex.Pattern re s]
244 (seq (.split re s)))
246 (def ^:private ^Cache text-layout-cache
247 (-> (CacheBuilder/newBuilder)
248 (.softValues)
249 (.expireAfterAccess (long 1) TimeUnit/SECONDS)
250 (.build)))
252 (defn- get-text-layout
253 [^String line ^Font font ^FontRenderContext font-context]
254 ;; XXX: TextLayout fails on empty strings, use zero-width space as a
255 ;; workaround.
256 (let [line (if (.isEmpty line) "\u200b" line)]
257 (.get text-layout-cache [line font font-context]
258 #(TextLayout. line font font-context))))
260 (defn- layout-text
261 [lines font font-context]
262 (map #(get-text-layout % font font-context) lines))
264 (defn- text-width [layouts]
265 (reduce (fn [w ^TextLayout tl] (max w (.getAdvance tl))) 0 layouts))
267 (defn- text-height [layouts]
268 (reduce (fn [w ^TextLayout tl]
269 (+ w (.getAscent tl)
270 (.getDescent tl)
271 (.getLeading tl)))
272 0 layouts))
274 (defrecord Label [h-align v-align lines]
275 View
276 (render! [view]
277 (let [w *width*
278 h *height*
279 font (.getFont *graphics*)
280 layouts (layout-text lines font (font-context))
281 y (align-y v-align (text-height layouts) h)]
282 (loop [layouts layouts, y y]
283 (when-first [^TextLayout layout layouts]
284 (let [ascent (.getAscent layout)
285 lh (+ ascent (.getDescent layout) (.getLeading layout))
286 x (align-x h-align (.getAdvance layout) w)]
287 (.draw layout *graphics* x (+ y ascent))
288 (recur (next layouts) (+ y lh)))))))
289 (geometry [view]
290 (let [layouts (layout-text lines (theme-get :font) (font-context))
291 w (text-width layouts)
292 h (text-height layouts)]
293 (->Size w h))))
295 (defn label
296 "Creates a view to display multiline text."
297 ([text]
298 (label :left :top text))
299 ([h-align v-align text]
300 (->Label h-align
301 v-align
302 (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" (str text)))))
304 (defrecord ImageView [^Image image]
305 View
306 (render! [view]
307 (repaint-on-update! view)
308 (.drawImage *graphics* image 0 0 view))
309 (geometry [view]
310 (let [width (.getWidth image view)
311 height (.getHeight image view)
312 width (if (pos? width) width 1)
313 height (if (pos? height) height 1)]
314 (->Size width height)))
315 ImageObserver
316 (imageUpdate [view img infoflags x y width height]
317 (notify! view)
318 (zero? (bit-and infoflags
319 (bit-or ImageObserver/ALLBITS
320 ImageObserver/ABORT)))))
322 (defn image-view
323 [image-or-uri]
324 (let [^Image image (if (instance? Image image-or-uri)
325 image-or-uri
326 (.getImage (Toolkit/getDefaultToolkit)
327 ^java.net.URL image-or-uri))]
328 (.prepareImage (Toolkit/getDefaultToolkit) image -1 -1 nil)
329 (->ImageView image)))
331 (defrecord RefView [reference view-delay-atom]
332 View
333 (render! [v]
334 (repaint-on-update! v)
335 (when-let [view @@view-delay-atom]
336 (render! view)))
337 (geometry [v]
338 (if-let [view @@view-delay-atom]
339 (geometry view)
340 (->Size 1 1))))
342 (defn ref-view
343 ([reference]
344 (ref-view reference #'identity))
345 ([reference view-fn]
346 ;; The reference may update multiple times before repaint happens,
347 ;; delay is used to avoid unnecessary invocations of view-fn.
348 (let [view-delay-atom (atom (delay (view-fn @reference)))
349 v (->RefView reference view-delay-atom)]
350 (add-watch reference v (fn [_ _ _ n]
351 (reset! view-delay-atom (delay (view-fn n)))
352 (notify! v)))
353 v)))
355 ;;
356 ;; View context decorators
357 ;;
359 (defrecord Active [handlers content]
360 View
361 (render! [v]
362 (with-handlers* v handlers render! content))
363 (geometry [_]
364 (geometry content)))
366 (defmacro add-handlers
367 "Adds event handling to the view."
368 [view & event-handlers]
369 `(->Active (handlers ~@event-handlers) ~view))
371 (defrecord Themed [theme view]
372 View
373 (render! [_]
374 (with-theme theme
375 (apply-theme)
376 (render! view)))
377 (geometry [_]
378 (with-theme* theme geometry view)))
380 (defn themed [theme view]
381 (->Themed theme view))
383 (defrecord Hinted [hints view]
384 View
385 (render! [_]
386 (with-hints* hints render! view))
387 (geometry [_]
388 (if (bound? #'*graphics*)
389 (with-hints* hints geometry view)
390 (geometry view))))
392 (defn hinted [hints view]
393 (->Hinted hints view))
395 (defn- transform-bounds
396 ^Rectangle2D [^AffineTransform tr ^double w ^double h]
397 (.getBounds2D
398 (.createTransformedShape tr (Rectangle2D$Double. 0 0 w h))))
400 (defrecord Transform [transform view]
401 View
402 (render! [v]
403 (let [g (geometry view)
404 w (double (width g))
405 h (double (height g))
406 ^Rectangle2D bounds (transform-bounds transform w h)
407 g *graphics*]
408 (.translate g (- (.getX bounds)) (- (.getY bounds)))
409 (.transform g transform)
410 ;; TODO: scale w and h to fit *width* and *height*.
411 (draw! view 0 0 w h)))
412 (geometry [_]
413 (let [g (geometry view)
414 w (double (width g))
415 h (double (height g))
416 ^Rectangle2D bounds (transform-bounds transform w h)]
417 (->Size (.getWidth bounds) (.getHeight bounds)))))
419 (defn transform [tr view]
420 (->Transform tr view))
422 (defn rotate [^double degrees view]
423 (transform
424 (AffineTransform/getRotateInstance (Math/toRadians degrees))
425 view))
427 ;;
428 ;; Measuring time
429 ;;
431 (def ^:dynamic *interval*)
433 (defrecord IntervalView [last-time content]
434 View
435 (render! [_]
436 (compare-and-set! last-time nil *time*)
437 (let [lt @last-time]
438 (binding [*interval* (if (compare-and-set! last-time lt *time*)
439 (- *time* lt)
440 0)] ; already measured on parallel thread
441 (render! content))))
442 (geometry [_]
443 (geometry content)))
445 (defn interval-view
446 "Creates a view that measures time between repaints and draws it's
447 content with the *interval* var bound to the measured time."
448 [content]
449 (->IntervalView (atom nil) content))
451 (defn- fps-label [text]
452 (padding 5 (label :right :bottom text)))
454 (defrecord FPSView [update-interval frames prev-time display content]
455 View
456 (render! [_]
457 (draw! content)
458 (draw!
459 (dosync
460 (alter frames inc)
461 (if @prev-time
462 (let [elapsed (- *time* @prev-time)]
463 (when (> elapsed update-interval)
464 (let [fps (/ @frames (/ elapsed 1E9))]
465 (ref-set display (fps-label (format "%.1f" fps)))
466 (ref-set frames 0)
467 (ref-set prev-time *time*))))
468 (ref-set prev-time *time*))
469 @display)))
470 (geometry [_] (geometry content)))
472 (defn fps-view
473 "Creates a view that draws content and displays the
474 frames per second rate."
475 [content]
476 ;; 2E8 ns = 0.2 s.
477 (->FPSView 2E8 (ref 0) (ref nil) (ref (fps-label "fps n/a")) content))
479 ;;
480 ;; Overlays
481 ;;
483 (def ^:private ^:dynamic *above*)
485 (defn- overlay* [f & args]
486 (var-set #'*above* (conj *above* (apply partial f args))))
488 (defn- ^Point2D to-graphics-coords
489 [^AffineTransform transform x y]
490 (let [p (Point2D$Double. x y)]
491 (.transform transform p p)
492 (.transform (.createInverse (.getTransform *graphics*)) p p)
493 p))
495 (defn- draw-relative!
496 ([view transform x y]
497 (let [p (to-graphics-coords transform x y)]
498 (draw! view (.getX p) (.getY p))))
499 ([view transform x y w h]
500 (let [p (to-graphics-coords transform x y)]
501 (draw! view (.getX p) (.getY p) w h))))
503 (defn- draw-relative-aligned!
504 [view transform h-align v-align x y]
505 (let [geom (geometry view)
506 w (width geom)
507 h (height geom)
508 p (to-graphics-coords transform x y)
509 x (- (.getX p) (anchor-x geom h-align w))
510 y (- (.getY p) (anchor-y geom v-align h))]
511 (draw! view x y w h)))
513 (defn overlay!
514 "Draws view in the overlay context above the current layer."
515 ([view]
516 (overlay* draw-relative! view (.getTransform *graphics*) 0 0))
517 ([view x y]
518 (overlay* draw-relative! view (.getTransform *graphics*) x y))
519 ([view x y w h]
520 (overlay* draw-relative! view (.getTransform *graphics*) x y w h)))
522 (defn overlay-aligned! [view h-align v-align x y]
523 (overlay* draw-relative-aligned!
524 view
525 (.getTransform *graphics*)
526 h-align v-align
527 x y))
529 (defn with-overlays* [recursive? f & args]
530 (binding [*above* []]
531 (apply f args)
532 (if recursive?
533 (loop [above *above*]
534 (when (seq above)
535 (var-set #'*above* [])
536 (doseq [of above]
537 (of))
538 (recur *above*)))
539 (doseq [of *above*]
540 (of)))))
542 (defmacro with-overlays [recursive? & body]
543 `(with-overlays* ~recursive? (fn [] ~@body)))
545 (defrecord Layered [recursive? content]
546 View
547 (render! [_]
548 (with-overlays* recursive? render! content))
549 (geometry [_ ]
550 (geometry content)))
552 (defn layered
553 "Allows content view to display pop-ups on top of itself."
554 ([content]
555 (layered true content))
556 ([recursive? content]
557 (->Layered recursive? content)))