Mercurial > hg > indyvon
view src/indyvon/views.clj @ 166:c5b37c658161
Added ref-view argument to specify a function for converting ref value to View.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Fri, 28 Nov 2014 23:16:23 +0300 |
| parents | dc3ed475c6d6 |
| children | 5b80af180da0 |
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 (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 [& contents]
157 (hbox* true contents))
159 (defn vbox
160 "Creates a view that draws the specified content views placing them
161 horizontally."
162 [& contents]
163 (vbox* false contents))
165 (defn vbox-proportional [& contents]
166 (vbox* true contents))
168 (defrecord BorderBox [north west south east center]
169 View
170 (render! [_]
171 (let [w *width*
172 h *height*
173 t (height (geometry north) w)
174 b (height (geometry south) w)
175 ch (- h t b)
176 l (width (geometry west) ch)
177 r (width (geometry east) ch)
178 cw (- w l r)]
179 (draw! north 0 0 w t)
180 (draw! west 0 t l ch)
181 (draw! south 0 (- h b) w b)
182 (draw! east (- w r) t r ch)
183 (draw! center l t cw ch)))
184 (geometry [_]
185 (let [ng (geometry north)
186 wg (geometry west)
187 sg (geometry south)
188 eg (geometry east)
189 cg (geometry center)
190 cw (width cg)
191 ch (max (height cg) (height wg) (height eg))
192 l (width wg ch)
193 r (width eg ch)
194 w (max (+ cw l r) (width ng) (width sg))
195 t (height ng w)
196 b (height sg w)
197 h (+ ch t b)]
198 (->Size w h))))
200 (defn border-box
201 "reginonviews => region-key view
202 Returns a View that organizes specified Views in five
203 regions (:north, :south, :east, :west, and
204 :center). Each region may contain no more than one View."
205 [& regionviews]
206 (let [regions (apply array-map regionviews)]
207 (->BorderBox (:north regions empty-view)
208 (:west regions empty-view)
209 (:south regions empty-view)
210 (:east regions empty-view)
211 (:center regions empty-view))))
213 (defn- re-split [^java.util.regex.Pattern re s]
214 (seq (.split re s)))
216 (def ^:private ^Cache text-layout-cache
217 (-> (CacheBuilder/newBuilder)
218 (.softValues)
219 (.expireAfterAccess (long 1) TimeUnit/SECONDS)
220 (.build)))
222 (defn- get-text-layout
223 [^String line ^Font font ^FontRenderContext font-context]
224 (.get text-layout-cache [line font font-context]
225 #(TextLayout. line font font-context)))
227 (defn- layout-text
228 [lines font font-context]
229 (map #(get-text-layout % font font-context) lines))
231 (defn- text-width [layouts]
232 (reduce (fn [w ^TextLayout tl] (max w (.getAdvance tl))) 0 layouts))
234 (defn- text-height [layouts]
235 (reduce (fn [w ^TextLayout tl]
236 (+ w (.getAscent tl)
237 (.getDescent tl)
238 (.getLeading tl)))
239 0 layouts))
241 (defn label
242 "Creates a view to display multiline text."
243 ([text]
244 (label :left :top text))
245 ([h-align v-align text]
246 (let [lines (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" (str text))]
247 (reify View
248 (render! [view]
249 (let [w *width*
250 h *height*
251 font (.getFont *graphics*)
252 layouts (layout-text lines font (font-context))
253 y (align-y v-align (text-height layouts) h)]
254 (loop [layouts layouts, y y]
255 (when-first [^TextLayout layout layouts]
256 (let [ascent (.getAscent layout)
257 lh (+ ascent (.getDescent layout) (.getLeading layout))
258 x (align-x h-align (.getAdvance layout) w)]
259 (.draw layout *graphics* x (+ y ascent))
260 (recur (next layouts) (+ y lh)))))))
261 (geometry [view]
262 (let [layouts (layout-text lines (theme-get :font) (font-context))
263 w (text-width layouts)
264 h (text-height layouts)]
265 (->Size w h)))))))
267 (defn- ^ImageObserver image-observer [view]
268 (reify
269 ImageObserver
270 (imageUpdate [this img infoflags x y width height]
271 (update view)
272 (zero? (bit-and infoflags
273 (bit-or ImageObserver/ALLBITS
274 ImageObserver/ABORT))))))
276 (defn image-view
277 [image-or-uri]
278 (let [^Image image (if (instance? Image image-or-uri)
279 image-or-uri
280 (.getImage (Toolkit/getDefaultToolkit)
281 ^java.net.URL image-or-uri))]
282 (.prepareImage (Toolkit/getDefaultToolkit) image -1 -1 nil)
283 (reify
284 View
285 (render! [view]
286 (repaint-on-update view)
287 (.drawImage *graphics* image 0 0 (image-observer view)))
288 (geometry [view]
289 (let [observer (image-observer view)
290 width (.getWidth image observer)
291 height (.getHeight image observer)
292 width (if (pos? width) width 1)
293 height (if (pos? height) height 1)]
294 (->Size width height))))))
296 (def ^:dynamic *miniature-thread-priority* 2)
298 (defn ref-view
299 ([view-ref]
300 (ref-view view-ref identity))
301 ([view-ref view-fn]
302 (let [v (reify
303 View
304 (render! [v]
305 (repaint-on-update v)
306 (when-let [view (view-fn @view-ref)]
307 (render! view)))
308 (geometry [_]
309 (if-let [view (view-fn @view-ref)]
310 (geometry view)
311 (->Size 1 1))))]
312 (add-watch view-ref v (fn [_ _ _ _] (update v)))
313 v)))
315 ;;
316 ;; View context decorators
317 ;;
319 (defmacro add-handlers [view & handlers]
320 "Adds event handling to the view."
321 `(let [view# ~view]
322 (decorate-view view# [t#]
323 (with-handlers t#
324 (render! view#)
325 ~@handlers))))
327 (defn themed [theme view]
328 (reify
329 View
330 (render! [_]
331 (with-theme theme
332 (apply-theme)
333 (render! view)))
334 (geometry [_]
335 (with-theme* theme geometry view))))
337 (defn hinted [hints view]
338 (reify
339 View
340 (render! [_]
341 (with-hints* hints render! view))
342 (geometry [_]
343 (if (bound? #'*graphics*)
344 (with-hints* hints geometry view)
345 (geometry view)))))
347 ;;
348 ;; Measuring time
349 ;;
351 (def ^:dynamic *interval*)
353 (defn interval-view
354 "Creates a view that measures time between repaints ant draws it's
355 content with the *interval* var bound to the measured time."
356 [content]
357 (let [last-time (atom nil)]
358 (decorate-view content [_]
359 (compare-and-set! last-time nil *time*)
360 (let [lt @last-time]
361 (binding [*interval* (if (compare-and-set! last-time lt *time*)
362 (- *time* lt)
363 0)] ; already measured on parallel thread
364 (render! content))))))
366 (defn- fps-label [text]
367 (padding 5 (label :right :bottom text)))
369 (defn fps-view
370 "Creates a view that draws content and displays the
371 frames per second rate."
372 [content]
373 (let [update-interval 2E8 ; 0.2 s in nanoseconds
374 frames (ref 0)
375 prev-time (ref nil)
376 display (ref (fps-label "fps n/a"))]
377 (decorate-view content [_]
378 (draw! content)
379 (draw!
380 (dosync
381 (alter frames inc)
382 (if @prev-time
383 (let [elapsed (- *time* @prev-time)]
384 (when (> elapsed update-interval)
385 (let [fps (/ @frames (/ elapsed 1E9))]
386 (ref-set display (fps-label (format "%.1f" fps)))
387 (ref-set frames 0)
388 (ref-set prev-time *time*))))
389 (ref-set prev-time *time*))
390 @display)))))
392 ;;
393 ;; Overlays
394 ;;
396 (def ^:private ^:dynamic *above*)
398 (defn- overlay* [f & args]
399 (var-set #'*above* (conj *above* (apply partial f args))))
401 (defn- ^Point2D to-graphics-coords
402 [^AffineTransform transform x y]
403 (let [p (Point2D$Double. x y)]
404 (.transform transform p p)
405 (.transform (.createInverse (.getTransform *graphics*)) p p)
406 p))
408 (defn- draw-relative!
409 ([view transform x y]
410 (let [p (to-graphics-coords transform x y)]
411 (draw! view (.getX p) (.getY p))))
412 ([view transform x y w h]
413 (let [p (to-graphics-coords transform x y)]
414 (draw! view (.getX p) (.getY p) w h))))
416 (defn- draw-relative-aligned!
417 [view transform h-align v-align x y]
418 (let [geom (geometry view)
419 w (width geom)
420 h (height geom)
421 p (to-graphics-coords transform x y)
422 x (- (.getX p) (anchor-x geom h-align w))
423 y (- (.getY p) (anchor-y geom v-align h))]
424 (draw! view x y w h)))
426 (defn overlay!
427 "Draws view in the overlay context above the other views."
428 ([view]
429 (overlay* draw-relative! view (.getTransform *graphics*) 0 0))
430 ([view x y]
431 (overlay* draw-relative! view (.getTransform *graphics*) x y))
432 ([view x y w h]
433 (overlay* draw-relative! view (.getTransform *graphics*) x y w h)))
435 (defn overlay-aligned! [view h-align v-align x y]
436 (overlay* draw-relative-aligned!
437 view
438 (.getTransform *graphics*)
439 h-align v-align
440 x y))
442 (defn with-overlays* [recursive? f & args]
443 (binding [*above* []]
444 (apply f args)
445 (if recursive?
446 (loop [above *above*]
447 (when (seq above)
448 (var-set #'*above* [])
449 (doseq [of above]
450 (of))
451 (recur *above*)))
452 (doseq [of *above*]
453 (of)))))
455 (defmacro with-overlays [recursive? & body]
456 `(with-overlays* ~recursive? (fn [] ~@body)))
458 (defn layered
459 ([content]
460 (layered true content))
461 ([recursive? content]
462 (decorate-view content [_]
463 (with-overlays* recursive? render! content))))