Mercurial > hg > indyvon

view src/kryshen/indyvon/layers.clj @ 47:180d7690d09a

find changesets by author, revision, files, or words in the commit message
Fix image layer performance issues. Handler macro captures layer in let.
author Mikhail Kryshen <mikhail@kryshen.net>
date Wed, 28 Jul 2010 04:46:34 +0400
parents 064b21604f74
children
line source
1 ;;
2 ;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net>
3 ;;
4 ;; This file is part of Indyvon.
5 ;;
6
7 (ns kryshen.indyvon.layers
8 (:use kryshen.indyvon.core)
9 (:import (kryshen.indyvon.core Size Location)
10 (java.lang.ref SoftReference)
11 (java.awt Font Cursor Image Toolkit)
12 (java.awt.image ImageObserver)
13 (java.awt.font FontRenderContext TextLayout)))
14
15 ;; Define as macro to avoid unnecessary calculation of inner and outer
16 ;; sizes in the first case.
17 (defmacro align-xy [inner outer align first center last]
18 `(case ~align
19 ~first 0
20 ~center (/ (- ~outer ~inner) 2)
21 ~last (- ~outer ~inner)))
22
23 (defmacro align-x [inner outer align]
24 `(align-xy ~inner ~outer ~align :left :center :right))
25
26 (defmacro align-y [inner outer align]
27 `(align-xy ~inner ~outer ~align :top :center :bottom))
28
29 (defmacro decorate-layer [layer & render-tail]
30 `(reify
31 Layer
32 (render! ~@render-tail)
33 (layer-size [t#] (layer-size ~layer))
34 Anchored
35 (anchor [t# xa# ya#] (anchor ~layer xa# ya#))))
36
37 (defn padding
38 ([content pad]
39 (padding content pad pad pad pad))
40 ([content top left bottom right]
41 (if (== 0 top left bottom right)
42 content
43 (reify
44 Layer
45 (render! [l]
46 (draw! content
47 left top
48 (- (:width *bounds*) left right)
49 (- (:height *bounds*) top bottom)))
50 (layer-size [l]
51 (let [s (layer-size content)]
52 (Size. (+ (:width s) left right)
53 (+ (:height s) top bottom))))))))
54
55 (defn border
56 "Decorate layer with a border."
57 ([content]
58 (border content 1))
59 ([content width]
60 (border content width 0))
61 ([content width gap]
62 (let [layer (padding content (+ width gap))]
63 (decorate-layer layer [_]
64 (let [w (:width *bounds*)
65 h (:height *bounds*)]
66 (with-color (:border-color *theme*)
67 (doseq [i (range 0 width)]
68 (.drawRect *graphics* i i (- w 1 i i) (- h 1 i i))))
69 (render! layer))))))
70
71 (defn panel
72 "Opaque layer using theme's alt-back-color."
73 ([content]
74 (panel content 0))
75 ([content gap]
76 (let [layer (padding content gap)]
77 (decorate-layer layer [_]
78 (with-color (:alt-back-color *theme*)
79 (.fillRect *graphics* 0 0
80 (:width *bounds*) (:height *bounds*)))
81 (render! layer)))))
82
83 (defn- re-split [^java.util.regex.Pattern re s]
84 (seq (.split re s)))
85
86 (def text-layout-cache (atom {}))
87
88 (defn- get-text-layout
89 [^String line ^Font font ^FontRenderContext font-context]
90 (let [key [line font font-context]]
91 (or (if-let [^SoftReference softref (@text-layout-cache key)]
92 (.get softref)
93 (do (swap! text-layout-cache dissoc key)
94 false))
95 (let [layout (TextLayout. line font font-context)]
96 (println "text-layout-cache miss" line)
97 (swap! text-layout-cache assoc key (SoftReference. layout))
98 layout))))
99
100 (defn- layout-text
101 [lines ^Font font ^FontRenderContext font-context]
102 (map #(get-text-layout % font font-context) lines))
103 ;;(map #(TextLayout. ^String % font font-context) lines))
104
105 (defn- text-width [layouts]
106 (reduce (fn [w ^TextLayout tl] (max w (.getAdvance tl))) 0 layouts))
107
108 (defn- text-height [layouts]
109 (reduce (fn [w ^TextLayout tl] (+ w (.getAscent tl)
110 (.getDescent tl)
111 (.getLeading tl)))
112 0 layouts))
113
114 (defn text-layer
115 "Creates a layer to display multiline text."
116 ([text]
117 (text-layer text :left :top))
118 ([text h-align v-align]
119 (let [lines (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" text)]
120 (reify Layer
121 (render! [layer]
122 (let [w (:width *bounds*)
123 h (:height *bounds*)
124 font (.getFont *graphics*)
125 layouts (layout-text lines font *font-context*)
126 y (align-y (text-height layouts) h v-align)]
127 (loop [layouts layouts, y y]
128 (when-first [^TextLayout layout layouts]
129 (let [ascent (.getAscent layout)
130 lh (+ ascent (.getDescent layout) (.getLeading layout))
131 x (align-x (.getAdvance layout) w h-align)]
132 (.draw layout *graphics* x (+ y ascent))
133 (recur (next layouts) (+ y lh)))))))
134 (layer-size [layer]
135 (let [layouts (layout-text lines (:font *theme*) *font-context*)
136 width (text-width layouts)
137 height (text-height layouts)]
138 (Size. width height)))))))
139
140 (defn- image-observer [update-fn]
141 (reify
142 ImageObserver
143 (imageUpdate [this img infoflags x y width height]
144 (update-fn)
145 (zero? (bit-and infoflags
146 (bit-or ImageObserver/ALLBITS
147 ImageObserver/ABORT))))))
148
149 (defn image-layer
150 [image-or-uri]
151 (let [^Image image (if (isa? image-or-uri Image)
152 image-or-uri
153 (.getImage (Toolkit/getDefaultToolkit)
154 ^java.net.URL image-or-uri))]
155 (.prepareImage (Toolkit/getDefaultToolkit) image -1 -1 nil)
156 (reify
157 Layer
158 (render! [layer]
159 (.drawImage *graphics* image 0 0
160 ^ImageObserver (image-observer *update*)))
161 (layer-size [layer]
162 (let [observer (image-observer *update*)
163 width (.getWidth image observer)
164 height (.getHeight image observer)
165 width (if (pos? width) width 1)
166 height (if (pos? height) height 1)]
167 (Size. width height))))))
168
169 (defn viewport
170 "Creates scrollable viewport layer."
171 ([content] (viewport content :left :top))
172 ([content h-align v-align]
173 (let [x (ref 0)
174 y (ref 0)
175 fix-x (ref 0)
176 fix-y (ref 0)
177 last-width (ref 0)
178 last-height (ref 0)]
179 (reify
180 Layer
181 (render! [layer]
182 (with-handlers layer
183 (let [anchor (anchor content h-align v-align)
184 width (:width *bounds*)
185 height (:height *bounds*)]
186 (dosync
187 (alter x + (align-x width @last-width h-align))
188 (alter y + (align-y height @last-height v-align))
189 (ref-set last-width width)
190 (ref-set last-height height))
191 (draw! content (- 0 @x (:x anchor)) (- 0 @y (:y anchor))))
192 (:mouse-pressed e
193 (dosync
194 (ref-set fix-x (:x-on-screen e))
195 (ref-set fix-y (:y-on-screen e)))
196 (->> Cursor/MOVE_CURSOR Cursor. (.setCursor *target*)))
197 (:mouse-released e
198 (->> Cursor/DEFAULT_CURSOR Cursor. (.setCursor *target*)))
199 (:mouse-dragged e
200 (dosync
201 (alter x + (- @fix-x (:x-on-screen e)))
202 (alter y + (- @fix-y (:y-on-screen e)))
203 (ref-set fix-x (:x-on-screen e))
204 (ref-set fix-y (:y-on-screen e)))
205 (*update*))))
206 (layer-size [layer] (layer-size content))))))
207
208 ;;
209 ;; Layer context decorators.
210 ;;
211
212 (defmacro handler [layer & handlers]
213 `(let [layer# ~layer]
214 (decorate-layer layer# [t#]
215 (with-handlers t#
216 (render! layer#)
217 ~@handlers))))
218
219 (defn theme [layer & map-or-keyvals]
220 (let [theme (if (== (count map-or-keyvals) 1)
221 map-or-keyvals
222 (apply array-map map-or-keyvals))]
223 (reify
224 Layer
225 (render! [t]
226 (with-theme theme
227 (render! layer)))
228 (layer-size [t]
229 (with-theme theme
230 (layer-size layer)))
231 Anchored
232 (anchor [t xa ya]
233 (with-theme theme
234 (anchor layer xa ya))))))