Mercurial > hg > indyvon
view src/indyvon/core.clj @ 25:07ee065cbb3e
Avoid some code repetition by using macros.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Mon, 21 Jun 2010 01:18:50 +0400 |
| parents | c17e3588ede9 |
| children | 1237f7555029 |
line source
1 ;;
2 ;; Copyright (C) 2010 Mikhail Kryshen <mikhail@kryshen.net>
3 ;;
4 ;; This file is part of Indyvon.
5 ;;
7 (ns indyvon.core
8 (:import (java.awt Color Font Cursor)
9 (java.awt.font FontRenderContext TextLayout)
10 (java.awt.event MouseEvent)))
12 (defprotocol Layer
13 "Basic UI element."
14 (render! [this context graphics])
15 (size [this context]))
17 (defprotocol MouseHandler
18 "Layers that also satisfy this protocol will recieve mouse events."
19 (handle-mouse [this context event]))
21 (defprotocol EventDispatcher
22 (listen! [this component])
23 (register [this context])
24 (commit [this])
25 (hovered? [this layer])
26 (picked? [this layer]))
28 (defrecord Theme [fore-color back-color border-color font])
30 (defn default-theme []
31 (Theme. Color/BLACK Color/WHITE Color/BLUE (Font. "Sans" Font/PLAIN 12)))
33 (defrecord LayerContext [layer parent x y width height update-fn
34 dispatcher font-context theme target])
36 (defn default-context []
37 (LayerContext. nil nil 0 0 0 0 nil nil nil (default-theme) nil))
39 (defn update [context]
40 ((:update-fn context)))
42 (defn- make-graphics [graphics x y w h clip]
43 (if clip
44 (.create graphics x y w h)
45 (doto (.create graphics)
46 (.translate x y))))
48 (defn- apply-theme [graphics theme]
49 (doto graphics
50 (.setColor (:fore-color theme))
51 (.setFont (:font theme))))
53 (defn draw!
54 "Render layer in a new graphics context."
55 ([layer context graphics]
56 (draw! layer context graphics
57 0 0 (:width context) (:height context)))
58 ([layer context graphics x y]
59 (draw! layer context graphics x y true))
60 ([layer context graphics x y clip]
61 (let [s (size layer context)]
62 (draw! layer context graphics
63 x y (s 0) (s 1) clip)))
64 ([layer context graphics x y w h]
65 (draw! layer context graphics
66 x y w h true))
67 ([layer context graphics x y w h clip]
68 (let [context (assoc context
69 :layer layer
70 :parent context
71 :x (+ (:x context) x)
72 :y (+ (:y context) y)
73 :width w
74 :height h)
75 graphics (make-graphics graphics x y w h clip)
76 graphics (apply-theme graphics (:theme context))]
77 (try
78 (register (:dispatcher context) context)
79 (render! layer context graphics)
80 (finally
81 (.dispose graphics))))))
83 ;;
84 ;; Layer implementations.
85 ;;
87 (defn border-layer
88 "Decorate layer with a border."
89 ([content]
90 (border-layer content 1))
91 ([content width]
92 (border-layer content width 0))
93 ([content width gap]
94 (let [offset (+ width gap)]
95 (reify Layer
96 (render! [l c g]
97 (let [w (:width c)
98 h (:height c)]
99 (.setColor g (-> c :theme :border-color))
100 (doseq [i (range 0 width)]
101 (.drawRect g i i (- w 1 i i) (- h 1 i i)))
102 (draw! content c g offset offset (- w offset offset)
103 (- h offset offset))))
104 (size [l c]
105 (let [s (size content c)]
106 [(+ (s 0) offset offset)
107 (+ (s 1) offset offset)]))))))
109 ;; Define as macro to avoid unnecessary calculation of inner and outer
110 ;; sizes in the first case.
111 (defmacro align-xy [inner outer align first center last]
112 `(case ~align
113 ~first 0
114 ~center (/ (- ~outer ~inner) 2)
115 ~last (- ~outer ~inner)))
117 (defmacro align-x [inner outer align]
118 `(align-xy ~inner ~outer ~align :left :center :right))
120 (defmacro align-y [inner outer align]
121 `(align-xy ~inner ~outer ~align :top :center :bottom))
123 (defn- re-split [re s]
124 (seq (.split re s)))
126 (defn- layout-text [lines font font-context]
127 (map #(TextLayout. % font font-context) lines))
129 (defn- text-width [layouts]
130 (reduce #(max %1 (.getAdvance %2)) 0 layouts))
132 (defn- text-height [layouts]
133 (reduce #(+ %1 (.getAscent %2) (.getDescent %2) (.getLeading %2))
134 0 layouts))
136 (defn text-layer
137 "Creates a layer to display multiline text."
138 ([text]
139 (text-layer text :left :top))
140 ([text h-align v-align]
141 (let [lines (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" text)]
142 (reify Layer
143 (render! [l c g]
144 (let [w (:width c)
145 h (:height c)
146 font (.getFont g)
147 font-context (:font-context c)
148 layouts (layout-text lines font font-context)
149 y (align-y (text-height layouts) h v-align)]
150 (loop [layouts layouts, y y]
151 (when-first [layout layouts]
152 (let [ascent (.getAscent layout)
153 lh (+ ascent (.getDescent layout) (.getLeading layout))
154 x (align-x (.getAdvance layout) w h-align)]
155 (.draw layout g x (+ y ascent))
156 (recur (next layouts) (+ y lh)))))))
157 (size [l c]
158 (let [layouts (layout-text lines
159 (-> c :theme :font)
160 (:font-context c))
161 width (text-width layouts)
162 height (text-height layouts)]
163 [width height]))))))
165 (defprotocol Anchored
166 "Provide anchor point for Layers. Used by viewport."
167 (anchor [this context] "Anchor point: [x y]"))
169 ;; Default implementation of Anchored for any Layer.
170 (extend-protocol Anchored
171 indyvon.core.Layer
172 (anchor [this context] [0 0]))
174 (defn viewport
175 "Creates scrollable viewport layer."
176 ([content] (viewport content :left :top))
177 ([content h-align v-align]
178 (let [x (ref 0)
179 y (ref 0)
180 fix-x (ref 0)
181 fix-y (ref 0)
182 last-width (ref 0)
183 last-height (ref 0)]
184 (reify
185 Layer
186 (render! [layer c g]
187 (let [anchor (anchor content c)
188 width (:width c)
189 height (:height c)]
190 (dosync
191 (alter x + (align-x width @last-width h-align))
192 (alter y + (align-y height @last-height v-align))
193 (ref-set last-width width)
194 (ref-set last-height height))
195 (draw! content c g
196 (- 0 @x (anchor 0))
197 (- 0 @y (anchor 1)))))
198 (size [layer c] (size content c))
199 MouseHandler
200 (handle-mouse [layer c e]
201 (when (= (.getID e) MouseEvent/MOUSE_PRESSED)
202 (dosync
203 (ref-set fix-x (.getXOnScreen e))
204 (ref-set fix-y (.getYOnScreen e)))
205 (->> Cursor/MOVE_CURSOR Cursor. (.setCursor (:target c))))
206 (when (= (.getID e) MouseEvent/MOUSE_RELEASED)
207 (->> Cursor/DEFAULT_CURSOR Cursor. (.setCursor (:target c))))
208 (when (= (.getID e) MouseEvent/MOUSE_DRAGGED)
209 (dosync
210 (alter x + (- @fix-x (.getXOnScreen e)))
211 (alter y + (- @fix-y (.getYOnScreen e)))
212 (ref-set fix-x (.getXOnScreen e))
213 (ref-set fix-y (.getYOnScreen e)))
214 (update c)))))))