view src/indyvon/core.clj @ 23:bbe95838fe77

Scrollable viewport.
author Mikhail Kryshen <mikhail@kryshen.net>
date Sun, 20 Jun 2010 04:23:28 +0400
parents dc81033d4122
children c17e3588ede9
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 ([context layer graphics]
56 (draw! context layer graphics
57 0 0 (:width context) (:height context)))
58 ([context layer graphics x y]
59 (draw! context layer graphics x y true))
60 ([context layer graphics x y clip]
61 (let [s (size layer context)]
62 (draw! context layer graphics
63 x y (s 0) (s 1) clip)))
64 ([context layer graphics x y w h]
65 (draw! context layer graphics
66 x y w h true))
67 ([context layer 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! c content 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 (defn- re-split [re s]
110 (seq (.split re s)))
112 (defn- layout-text [lines font font-context]
113 (map #(TextLayout. % font font-context) lines))
115 (defn- text-width [layouts]
116 (reduce #(max %1 (.getAdvance %2)) 0 layouts))
118 (defn- text-height [layouts]
119 (reduce #(+ %1 (.getAscent %2) (.getDescent %2) (.getLeading %2))
120 0 layouts))
122 (defn text-layer
123 "Creates a layer to display multiline text."
124 ([text]
125 (text-layer text :left :top))
126 ([text h-align v-align]
127 (let [lines (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" text)]
128 (reify Layer
129 (render! [l c g]
130 (let [w (:width c)
131 h (:height c)
132 font (.getFont g)
133 font-context (:font-context c)
134 layouts (layout-text lines font font-context)
135 y (case v-align
136 :top 0
137 :center (/ (- h (text-height layouts)) 2)
138 :bottom (- h (text-height layouts)))]
139 (loop [layouts layouts, y y]
140 (when-first [layout layouts]
141 (let [ascent (.getAscent layout)
142 lh (+ ascent (.getDescent layout) (.getLeading layout))
143 x (case h-align
144 :left 0
145 :center (/ (- w (.getAdvance layout)) 2)
146 :right (- w (.getAdvance layout)))]
147 (.draw layout g x (+ y ascent))
148 (recur (next layouts) (+ y lh)))))))
149 (size [l c]
150 (let [layouts (layout-text lines
151 (-> c :theme :font)
152 (:font-context c))
153 width (text-width layouts)
154 height (text-height layouts)]
155 [width height]))))))
157 (defprotocol Anchored
158 "Provide anchor point for Layers. Used by viewport."
159 (anchor [this context] "Anchor point: [x y]"))
161 ;; Default implementation of Anchored for any Layer.
162 (extend-protocol Anchored
163 indyvon.core.Layer
164 (anchor [this context] [0 0]))
166 (defn viewport
167 "Creates scrollable viewport layer."
168 ([content] (viewport content :left :top))
169 ([content h-align v-align]
170 (let [x (ref 0)
171 y (ref 0)
172 fix-x (ref 0)
173 fix-y (ref 0)
174 last-width (ref 0)
175 last-height (ref 0)]
176 (reify
177 Layer
178 (render! [layer c g]
179 (let [anchor (anchor content c)
180 width (:width c)
181 height (:height c)]
182 (dosync
183 (case h-align
184 :left nil
185 :center (alter x + (/ (- @last-width width) 2))
186 :right (alter x + (- @last-width width)))
187 (case v-align
188 :top nil
189 :center (alter y + (/ (- @last-height height) 2))
190 :bottom (alter y + (- @last-height height)))
191 (ref-set last-width width)
192 (ref-set last-height height))
193 (draw! c content g
194 (- 0 @x (anchor 0))
195 (- 0 @y (anchor 1)))))
196 (size [layer c] (size content c))
197 MouseHandler
198 (handle-mouse [layer c e]
199 (when (= (.getID e) MouseEvent/MOUSE_PRESSED)
200 (dosync
201 (ref-set fix-x (.getXOnScreen e))
202 (ref-set fix-y (.getYOnScreen e)))
203 (->> Cursor/MOVE_CURSOR Cursor. (.setCursor (:target c))))
204 (when (= (.getID e) MouseEvent/MOUSE_RELEASED)
205 (->> Cursor/DEFAULT_CURSOR Cursor. (.setCursor (:target c))))
206 (when (= (.getID e) MouseEvent/MOUSE_DRAGGED)
207 (dosync
208 (alter x + (- @fix-x (.getXOnScreen e)))
209 (alter y + (- @fix-y (.getYOnScreen e)))
210 (ref-set fix-x (.getXOnScreen e))
211 (ref-set fix-y (.getYOnScreen e)))
212 (update c)))))))