Mercurial > hg > indyvon
view src/indyvon/views.clj @ 160:d149f03d1feb
Reworked implementation of hbox and vbox (DRY).
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Tue, 18 Nov 2014 17:00:35 +0300 |
| parents | 2a93c3ca0244 |
| children | acda6344bcb7 |
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 (defn- re-split [^java.util.regex.Pattern re s]
169 (seq (.split re s)))
171 (def ^:private ^Cache text-layout-cache
172 (-> (CacheBuilder/newBuilder)
173 (.softValues)
174 (.expireAfterAccess (long 1) TimeUnit/SECONDS)
175 (.build)))
177 (defn- get-text-layout
178 [^String line ^Font font ^FontRenderContext font-context]
179 (.get text-layout-cache [line font font-context]
180 #(TextLayout. line font font-context)))
182 (defn- layout-text
183 [lines font font-context]
184 (map #(get-text-layout % font font-context) lines))
186 (defn- text-width [layouts]
187 (reduce (fn [w ^TextLayout tl] (max w (.getAdvance tl))) 0 layouts))
189 (defn- text-height [layouts]
190 (reduce (fn [w ^TextLayout tl]
191 (+ w (.getAscent tl)
192 (.getDescent tl)
193 (.getLeading tl)))
194 0 layouts))
196 (defn label
197 "Creates a view to display multiline text."
198 ([text]
199 (label :left :top text))
200 ([h-align v-align text]
201 (let [lines (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" (str text))]
202 (reify View
203 (render! [view]
204 (let [w *width*
205 h *height*
206 font (.getFont *graphics*)
207 layouts (layout-text lines font (font-context))
208 y (align-y v-align (text-height layouts) h)]
209 (loop [layouts layouts, y y]
210 (when-first [^TextLayout layout layouts]
211 (let [ascent (.getAscent layout)
212 lh (+ ascent (.getDescent layout) (.getLeading layout))
213 x (align-x h-align (.getAdvance layout) w)]
214 (.draw layout *graphics* x (+ y ascent))
215 (recur (next layouts) (+ y lh)))))))
216 (geometry [view]
217 (let [layouts (layout-text lines (theme-get :font) (font-context))
218 w (text-width layouts)
219 h (text-height layouts)]
220 (->Size w h)))))))
222 (defn- ^ImageObserver image-observer [view]
223 (reify
224 ImageObserver
225 (imageUpdate [this img infoflags x y width height]
226 (update view)
227 (zero? (bit-and infoflags
228 (bit-or ImageObserver/ALLBITS
229 ImageObserver/ABORT))))))
231 (defn image-view
232 [image-or-uri]
233 (let [^Image image (if (instance? Image image-or-uri)
234 image-or-uri
235 (.getImage (Toolkit/getDefaultToolkit)
236 ^java.net.URL image-or-uri))]
237 (.prepareImage (Toolkit/getDefaultToolkit) image -1 -1 nil)
238 (reify
239 View
240 (render! [view]
241 (repaint-on-update view)
242 (.drawImage *graphics* image 0 0 (image-observer view)))
243 (geometry [view]
244 (let [observer (image-observer view)
245 width (.getWidth image observer)
246 height (.getHeight image observer)
247 width (if (pos? width) width 1)
248 height (if (pos? height) height 1)]
249 (->Size width height))))))
251 (def ^:dynamic *miniature-thread-priority* 2)
253 (defn ref-view
254 [view-ref]
255 (let [l (reify
256 View
257 (render! [l]
258 (repaint-on-update l)
259 (if-let [view @view-ref]
260 (render! view)))
261 (geometry [_]
262 (if-let [view @view-ref]
263 (geometry view)
264 (->Size 1 1))))]
265 (add-watch view-ref l (fn [_ _ _ _] (update l)))
266 l))
268 ;;
269 ;; View context decorators
270 ;;
272 (defmacro add-handlers [view & handlers]
273 "Adds event handling to the view."
274 `(let [view# ~view]
275 (decorate-view view# [t#]
276 (with-handlers t#
277 (render! view#)
278 ~@handlers))))
280 (defn themed [theme view]
281 (reify
282 View
283 (render! [_]
284 (with-theme theme
285 (apply-theme)
286 (render! view)))
287 (geometry [_]
288 (with-theme* theme geometry view))))
290 (defn hinted [hints view]
291 (reify
292 View
293 (render! [_]
294 (with-hints* hints render! view))
295 (geometry [_]
296 (with-hints* hints geometry view))))
298 ;;
299 ;; Measuring time
300 ;;
302 (def ^:dynamic *interval*)
304 (defn interval-view
305 "Creates a view that measures time between repaints ant draws it's
306 content with the *interval* var bound to the measured time."
307 [content]
308 (let [last-time (atom nil)]
309 (decorate-view content [_]
310 (compare-and-set! last-time nil *time*)
311 (let [lt @last-time]
312 (binding [*interval* (if (compare-and-set! last-time lt *time*)
313 (- *time* lt)
314 0)] ; already measured on parallel thread
315 (render! content))))))
317 (defn- fps-label [text]
318 (padding 5 (label :right :bottom text)))
320 (defn fps-view
321 "Creates a view that draws content and displays the
322 frames per second rate."
323 [content]
324 (let [update-interval 2E8 ; 0.2 s in nanoseconds
325 frames (ref 0)
326 prev-time (ref nil)
327 display (ref (fps-label "fps n/a"))]
328 (decorate-view content [_]
329 (draw! content)
330 (draw!
331 (dosync
332 (alter frames inc)
333 (if @prev-time
334 (let [elapsed (- *time* @prev-time)]
335 (when (> elapsed update-interval)
336 (let [fps (/ @frames (/ elapsed 1E9))]
337 (ref-set display (fps-label (format "%.1f" fps)))
338 (ref-set frames 0)
339 (ref-set prev-time *time*))))
340 (ref-set prev-time *time*))
341 @display)))))
343 ;;
344 ;; Overlays
345 ;;
347 (def ^:private ^:dynamic *above*)
349 (defn- overlay* [f & args]
350 (var-set #'*above* (conj *above* (apply partial f args))))
352 (defn- ^Point2D to-graphics-coords
353 [^AffineTransform transform x y]
354 (let [p (Point2D$Double. x y)]
355 (.transform transform p p)
356 (.transform (.createInverse (.getTransform *graphics*)) p p)
357 p))
359 (defn- draw-relative!
360 ([view transform x y]
361 (let [p (to-graphics-coords transform x y)]
362 (draw! view (.getX p) (.getY p))))
363 ([view transform x y w h]
364 (let [p (to-graphics-coords transform x y)]
365 (draw! view (.getX p) (.getY p) w h))))
367 (defn- draw-relative-aligned!
368 [view transform h-align v-align x y]
369 (let [geom (geometry view)
370 w (width geom)
371 h (height geom)
372 p (to-graphics-coords transform x y)
373 x (- (.getX p) (anchor-x geom h-align w))
374 y (- (.getY p) (anchor-y geom v-align h))]
375 (draw! view x y w h)))
377 (defn overlay!
378 "Draws view in the overlay context above the other views."
379 ([view]
380 (overlay* draw-relative! view (.getTransform *graphics*) 0 0))
381 ([view x y]
382 (overlay* draw-relative! view (.getTransform *graphics*) x y))
383 ([view x y w h]
384 (overlay* draw-relative! view (.getTransform *graphics*) x y w h)))
386 (defn overlay-aligned! [view h-align v-align x y]
387 (overlay* draw-relative-aligned!
388 view
389 (.getTransform *graphics*)
390 h-align v-align
391 x y))
393 (defn with-overlays* [recursive? f & args]
394 (binding [*above* []]
395 (apply f args)
396 (if recursive?
397 (loop [above *above*]
398 (when (seq above)
399 (var-set #'*above* [])
400 (doseq [of above]
401 (of))
402 (recur *above*)))
403 (doseq [of *above*]
404 (of)))))
406 (defmacro with-overlays [recursive? & body]
407 `(with-overlays* ~recursive? (fn [] ~@body)))
409 (defn layered
410 ([content]
411 (layered true content))
412 ([recursive? content]
413 (decorate-view content [_]
414 (with-overlays* recursive? render! content))))