Mercurial > hg > indyvon
view src/indyvon/views.clj @ 171:d9bdf08211df
Added some docstrings.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Tue, 09 Dec 2014 16:45:22 +0300 |
| parents | 5b80af180da0 |
| children | eb1bedf22731 |
line source
1 ;;
2 ;; Copyright 2010-2014 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 (defmacro decorate-view
34 "Decorate the view replacing render! implementation."
35 [view & render-tail]
36 `(let [view# ~view]
37 (reify
38 View
39 (render! ~@render-tail)
40 (geometry [t#] (geometry view#)))))
42 (defrecord Empty []
43 View
44 (render! [_])
45 (geometry [_]
46 (->Size 0 0)))
48 (def empty-view (->Empty))
50 (defn padding
51 "Adds padding to the content view."
52 ([distance content]
53 (padding distance distance distance distance content))
54 ([top left bottom right content]
55 (if (== 0 top left bottom right)
56 content
57 (reify
58 View
59 (render! [l]
60 (draw! content
61 left top
62 (- *width* left right)
63 (- *height* top bottom)
64 false))
65 (geometry [l]
66 (->NestedGeometry (geometry content) top left bottom right))))))
68 (defn border
69 "Adds a border to the content view."
70 ([content]
71 (border 1 content))
72 ([thickness content]
73 (border thickness 0 content))
74 ([thickness gap content]
75 (let [view (padding (+ thickness gap) content)
76 t (double thickness)]
77 (decorate-view view [_]
78 (render! view)
79 (with-color :border-color
80 (let [w (double *width*)
81 h (double *height*)
82 outer (Area. (Rectangle2D$Double. 0.0 0.0 w h))
83 inner (Area. (Rectangle2D$Double. t t (- w t t) (- h t t)))]
84 (.subtract outer inner)
85 (.fill *graphics* outer)))))))
87 ;; TODO: opacity and blur.
88 (defn shadow
89 "Adds a shadow to the content view."
90 ([content]
91 (shadow 1 1 content))
92 ([x-offset y-offset content]
93 (let [x (if (neg? x-offset) (- x-offset) 0)
94 y (if (neg? y-offset) (- y-offset) 0)
95 abs-x (if (neg? x-offset) (- x-offset) x-offset)
96 abs-y (if (neg? y-offset) (- y-offset) y-offset)
97 shadow-x (+ x-offset x)
98 shadow-y (+ y-offset y)]
99 (reify
100 View
101 (render! [_]
102 (let [w (- *width* abs-x)
103 h (- *height* abs-y)]
104 (with-color :shadow-color
105 (.fillRect *graphics* shadow-x shadow-y w h))
106 (draw! content x y w h)))
107 (geometry [_]
108 (->NestedGeometry (geometry content)
109 y x shadow-y shadow-x))))))
111 (defn panel
112 "An opaque view using theme's alt-back-color or a custom background
113 color."
114 ([content]
115 (panel :alt-back-color content))
116 ([back-color content]
117 (decorate-view content [_]
118 (with-color back-color
119 (.fill *graphics* (Rectangle2D$Double. 0.0 0.0 *width* *height*)))
120 (render! content))))
122 (defrecord Box [proportional? translate-geometry contents]
123 View
124 (render! [_]
125 (let [context-size (translate-geometry (->Size *width* *height*))
126 dimxs (map (comp width translate-geometry geometry) contents)
127 xs (cons 0 (reductions + dimxs))
128 dimxs-sum (last xs)
129 scale (if proportional? (/ (width context-size) dimxs-sum) 1)]
130 (doseq [[c w x] (map vector contents dimxs xs)]
131 (draw-aligned! c
132 (translate-geometry
133 (->FixedGeometry (- (* scale x)) 0
134 (* scale w) (height context-size)))
135 :left :top
136 0 0))))
137 (geometry [_]
138 (translate-geometry
139 (reduce #(->Size (+ (width %1) (width %2))
140 (max (height %1) (height %2)))
141 (->Size 0 0)
142 (map (comp translate-geometry geometry) contents)))))
144 (defn- hbox* [proportional? contents]
145 (->Box proportional? #'identity contents))
147 (defn- vbox* [proportional? contents]
148 (->Box proportional? #'->TransposedGeometry contents))
150 (defn hbox
151 "Creates a view that draws the specified content views placing them
152 horizontally."
153 [& contents]
154 (hbox* false contents))
156 (defn hbox-proportional
157 "Like hbox, but proportionally distributes the available space."
158 [& contents]
159 (hbox* true contents))
161 (defn vbox
162 "Creates a view that draws the specified content views placing them
163 horizontally."
164 [& contents]
165 (vbox* false contents))
167 (defn vbox-proportional
168 "Like vbox, but proportionally distributes the available space."
169 [& contents]
170 (vbox* true contents))
172 (defrecord BorderBox [north west south east center]
173 View
174 (render! [_]
175 (let [w *width*
176 h *height*
177 t (height (geometry north) w)
178 b (height (geometry south) w)
179 ch (- h t b)
180 l (width (geometry west) ch)
181 r (width (geometry east) ch)
182 cw (- w l r)]
183 (draw! north 0 0 w t)
184 (draw! west 0 t l ch)
185 (draw! south 0 (- h b) w b)
186 (draw! east (- w r) t r ch)
187 (draw! center l t cw ch)))
188 (geometry [_]
189 (let [ng (geometry north)
190 wg (geometry west)
191 sg (geometry south)
192 eg (geometry east)
193 cg (geometry center)
194 cw (width cg)
195 ch (max (height cg) (height wg) (height eg))
196 l (width wg ch)
197 r (width eg ch)
198 w (max (+ cw l r) (width ng) (width sg))
199 t (height ng w)
200 b (height sg w)
201 h (+ ch t b)]
202 (->Size w h))))
204 (defn border-box
205 "reginonviews => region-key view
206 Returns a View that organizes specified Views in five
207 regions (:north, :south, :east, :west, and
208 :center). Each region may contain no more than one View."
209 [& regionviews]
210 (let [regions (apply array-map regionviews)]
211 (->BorderBox (:north regions empty-view)
212 (:west regions empty-view)
213 (:south regions empty-view)
214 (:east regions empty-view)
215 (:center regions empty-view))))
217 (defn- re-split [^java.util.regex.Pattern re s]
218 (seq (.split re s)))
220 (def ^:private ^Cache text-layout-cache
221 (-> (CacheBuilder/newBuilder)
222 (.softValues)
223 (.expireAfterAccess (long 1) TimeUnit/SECONDS)
224 (.build)))
226 (defn- get-text-layout
227 [^String line ^Font font ^FontRenderContext font-context]
228 (.get text-layout-cache [line font font-context]
229 #(TextLayout. line font font-context)))
231 (defn- layout-text
232 [lines font font-context]
233 (map #(get-text-layout % font font-context) lines))
235 (defn- text-width [layouts]
236 (reduce (fn [w ^TextLayout tl] (max w (.getAdvance tl))) 0 layouts))
238 (defn- text-height [layouts]
239 (reduce (fn [w ^TextLayout tl]
240 (+ w (.getAscent tl)
241 (.getDescent tl)
242 (.getLeading tl)))
243 0 layouts))
245 (defn label
246 "Creates a view to display multiline text."
247 ([text]
248 (label :left :top text))
249 ([h-align v-align text]
250 (let [lines (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" (str text))]
251 (reify View
252 (render! [view]
253 (let [w *width*
254 h *height*
255 font (.getFont *graphics*)
256 layouts (layout-text lines font (font-context))
257 y (align-y v-align (text-height layouts) h)]
258 (loop [layouts layouts, y y]
259 (when-first [^TextLayout layout layouts]
260 (let [ascent (.getAscent layout)
261 lh (+ ascent (.getDescent layout) (.getLeading layout))
262 x (align-x h-align (.getAdvance layout) w)]
263 (.draw layout *graphics* x (+ y ascent))
264 (recur (next layouts) (+ y lh)))))))
265 (geometry [view]
266 (let [layouts (layout-text lines (theme-get :font) (font-context))
267 w (text-width layouts)
268 h (text-height layouts)]
269 (->Size w h)))))))
271 (defn- ^ImageObserver image-observer [view]
272 (reify
273 ImageObserver
274 (imageUpdate [this img infoflags x y width height]
275 (update view)
276 (zero? (bit-and infoflags
277 (bit-or ImageObserver/ALLBITS
278 ImageObserver/ABORT))))))
280 (defn image-view
281 [image-or-uri]
282 (let [^Image image (if (instance? Image image-or-uri)
283 image-or-uri
284 (.getImage (Toolkit/getDefaultToolkit)
285 ^java.net.URL image-or-uri))]
286 (.prepareImage (Toolkit/getDefaultToolkit) image -1 -1 nil)
287 (reify
288 View
289 (render! [view]
290 (repaint-on-update view)
291 (.drawImage *graphics* image 0 0 (image-observer view)))
292 (geometry [view]
293 (let [observer (image-observer view)
294 width (.getWidth image observer)
295 height (.getHeight image observer)
296 width (if (pos? width) width 1)
297 height (if (pos? height) height 1)]
298 (->Size width height))))))
300 (def ^:dynamic *miniature-thread-priority* 2)
302 (defn ref-view
303 ([view-ref]
304 (ref-view view-ref identity))
305 ([view-ref view-fn]
306 (let [v (reify
307 View
308 (render! [v]
309 (repaint-on-update v)
310 (when-let [view (view-fn @view-ref)]
311 (render! view)))
312 (geometry [_]
313 (if-let [view (view-fn @view-ref)]
314 (geometry view)
315 (->Size 1 1))))]
316 (add-watch view-ref v (fn [_ _ _ _] (update v)))
317 v)))
319 ;;
320 ;; View context decorators
321 ;;
323 (defmacro add-handlers [view & handlers]
324 "Adds event handling to the view."
325 `(let [view# ~view]
326 (decorate-view view# [t#]
327 (with-handlers t#
328 (render! view#)
329 ~@handlers))))
331 (defn themed [theme view]
332 (reify
333 View
334 (render! [_]
335 (with-theme theme
336 (apply-theme)
337 (render! view)))
338 (geometry [_]
339 (with-theme* theme geometry view))))
341 (defn hinted [hints view]
342 (reify
343 View
344 (render! [_]
345 (with-hints* hints render! view))
346 (geometry [_]
347 (if (bound? #'*graphics*)
348 (with-hints* hints geometry view)
349 (geometry view)))))
351 (defn- transform-bounds
352 ^Rectangle2D [^AffineTransform tr ^double w ^double h]
353 (.getBounds2D
354 (.createTransformedShape tr (Rectangle2D$Double. 0 0 w h))))
356 (defn transform [tr view]
357 (reify View
358 (render! [v]
359 (let [g (geometry view)
360 w (double (width g))
361 h (double (height g))
362 ^Rectangle2D bounds (transform-bounds tr w h)
363 g *graphics*]
364 (.translate g (- (.getX bounds)) (- (.getY bounds)))
365 (.transform g tr)
366 ;; TODO: scale w and h to fit *width* and *height*.
367 (draw! view 0 0 w h)))
368 (geometry [_]
369 (let [g (geometry view)
370 w (double (width g))
371 h (double (height g))
372 ^Rectangle2D bounds (transform-bounds tr w h)]
373 (->Size (.getWidth bounds) (.getHeight bounds))))))
375 (defn rotate [^double degrees view]
376 (transform
377 (AffineTransform/getRotateInstance (Math/toRadians degrees))
378 view))
380 ;;
381 ;; Measuring time
382 ;;
384 (def ^:dynamic *interval*)
386 (defn interval-view
387 "Creates a view that measures time between repaints ant draws it's
388 content with the *interval* var bound to the measured time."
389 [content]
390 (let [last-time (atom nil)]
391 (decorate-view content [_]
392 (compare-and-set! last-time nil *time*)
393 (let [lt @last-time]
394 (binding [*interval* (if (compare-and-set! last-time lt *time*)
395 (- *time* lt)
396 0)] ; already measured on parallel thread
397 (render! content))))))
399 (defn- fps-label [text]
400 (padding 5 (label :right :bottom text)))
402 (defn fps-view
403 "Creates a view that draws content and displays the
404 frames per second rate."
405 [content]
406 (let [update-interval 2E8 ; 0.2 s in nanoseconds
407 frames (ref 0)
408 prev-time (ref nil)
409 display (ref (fps-label "fps n/a"))]
410 (decorate-view content [_]
411 (draw! content)
412 (draw!
413 (dosync
414 (alter frames inc)
415 (if @prev-time
416 (let [elapsed (- *time* @prev-time)]
417 (when (> elapsed update-interval)
418 (let [fps (/ @frames (/ elapsed 1E9))]
419 (ref-set display (fps-label (format "%.1f" fps)))
420 (ref-set frames 0)
421 (ref-set prev-time *time*))))
422 (ref-set prev-time *time*))
423 @display)))))
425 ;;
426 ;; Overlays
427 ;;
429 (def ^:private ^:dynamic *above*)
431 (defn- overlay* [f & args]
432 (var-set #'*above* (conj *above* (apply partial f args))))
434 (defn- ^Point2D to-graphics-coords
435 [^AffineTransform transform x y]
436 (let [p (Point2D$Double. x y)]
437 (.transform transform p p)
438 (.transform (.createInverse (.getTransform *graphics*)) p p)
439 p))
441 (defn- draw-relative!
442 ([view transform x y]
443 (let [p (to-graphics-coords transform x y)]
444 (draw! view (.getX p) (.getY p))))
445 ([view transform x y w h]
446 (let [p (to-graphics-coords transform x y)]
447 (draw! view (.getX p) (.getY p) w h))))
449 (defn- draw-relative-aligned!
450 [view transform h-align v-align x y]
451 (let [geom (geometry view)
452 w (width geom)
453 h (height geom)
454 p (to-graphics-coords transform x y)
455 x (- (.getX p) (anchor-x geom h-align w))
456 y (- (.getY p) (anchor-y geom v-align h))]
457 (draw! view x y w h)))
459 (defn overlay!
460 "Draws view in the overlay context above the other views."
461 ([view]
462 (overlay* draw-relative! view (.getTransform *graphics*) 0 0))
463 ([view x y]
464 (overlay* draw-relative! view (.getTransform *graphics*) x y))
465 ([view x y w h]
466 (overlay* draw-relative! view (.getTransform *graphics*) x y w h)))
468 (defn overlay-aligned! [view h-align v-align x y]
469 (overlay* draw-relative-aligned!
470 view
471 (.getTransform *graphics*)
472 h-align v-align
473 x y))
475 (defn with-overlays* [recursive? f & args]
476 (binding [*above* []]
477 (apply f args)
478 (if recursive?
479 (loop [above *above*]
480 (when (seq above)
481 (var-set #'*above* [])
482 (doseq [of above]
483 (of))
484 (recur *above*)))
485 (doseq [of *above*]
486 (of)))))
488 (defmacro with-overlays [recursive? & body]
489 `(with-overlays* ~recursive? (fn [] ~@body)))
491 (defn layered
492 ([content]
493 (layered true content))
494 ([recursive? content]
495 (decorate-view content [_]
496 (with-overlays* recursive? render! content))))