view src/net/kryshen/indyvon/views.clj @ 151:cb108c6fa079

Layers are now called Views.
author Mikhail Kryshen <mikhail@kryshen.net>
date Mon, 07 Apr 2014 15:23:58 +0400
parents src/net/kryshen/indyvon/layers.clj@613bd4ac1bc0
children 9997ac717c3c
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 net.kryshen.indyvon.views
21 "Implementations of the View protocol."
22 (:use
23 (net.kryshen.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 ;; TODO: change argument order for decorators, content should be the
51 ;; last.
53 (defn padding
54 "Adds padding to the content view."
55 ([content pad]
56 (padding content pad pad pad pad))
57 ([content top left bottom right]
58 (if (== 0 top left bottom right)
59 content
60 (reify
61 View
62 (render! [l]
63 (draw! content
64 left top
65 (- *width* left right)
66 (- *height* top bottom)
67 false))
68 (geometry [l]
69 (->NestedGeometry (geometry content) top left bottom right))))))
71 (defn border
72 "Adds a border to the content view."
73 ([content]
74 (border content 1))
75 ([content thikness]
76 (border content thikness 0))
77 ([content thikness gap]
78 (let [view (padding content (+ thikness gap))
79 t (double thikness)]
80 (decorate-view view [_]
81 (render! view)
82 (with-color :border-color
83 (let [w (double *width*)
84 h (double *height*)
85 outer (Area. (Rectangle2D$Double. 0.0 0.0 w h))
86 inner (Area. (Rectangle2D$Double. t t (- w t t) (- h t t)))]
87 (.subtract outer inner)
88 (.fill *graphics* outer)))))))
90 ;; TODO: opacity and blur.
91 (defn shadow
92 "Adds a shadow to the content view."
93 ([content]
94 (shadow content 1 1))
95 ([content x-offset y-offset]
96 (let [x (if (neg? x-offset) (- x-offset) 0)
97 y (if (neg? y-offset) (- y-offset) 0)
98 abs-x (if (neg? x-offset) (- x-offset) x-offset)
99 abs-y (if (neg? y-offset) (- y-offset) y-offset)
100 shadow-x (+ x-offset x)
101 shadow-y (+ y-offset y)]
102 (reify
103 View
104 (render! [_]
105 (let [w (- *width* abs-x)
106 h (- *height* abs-y)]
107 (with-color :shadow-color
108 (.fillRect *graphics* shadow-x shadow-y w h))
109 (draw! content x y w h)))
110 (geometry [_]
111 (->NestedGeometry (geometry content)
112 y x shadow-y shadow-x))))))
114 (defn panel
115 "An opaque view using theme's alt-back-color or a custom background
116 color."
117 ([content]
118 (panel :alt-back-color content))
119 ([back-color content]
120 (decorate-view content [_]
121 (with-color back-color
122 (.fill *graphics* (Rectangle2D$Double. 0.0 0.0 *width* *height*)))
123 (render! content))))
125 (defn hbox
126 "Creates a view that draws the specified content views placing them
127 horizontally."
128 [& contents]
129 (reify
130 View
131 (render! [_]
132 (let [widths (map #(width (geometry %)) contents)
133 xs (cons 0 (reductions + widths))
134 widths-sum (last xs)
135 scale (/ *width* widths-sum)]
136 (doseq [[c w x] (map vector contents widths xs)]
137 (draw! c x 0 w *height*))))
138 (geometry [_]
139 (reduce #(->Size (+ (width %1) (width %2))
140 (max (height %1) (height %2)))
141 (->Size 0 0)
142 (map geometry contents)))))
144 (defn vbox
145 "Creates a view that draws the specified content views placing them
146 vertically."
147 [& contents]
148 (reify
149 View
150 (render! [_]
151 (let [heights (map #(height (geometry %)) contents)
152 ys (cons 0 (reductions + heights))
153 heights-sum (last ys)
154 scale (/ *height* heights-sum)]
155 (doseq [[c h y] (map vector contents heights ys)]
156 (draw! c 0 y *width* h))))
157 (geometry [_]
158 (reduce #(->Size (max (width %1) (width %2))
159 (+ (height %1) (height %2)))
160 (->Size 0 0)
161 (map geometry contents)))))
163 (defn- re-split [^java.util.regex.Pattern re s]
164 (seq (.split re s)))
166 (def ^:private ^Cache text-layout-cache
167 (-> (CacheBuilder/newBuilder)
168 (.softValues)
169 (.expireAfterAccess (long 1) TimeUnit/SECONDS)
170 (.build)))
172 (defn- get-text-layout
173 [^String line ^Font font ^FontRenderContext font-context]
174 (.get text-layout-cache [line font font-context]
175 #(TextLayout. line font font-context)))
177 (defn- layout-text
178 [lines font font-context]
179 (map #(get-text-layout % font font-context) lines))
181 (defn- text-width [layouts]
182 (reduce (fn [w ^TextLayout tl] (max w (.getAdvance tl))) 0 layouts))
184 (defn- text-height [layouts]
185 (reduce (fn [w ^TextLayout tl]
186 (+ w (.getAscent tl)
187 (.getDescent tl)
188 (.getLeading tl)))
189 0 layouts))
191 (defn label
192 "Creates a view to display multiline text."
193 ([text]
194 (label text :left :top))
195 ([text h-align v-align]
196 (let [lines (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" (str text))]
197 (reify View
198 (render! [view]
199 (let [w *width*
200 h *height*
201 font (.getFont *graphics*)
202 layouts (layout-text lines font (font-context))
203 y (align-y v-align (text-height layouts) h)]
204 (loop [layouts layouts, y y]
205 (when-first [^TextLayout layout layouts]
206 (let [ascent (.getAscent layout)
207 lh (+ ascent (.getDescent layout) (.getLeading layout))
208 x (align-x h-align (.getAdvance layout) w)]
209 (.draw layout *graphics* x (+ y ascent))
210 (recur (next layouts) (+ y lh)))))))
211 (geometry [view]
212 (let [layouts (layout-text lines (:font *theme*) (font-context))
213 w (text-width layouts)
214 h (text-height layouts)]
215 (->Size w h)))))))
217 (defn- ^ImageObserver image-observer [view]
218 (reify
219 ImageObserver
220 (imageUpdate [this img infoflags x y width height]
221 (update view)
222 (zero? (bit-and infoflags
223 (bit-or ImageObserver/ALLBITS
224 ImageObserver/ABORT))))))
226 (defn image-view
227 [image-or-uri]
228 (let [^Image image (if (instance? Image image-or-uri)
229 image-or-uri
230 (.getImage (Toolkit/getDefaultToolkit)
231 ^java.net.URL image-or-uri))]
232 (.prepareImage (Toolkit/getDefaultToolkit) image -1 -1 nil)
233 (reify
234 View
235 (render! [view]
236 (repaint-on-update view)
237 (.drawImage *graphics* image 0 0 (image-observer view)))
238 (geometry [view]
239 (let [observer (image-observer view)
240 width (.getWidth image observer)
241 height (.getHeight image observer)
242 width (if (pos? width) width 1)
243 height (if (pos? height) height 1)]
244 (->Size width height))))))
246 (def ^:dynamic *miniature-thread-priority* 2)
248 (defn ref-view
249 [view-ref]
250 (let [l (reify
251 View
252 (render! [l]
253 (repaint-on-update l)
254 (if-let [view @view-ref]
255 (render! view)))
256 (geometry [_]
257 (if-let [view @view-ref]
258 (geometry view)
259 (->Size 1 1))))]
260 (add-watch view-ref l (fn [_ _ _ _] (update l)))
261 l))
263 ;;
264 ;; View context decorators
265 ;;
267 (defmacro handler [view & handlers]
268 "Adds event handling to the view."
269 `(let [view# ~view]
270 (decorate-view view# [t#]
271 (with-handlers t#
272 (render! view#)
273 ~@handlers))))
275 (defn themed [view & map-or-keyvals]
276 (let [theme (if (== (count map-or-keyvals) 1)
277 (first map-or-keyvals)
278 (apply array-map map-or-keyvals))]
279 (reify
280 View
281 (render! [_]
282 (with-theme theme
283 (render! view)))
284 (geometry [_]
285 (with-theme theme
286 (geometry view))))))
288 (defn hinted [view & map-or-keyvals]
289 (let [hints (if (== (count map-or-keyvals) 1)
290 (first map-or-keyvals)
291 (apply array-map map-or-keyvals))]
292 (decorate-view view [_]
293 (with-hints* hints render! view))))
295 ;;
296 ;; Measuring time
297 ;;
299 (def ^:dynamic *interval*)
301 (defn interval-view
302 "Creates a view that measures time between repaints ant draws it's
303 content with the *interval* var bound to the measured time."
304 [content]
305 (let [last-time (atom nil)]
306 (decorate-view content [_]
307 (compare-and-set! last-time nil *time*)
308 (let [lt @last-time]
309 (binding [*interval* (if (compare-and-set! last-time lt *time*)
310 (- *time* lt)
311 0)] ; already measured on parallel thread
312 (render! content))))))
314 (defn- fps-label [text]
315 (padding (label text :right :bottom) 5))
317 (defn fps-view
318 "Creates a view that draws content and displays the
319 frames per second rate."
320 [content]
321 (let [update-interval 2E8 ; 0.2 s in nanoseconds
322 frames (ref 0)
323 prev-time (ref nil)
324 display (ref (fps-label "fps n/a"))]
325 (decorate-view content [_]
326 (draw! content)
327 (draw!
328 (dosync
329 (alter frames inc)
330 (if @prev-time
331 (let [elapsed (- *time* @prev-time)]
332 (when (> elapsed update-interval)
333 (let [fps (/ @frames (/ elapsed 1E9))]
334 (ref-set display (fps-label (format "%.1f" fps)))
335 (ref-set frames 0)
336 (ref-set prev-time *time*))))
337 (ref-set prev-time *time*))
338 @display)))))
340 ;;
341 ;; Overlays
342 ;;
344 (def ^:private ^:dynamic *above*)
346 (defn- overlay* [f & args]
347 (var-set #'*above* (conj *above* (apply partial f args))))
349 (defn- ^Point2D to-graphics-coords
350 [^AffineTransform transform x y]
351 (let [p (Point2D$Double. x y)]
352 (.transform transform p p)
353 (.transform (.createInverse (.getTransform *graphics*)) p p)
354 p))
356 (defn- draw-relative!
357 ([view transform x y]
358 (let [p (to-graphics-coords transform x y)]
359 (draw! view (.getX p) (.getY p))))
360 ([view transform x y w h]
361 (let [p (to-graphics-coords transform x y)]
362 (draw! view (.getX p) (.getY p) w h))))
364 (defn- draw-relative-aligned!
365 [view transform h-align v-align x y]
366 (let [geom (geometry view)
367 w (width geom)
368 h (height geom)
369 p (to-graphics-coords transform x y)
370 x (- (.getX p) (anchor-x geom h-align w))
371 y (- (.getY p) (anchor-y geom v-align h))]
372 (draw! view x y w h)))
374 (defn overlay!
375 "Draws view in the overlay context above the other views."
376 ([view]
377 (overlay* draw-relative! view (.getTransform *graphics*) 0 0))
378 ([view x y]
379 (overlay* draw-relative! view (.getTransform *graphics*) x y))
380 ([view x y w h]
381 (overlay* draw-relative! view (.getTransform *graphics*) x y w h)))
383 (defn overlay-aligned! [view h-align v-align x y]
384 (overlay* draw-relative-aligned!
385 view (.getTransform *graphics*)
386 h-align v-align x y))
388 (defn with-overlays* [rec? f & args]
389 (binding [*above* []]
390 (apply f args)
391 (if rec?
392 (loop [above *above*]
393 (when (seq above)
394 (var-set #'*above* [])
395 (doseq [f above]
396 (f))
397 (recur *above*)))
398 (doseq [of *above*]
399 (of)))))
401 (defmacro with-overlays [rec? & body]
402 `(with-overlays* ~rec? (fn [] ~@body)))
404 (defn layered
405 ([content]
406 (layered content true))
407 ([content rec?]
408 (decorate-view content [_]
409 (with-overlays* rec? render! content))))