Mercurial > hg > indyvon
view src/indyvon/core.clj @ 22:dc81033d4122
Layers should satisfy MouseHandler protocol to recieve mouse events.
| author | Mikhail Kryshen <mikhail@kryshen.net> |
|---|---|
| date | Sat, 19 Jun 2010 06:50:24 +0400 |
| parents | 357bdd7d0550 |
| children | bbe95838fe77 |
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)
9 (java.awt.font FontRenderContext TextLayout)))
11 (defprotocol Layer
12 "Basic UI element."
13 (render! [this context graphics])
14 (size [this context]))
16 (defprotocol MouseHandler
17 "Layers that also satisfy this protocol will recieve mouse events."
18 (handle-mouse [this context event]))
20 (defprotocol EventDispatcher
21 (listen! [this component])
22 (register [this context])
23 (commit [this])
24 (hovered? [this layer])
25 (picked? [this layer]))
27 (defrecord Theme [fore-color back-color border-color font])
29 (defn default-theme []
30 (Theme. Color/BLACK Color/WHITE Color/BLUE (Font. "Sans" Font/PLAIN 12)))
32 (defrecord LayerContext
33 [layer parent x y width height update-fn dispatcher font-context theme])
35 (defn default-context []
36 (LayerContext. nil nil 0 0 0 0 nil nil nil (default-theme)))
38 (defn update [context]
39 ((:update-fn context)))
41 (defn- make-graphics [graphics x y w h clip]
42 (if clip
43 (.create graphics x y w h)
44 (doto (.create graphics)
45 (.translate x y))))
47 (defn- apply-theme [graphics theme]
48 (doto graphics
49 (.setColor (:fore-color theme))
50 (.setFont (:font theme))))
52 (defn draw!
53 "Render layer in a new graphics context."
54 ([context layer graphics]
55 (draw! context layer graphics
56 0 0 (:width context) (:height context)))
57 ([context layer graphics x y]
58 (draw! context layer graphics x y true))
59 ([context layer graphics x y clip]
60 (let [s (size layer context)]
61 (draw! context layer graphics
62 x y (s 0) (s 1) clip)))
63 ([context layer graphics x y w h]
64 (draw! context layer graphics
65 x y w h true))
66 ([context layer graphics x y w h clip]
67 (let [context (assoc context
68 :layer layer
69 :parent context
70 :x (+ (:x context) x)
71 :y (+ (:y context) y)
72 :width w
73 :height h)
74 graphics (make-graphics graphics x y w h clip)
75 graphics (apply-theme graphics (:theme context))]
76 (try
77 (register (:dispatcher context) context)
78 (render! layer context graphics)
79 (finally
80 (.dispose graphics))))))
82 ;;
83 ;; Layer implementations.
84 ;;
86 (defn border-layer
87 "Decorate layer with a border."
88 ([content]
89 (border-layer content 1))
90 ([content width]
91 (border-layer content width 0))
92 ([content width gap]
93 (let [offset (+ width gap)]
94 (reify Layer
95 (render! [l c g]
96 (let [w (:width c)
97 h (:height c)]
98 (.setColor g (-> c :theme :border-color))
99 (doseq [i (range 0 width)]
100 (.drawRect g i i (- w 1 i i) (- h 1 i i)))
101 (draw! c content g offset offset (- w offset offset)
102 (- h offset offset))))
103 (size [l c]
104 (let [s (size content c)]
105 [(+ (s 0) offset offset)
106 (+ (s 1) offset offset)]))))))
108 (defn- re-split [re s]
109 (seq (.split re s)))
111 (defn- layout-text [lines font font-context]
112 (map #(TextLayout. % font font-context) lines))
114 (defn- text-width [layouts]
115 (reduce #(max %1 (.getAdvance %2)) 0 layouts))
117 (defn- text-height [layouts]
118 (reduce #(+ %1 (.getAscent %2) (.getDescent %2) (.getLeading %2))
119 0 layouts))
121 (defn text-layer
122 "Creates a layer to display multiline text."
123 ([text]
124 (text-layer text :left :top))
125 ([text h-align v-align]
126 (let [lines (re-split #"\r\n|\n|\r|\u0085|\u2028|\u2029" text)]
127 (reify Layer
128 (render! [l c g]
129 (let [w (:width c)
130 h (:height c)
131 font (.getFont g)
132 font-context (:font-context c)
133 layouts (layout-text lines font font-context)
134 y (case v-align
135 :top 0
136 :center (/ (- h (text-height layouts)) 2)
137 :bottom (- h (text-height layouts)))]
138 (loop [layouts layouts, y y]
139 (when-first [layout layouts]
140 (let [ascent (.getAscent layout)
141 lh (+ ascent (.getDescent layout) (.getLeading layout))
142 x (case h-align
143 :left 0
144 :center (/ (- w (.getAdvance layout)) 2)
145 :right (- w (.getAdvance layout)))]
146 (.draw layout g x (+ y ascent))
147 (recur (next layouts) (+ y lh)))))))
148 (size [l c]
149 (let [layouts (layout-text lines
150 (-> c :theme :font)
151 (:font-context c))
152 width (text-width layouts)
153 height (text-height layouts)]
154 [width height]))))))
156 (defprotocol Anchored
157 "Provide anchor point for Layers. Used by viewport."
158 (anchor [this context] "Anchor point: [x y]"))
160 ;; Default implementation of Anchored for any Layer.
161 (extend-protocol Anchored
162 indyvon.core.Layer
163 (anchor [this context] [0 0]))
165 (defn viewport
166 "Creates scrollable viewport layer."
167 [content]
168 ;; TODO
169 )