Mercurial > hg > indyvon
view src/net/kryshen/indyvon/layers.clj @ 74:a823dd0c2736
LGPL3
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Mon, 30 Aug 2010 20:04:21 +0400 |
| parents | 59e1810c0278 |
| children | dafd4ff9d313 |
line source
1 ;;
2 ;; Copyright 2010 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.layers
21 "Implementations of Layer protocol."
22 (:use
23 (net.kryshen.indyvon core async))
24 (:import
25 (net.kryshen.indyvon.core Size Location)
26 (java.lang.ref SoftReference)
27 (java.awt Font Cursor Image Toolkit)
28 (java.awt.image ImageObserver)
29 (java.awt.font FontRenderContext TextLayout)))
31 ;; Define as macro to avoid unnecessary calculation of inner and outer
32 ;; sizes in the first case.
33 (defmacro align-xy [inner outer align first center last]
34 `(case ~align
35 ~first 0
36 ~center (/ (- ~outer ~inner) 2)
37 ~last (- ~outer ~inner)))
39 (defmacro align-x [inner outer align]
40 `(align-xy ~inner ~outer ~align :left :center :right))
42 (defmacro align-y [inner outer align]
43 `(align-xy ~inner ~outer ~align :top :center :bottom))
45 (defmacro decorate-layer
46 "Decorate Layer and Anchored replacing render! implementation."
47 [layer & render-tail]
48 `(reify
49 Layer
50 (render! ~@render-tail)
51 (layer-size [t#] (layer-size ~layer))
52 Anchored
53 (anchor [t# xa# ya#] (anchor ~layer xa# ya#))))
55 (defn padding
56 "Decorates layer adding padding."
57 ([content pad]
58 (padding content pad pad pad pad))
59 ([content top left bottom right]
60 (if (== 0 top left bottom right)
61 content
62 (reify
63 Layer
64 (render! [l]
65 (draw! content
66 left top
67 (- *width* left right)
68 (- *height* top bottom)))
69 (layer-size [l]
70 (let [s (layer-size content)]
71 (Size. (+ (:width s) left right)
72 (+ (:height s) top bottom))))))))
74 (defn border
75 "Decorate layer with a border."
76 ([content]
77 (border content 1))
78 ([content width]
79 (border content width 0))
80 ([content width gap]
81 (let [layer (padding content (+ width gap))]
82 (decorate-layer layer [_]
83 (with-color :border-color
84 (doseq [i (range 0 width)]
85 (.drawRect *graphics* i i
86 (- *width* 1 i i)
87 (- *height* 1 i i))))
88 (render! layer)))))
90 (defn panel
91 "Opaque layer using theme's alt-back-color."
92 ([content]
93 (panel content 0))
94 ([content gap]
95 (let [layer (padding content gap)]
96 (decorate-layer layer [_]
97 (with-color :alt-back-color
98 (.fillRect *graphics* 0 0 *width* *height*))
99 (render! layer)))))
101 (defn- re-split [^java.util.regex.Pattern re s]
102 (seq (.split re s)))
104 (def text-layout-cache (atom {}))
106 (defn- get-text-layout
107 [^String line ^Font font ^FontRenderContext font-context]
108 (let [key [line font font-context]]
109 (or (if-let [^SoftReference softref (@text-layout-cache key)]
110 (.get softref)
111 (do (swap! text-layout-cache dissoc key)
112 false))
113 (let [layout (TextLayout. line font font-context)]
114 ;;(println "text-layout-cache miss" line)
115 (swap! text-layout-cache assoc key (SoftReference. layout))
116 layout))))
118 (defn- layout-text
119 [lines ^Font font ^FontRenderContext font-context]
120 (map #(get-text-layout % font font-context) lines))
121 ;;(map #(TextLayout. ^String % font font-context) lines))
123 (defn- text-width [layouts]
124 (reduce (fn [w ^TextLayout tl] (max w (.getAdvance tl))) 0 layouts))
126 (defn- text-height [layouts]
127 (reduce (fn [w ^TextLayout tl]
128 (+ w (.getAscent tl)
129 (.getDescent tl)
130 (.getLeading tl)))
131 0 layouts))
133 (defn text-layer
134 "Creates a layer to display multiline text."
135 ([text]
136 (text-layer text :left :top))
137 ([text h-align v-align]
138 (let [lines (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" text)]
139 (reify Layer
140 (render! [layer]
141 (let [w *width*
142 h *height*
143 font (.getFont *graphics*)
144 layouts (layout-text lines font *font-context*)
145 y (align-y (text-height layouts) h v-align)]
146 (loop [layouts layouts, y y]
147 (when-first [^TextLayout layout layouts]
148 (let [ascent (.getAscent layout)
149 lh (+ ascent (.getDescent layout) (.getLeading layout))
150 x (align-x (.getAdvance layout) w h-align)]
151 (.draw layout *graphics* x (+ y ascent))
152 (recur (next layouts) (+ y lh)))))))
153 (layer-size [layer]
154 (let [layouts (layout-text lines (:font *theme*) *font-context*)
155 width (text-width layouts)
156 height (text-height layouts)]
157 (Size. width height)))))))
159 (defn- ^ImageObserver image-observer [layer]
160 (reify
161 ImageObserver
162 (imageUpdate [this img infoflags x y width height]
163 (update layer)
164 (zero? (bit-and infoflags
165 (bit-or ImageObserver/ALLBITS
166 ImageObserver/ABORT))))))
168 (defn image-layer
169 [image-or-uri]
170 (let [^Image image (if (isa? image-or-uri Image)
171 image-or-uri
172 (.getImage (Toolkit/getDefaultToolkit)
173 ^java.net.URL image-or-uri))]
174 (.prepareImage (Toolkit/getDefaultToolkit) image -1 -1 nil)
175 (reify
176 Layer
177 (render! [layer]
178 (repaint-on-update layer)
179 (.drawImage *graphics* image 0 0 (image-observer layer)))
180 (layer-size [layer]
181 (let [observer (image-observer layer)
182 width (.getWidth image observer)
183 height (.getHeight image observer)
184 width (if (pos? width) width 1)
185 height (if (pos? height) height 1)]
186 (Size. width height))))))
188 (defn miniature
189 "Creates layer that asynchronously renders view of the content
190 scaled to the specified size."
191 [content width height]
192 (async-layer
193 (reify
194 Layer
195 (render! [this]
196 (let [size (layer-size content)
197 sx (/ width (:width size))
198 sy (/ height (:height size))]
199 (.scale *graphics* sx sy)
200 (draw! content 0 0 (:width size) (:height size))))
201 (layer-size [this]
202 (Size. width height)))
203 width height))
205 (defrecord Viewport [content h-align v-align
206 ;; state (refs)
207 x y fix-x fix-y last-width last-height]
208 Layer
209 (render! [layer]
210 (repaint-on-update layer)
211 (with-handlers layer
212 (let [anchor (anchor content h-align v-align)]
213 (dosync
214 (alter x + (align-x *width* @last-width h-align))
215 (alter y + (align-y *height* @last-height v-align))
216 (ref-set last-width *width*)
217 (ref-set last-height *height*))
218 ;; TODO: notify observers when size changes.
219 (draw! content (- 0 @x (:x anchor)) (- 0 @y (:y anchor))))
220 (:mouse-pressed e
221 (dosync
222 (ref-set fix-x (:x-on-screen e))
223 (ref-set fix-y (:y-on-screen e)))
224 (when *target*
225 (->> Cursor/MOVE_CURSOR Cursor. (.setCursor *target*))))
226 (:mouse-released e
227 (when *target*
228 (->> Cursor/DEFAULT_CURSOR Cursor. (.setCursor *target*))))
229 (:mouse-dragged e
230 (dosync
231 (alter x + (- @fix-x (:x-on-screen e)))
232 (alter y + (- @fix-y (:y-on-screen e)))
233 (ref-set fix-x (:x-on-screen e))
234 (ref-set fix-y (:y-on-screen e)))
235 (update layer))))
236 (layer-size [layer]
237 (layer-size content)))
239 (defn viewport
240 "Creates scrollable viewport layer."
241 ([content] (viewport content :left :top))
242 ([content h-align v-align]
243 (Viewport. content h-align v-align
244 (ref 0) (ref 0) ; x y
245 (ref 0) (ref 0) ; fix-x fix-y
246 (ref 0) (ref 0)))) ; last-width last-height
248 (defn- viewport-visible-bounds
249 [viewport]
250 (dosync
251 [@(:x viewport) @(:y viewport)
252 @(:last-width viewport) @(:last-height viewport)]))
254 (defn viewport-miniature
255 "Creates miniature view of the viewport's contents."
256 [viewport width height]
257 (miniature
258 (decorate-layer (:content viewport) [_]
259 (repaint-on-update viewport)
260 (let [[x y w h] (viewport-visible-bounds viewport)]
261 (with-color :alt-back-color
262 (.fillRect *graphics* 0 0 *width* *height*))
263 (with-color :back-color
264 (.fillRect *graphics* x y w h))
265 (draw! (:content viewport))
266 (with-color :border-color
267 (.drawRect *graphics* x y w h))))
268 width height))
270 (defn fps-layer
271 "Creates layer that draws content and displays
272 the frames per seconds rate."
273 [content]
274 (let [update-interval 0.1
275 frames (ref 0)
276 prev-time (ref 0)
277 display (ref nil)]
278 (decorate-layer content [_]
279 (draw! content)
280 (draw!
281 (dosync
282 (alter frames + 1)
283 (let [time (System/nanoTime)
284 elapsed (/ (- time @prev-time) 1E9)
285 fps (/ @frames elapsed)]
286 (when (or (> elapsed update-interval) (not @display))
287 (ref-set display
288 (border (text-layer (format "%.1f" fps) :right :bottom) 0 5))
289 (ref-set frames 0)
290 (ref-set prev-time time)))
291 @display)))))
293 ;;
294 ;; Layer context decorators.
295 ;;
297 (defmacro handler [layer & handlers]
298 "Decorate layer to handle events."
299 `(let [layer# ~layer]
300 (decorate-layer layer# [t#]
301 (with-handlers t#
302 (render! layer#)
303 ~@handlers))))
305 (defn theme [layer & map-or-keyvals]
306 (let [theme (if (== (count map-or-keyvals) 1)
307 map-or-keyvals
308 (apply array-map map-or-keyvals))]
309 (reify
310 Layer
311 (render! [t]
312 (with-theme theme
313 (render! layer)))
314 (layer-size [t]
315 (with-theme theme
316 (layer-size layer)))
317 Anchored
318 (anchor [t xa ya]
319 (with-theme theme
320 (anchor layer xa ya))))))