view src/indyvon/views.clj @ 157:4fea68ec12f4

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