Mercurial > hg > indyvon
view src/indyvon/views.clj @ 159:2a93c3ca0244
Variants of vbox and hbox that fill available space.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Tue, 18 Nov 2014 00:41:05 +0300 |
| parents | e0063c1d0f7f |
| children | d149f03d1feb |
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$Double Point2D
28 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 (defn hbox-proportional [& contents]
123 (apply hbox* true contents))
125 (defn hbox
126 "Creates a view that draws the specified content views placing them
127 horizontally."
128 [& contents]
129 (apply hbox* false contents))
131 (defn- hbox*
132 [proportional? & contents]
133 (reify
134 View
135 (render! [_]
136 (let [widths (map #(width (geometry %)) contents)
137 xs (cons 0 (reductions + widths))
138 widths-sum (last xs)
139 scale (if proportional? (/ *width* widths-sum) 1)]
140 (doseq [[c w x] (map vector contents widths xs)]
141 (draw! c (* scale x) 0 (* scale w) *height*))))
142 (geometry [_]
143 (reduce #(->Size (+ (width %1) (width %2))
144 (max (height %1) (height %2)))
145 (->Size 0 0)
146 (map geometry contents)))))
148 (defn vbox-proportional [& contents]
149 (apply vbox* true contents))
151 (defn vbox
152 "Creates a view that draws the specified content views placing them
153 horizontally."
154 [& contents]
155 (apply vbox* false contents))
157 (defn vbox*
158 [proportional? & contents]
159 (reify
160 View
161 (render! [_]
162 (let [heights (map #(height (geometry %)) contents)
163 ys (cons 0 (reductions + heights))
164 heights-sum (last ys)
165 scale (if proportional? (/ *height* heights-sum) 1)]
166 (doseq [[c h y] (map vector contents heights ys)]
167 (draw! c 0 (* scale y) *width* (* scale h)))))
168 (geometry [_]
169 (reduce #(->Size (max (width %1) (width %2))
170 (+ (height %1) (height %2)))
171 (->Size 0 0)
172 (map geometry contents)))))
174 (defn- re-split [^java.util.regex.Pattern re s]
175 (seq (.split re s)))
177 (def ^:private ^Cache text-layout-cache
178 (-> (CacheBuilder/newBuilder)
179 (.softValues)
180 (.expireAfterAccess (long 1) TimeUnit/SECONDS)
181 (.build)))
183 (defn- get-text-layout
184 [^String line ^Font font ^FontRenderContext font-context]
185 (.get text-layout-cache [line font font-context]
186 #(TextLayout. line font font-context)))
188 (defn- layout-text
189 [lines font font-context]
190 (map #(get-text-layout % font font-context) lines))
192 (defn- text-width [layouts]
193 (reduce (fn [w ^TextLayout tl] (max w (.getAdvance tl))) 0 layouts))
195 (defn- text-height [layouts]
196 (reduce (fn [w ^TextLayout tl]
197 (+ w (.getAscent tl)
198 (.getDescent tl)
199 (.getLeading tl)))
200 0 layouts))
202 (defn label
203 "Creates a view to display multiline text."
204 ([text]
205 (label :left :top text))
206 ([h-align v-align text]
207 (let [lines (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" (str text))]
208 (reify View
209 (render! [view]
210 (let [w *width*
211 h *height*
212 font (.getFont *graphics*)
213 layouts (layout-text lines font (font-context))
214 y (align-y v-align (text-height layouts) h)]
215 (loop [layouts layouts, y y]
216 (when-first [^TextLayout layout layouts]
217 (let [ascent (.getAscent layout)
218 lh (+ ascent (.getDescent layout) (.getLeading layout))
219 x (align-x h-align (.getAdvance layout) w)]
220 (.draw layout *graphics* x (+ y ascent))
221 (recur (next layouts) (+ y lh)))))))
222 (geometry [view]
223 (let [layouts (layout-text lines (theme-get :font) (font-context))
224 w (text-width layouts)
225 h (text-height layouts)]
226 (->Size w h)))))))
228 (defn- ^ImageObserver image-observer [view]
229 (reify
230 ImageObserver
231 (imageUpdate [this img infoflags x y width height]
232 (update view)
233 (zero? (bit-and infoflags
234 (bit-or ImageObserver/ALLBITS
235 ImageObserver/ABORT))))))
237 (defn image-view
238 [image-or-uri]
239 (let [^Image image (if (instance? Image image-or-uri)
240 image-or-uri
241 (.getImage (Toolkit/getDefaultToolkit)
242 ^java.net.URL image-or-uri))]
243 (.prepareImage (Toolkit/getDefaultToolkit) image -1 -1 nil)
244 (reify
245 View
246 (render! [view]
247 (repaint-on-update view)
248 (.drawImage *graphics* image 0 0 (image-observer view)))
249 (geometry [view]
250 (let [observer (image-observer view)
251 width (.getWidth image observer)
252 height (.getHeight image observer)
253 width (if (pos? width) width 1)
254 height (if (pos? height) height 1)]
255 (->Size width height))))))
257 (def ^:dynamic *miniature-thread-priority* 2)
259 (defn ref-view
260 [view-ref]
261 (let [l (reify
262 View
263 (render! [l]
264 (repaint-on-update l)
265 (if-let [view @view-ref]
266 (render! view)))
267 (geometry [_]
268 (if-let [view @view-ref]
269 (geometry view)
270 (->Size 1 1))))]
271 (add-watch view-ref l (fn [_ _ _ _] (update l)))
272 l))
274 ;;
275 ;; View context decorators
276 ;;
278 (defmacro add-handlers [view & handlers]
279 "Adds event handling to the view."
280 `(let [view# ~view]
281 (decorate-view view# [t#]
282 (with-handlers t#
283 (render! view#)
284 ~@handlers))))
286 (defn themed [theme view]
287 (reify
288 View
289 (render! [_]
290 (with-theme theme
291 (apply-theme)
292 (render! view)))
293 (geometry [_]
294 (with-theme* theme geometry view))))
296 (defn hinted [hints view]
297 (reify
298 View
299 (render! [_]
300 (with-hints* hints render! view))
301 (geometry [_]
302 (with-hints* hints geometry view))))
304 ;;
305 ;; Measuring time
306 ;;
308 (def ^:dynamic *interval*)
310 (defn interval-view
311 "Creates a view that measures time between repaints ant draws it's
312 content with the *interval* var bound to the measured time."
313 [content]
314 (let [last-time (atom nil)]
315 (decorate-view content [_]
316 (compare-and-set! last-time nil *time*)
317 (let [lt @last-time]
318 (binding [*interval* (if (compare-and-set! last-time lt *time*)
319 (- *time* lt)
320 0)] ; already measured on parallel thread
321 (render! content))))))
323 (defn- fps-label [text]
324 (padding 5 (label :right :bottom text)))
326 (defn fps-view
327 "Creates a view that draws content and displays the
328 frames per second rate."
329 [content]
330 (let [update-interval 2E8 ; 0.2 s in nanoseconds
331 frames (ref 0)
332 prev-time (ref nil)
333 display (ref (fps-label "fps n/a"))]
334 (decorate-view content [_]
335 (draw! content)
336 (draw!
337 (dosync
338 (alter frames inc)
339 (if @prev-time
340 (let [elapsed (- *time* @prev-time)]
341 (when (> elapsed update-interval)
342 (let [fps (/ @frames (/ elapsed 1E9))]
343 (ref-set display (fps-label (format "%.1f" fps)))
344 (ref-set frames 0)
345 (ref-set prev-time *time*))))
346 (ref-set prev-time *time*))
347 @display)))))
349 ;;
350 ;; Overlays
351 ;;
353 (def ^:private ^:dynamic *above*)
355 (defn- overlay* [f & args]
356 (var-set #'*above* (conj *above* (apply partial f args))))
358 (defn- ^Point2D to-graphics-coords
359 [^AffineTransform transform x y]
360 (let [p (Point2D$Double. x y)]
361 (.transform transform p p)
362 (.transform (.createInverse (.getTransform *graphics*)) p p)
363 p))
365 (defn- draw-relative!
366 ([view transform x y]
367 (let [p (to-graphics-coords transform x y)]
368 (draw! view (.getX p) (.getY p))))
369 ([view transform x y w h]
370 (let [p (to-graphics-coords transform x y)]
371 (draw! view (.getX p) (.getY p) w h))))
373 (defn- draw-relative-aligned!
374 [view transform h-align v-align x y]
375 (let [geom (geometry view)
376 w (width geom)
377 h (height geom)
378 p (to-graphics-coords transform x y)
379 x (- (.getX p) (anchor-x geom h-align w))
380 y (- (.getY p) (anchor-y geom v-align h))]
381 (draw! view x y w h)))
383 (defn overlay!
384 "Draws view in the overlay context above the other views."
385 ([view]
386 (overlay* draw-relative! view (.getTransform *graphics*) 0 0))
387 ([view x y]
388 (overlay* draw-relative! view (.getTransform *graphics*) x y))
389 ([view x y w h]
390 (overlay* draw-relative! view (.getTransform *graphics*) x y w h)))
392 (defn overlay-aligned! [view h-align v-align x y]
393 (overlay* draw-relative-aligned!
394 view
395 (.getTransform *graphics*)
396 h-align v-align
397 x y))
399 (defn with-overlays* [recursive? f & args]
400 (binding [*above* []]
401 (apply f args)
402 (if recursive?
403 (loop [above *above*]
404 (when (seq above)
405 (var-set #'*above* [])
406 (doseq [of above]
407 (of))
408 (recur *above*)))
409 (doseq [of *above*]
410 (of)))))
412 (defmacro with-overlays [recursive? & body]
413 `(with-overlays* ~recursive? (fn [] ~@body)))
415 (defn layered
416 ([content]
417 (layered true content))
418 ([recursive? content]
419 (decorate-view content [_]
420 (with-overlays* recursive? render! content))))