Annotation of /sml/trunk/src/eXene/widgets/simple/scrollbar.sml

Parent Directory | Revision Log

---

Revision 651 - (view) (download)

1 :	monnier	2	(* scrollbar.sml
2 :			*
3 :			* COPYRIGHT (c) 1994 by AT&T Bell Laboratories See COPYRIGHT file for details.
4 :			*
5 :			* Scrollbar widget.
6 :			*)
7 :
8 :			structure Scrollbar : SCROLLBAR = struct
9 :
10 :			structure CML = CML
11 :			structure W = Widget
12 :
13 :			open CML Geometry EXeneBase Interact Widget ScrollView
14 :
15 :			val min = Int.min
16 :			val max = Int.max
17 :
18 :			datatype scroll_evt =
19 :			ScrUp of real
20 :			| ScrDown of real
21 :			| ScrStart of real
22 :			| ScrMove of real
23 :			| ScrEnd of real
24 :
25 :			datatype scrollbar =
26 :			Scrollbar of {
27 :			widget : Widget.widget,
28 :			evt : scroll_evt CML.event,
29 :			setvals : {top : real option, sz : real option } -> unit
30 :			}
31 :
32 :			datatype mseMsg =
33 :			Grab of point
34 :			| Move of point
35 :			| Ungrab of point
36 :			| UpGrab of point
37 :			| UpUngrab of point
38 :			| DownGrab of point
39 :			| DownUngrab of point
40 :
41 :			datatype rqst =
42 :			SetVals of {top : real option, sz : real option }
43 :			| DoRealize of {
44 :			env : in_env,
45 :			win : window,
46 :			sz : size
47 :			}
48 :
49 :			type scroll = {
50 :			curx : int,
51 :			swid : int
52 :			}
53 :
54 :			val initSize = 1000
55 :			val minSwid = 8
56 :
57 :			fun newVals (me as {curx, swid}, size, arg) =
58 :			case arg of
59 :			{top=NONE, sz=NONE} => me
60 :			| {top=SOME top, sz=NONE} =>
61 :			{curx=min(size-swid,max(0,floor(top * (real size)))),swid=swid}
62 :			| {top=NONE, sz=SOME sz} =>
63 :			{curx=curx,swid=min(size-curx,max(minSwid,ceil(sz * (real size))))}
64 :			| {top=SOME top, sz=SOME sz} =>
65 :			let
66 :			val sz' = min(size,max(minSwid,ceil(sz * (real size))))
67 :			val top' = min(size-sz',max(0,floor(top * (real size))))
68 :			in
69 :			{curx=top',swid=sz'}
70 :			end
71 :
72 :			fun mkScroll (root, dim, color, bg, {bounds_of, realize} : scroll_view) = let
73 :			val _ = if dim < 4
74 :			then LibBase.failure{module="Scrollbar",func="mkScroll",msg="dim < 4"}
75 :			else ()
76 :			val scr = screenOf root
77 :			val msechan = channel () (* mouse to scrollbar *)
78 :			val valchan = channel () (* scrollbar to user *)
79 :			val reqchan = channel () (* user to scrollbar *)
80 :			val mevt = recvEvt msechan
81 :			val reqevt = recvEvt reqchan
82 :
83 :			(* mouse reader *)
84 :			fun mseP m = let
85 :
86 :			fun downLoop (movef,upf) = let
87 :			fun loop () =
88 :			case msgBodyOf (sync m) of
89 :			MOUSE_LastUp {pt,...} => upf pt
90 :			| MOUSE_Motion {pt,...} => (movef pt;loop ())
91 :			| _ => loop ()
92 :			in
93 :			loop ()
94 :			end
95 :
96 :			fun loop () =
97 :			case msgBodyOf (sync m) of
98 :			MOUSE_FirstDown {but=btn as MButton 1,pt,...} => (
99 :			send (msechan, UpGrab pt);
100 :			downLoop (fn _ => (), fn p => send(msechan, UpUngrab p));
101 :			loop ()
102 :			)
103 :			| MOUSE_FirstDown {but=btn as (MButton 2),pt,...} => (
104 :			send (msechan, Grab pt);
105 :			downLoop (
106 :			fn p => send(msechan, Move p),
107 :			fn p => send(msechan, Ungrab p)
108 :			);
109 :			loop ()
110 :			)
111 :			| MOUSE_FirstDown {but=btn as MButton 3,pt,...} => (
112 :			send (msechan, DownGrab pt);
113 :			downLoop (fn _ => (),fn p => send(msechan, DownUngrab p));
114 :			loop ()
115 :			)
116 :			| _ => loop ()
117 :			in
118 :			loop ()
119 :			end
120 :
121 :			val config = realize (root,color)
122 :
123 :			fun realizeScroll {env=inenv, win, sz=winsz} me = let
124 :			val InEnv{m,ci,...} = Interact.ignoreKey inenv
125 :			val config = config (Drawing.drawableOfWin win)
126 :
127 :			fun reconfig ({curx,swid},size,sz,redraw) = let
128 :			val data as {size=size',draw,...} = config sz
129 :			val curx' = (curx*size') div size
130 :			val swid' = (swid*size') div size
131 :			in
132 :			if redraw then draw (curx',swid') else ();
133 :			cmdP ({curx=curx', swid=swid'}, data)
134 :			end
135 :
136 :			and cmdP (me, {size,coord,draw,move}) = let
137 :
138 :			fun sendVal (v, f) = send (valchan, f ((real v)/(real (size))))
139 :
140 :			fun moveSlide (me as {curx,swid}, x) = let
141 :			val curx' = min(size-swid,max(0,x))
142 :			in
143 :			if curx' <> curx then let
144 :			in
145 :			move (curx, swid, curx', swid);
146 :			{curx=curx',swid=swid}
147 :			end
148 :			else me
149 :			end
150 :
151 :			fun handleCIEvt (evt, me : scroll) =
152 :			case msgBodyOf evt of
153 :			CI_OwnDeath => me
154 :			| CI_Redraw _ => (draw (#curx me, #swid me); me)
155 :			| CI_Resize (RECT{wid,ht,...}) =>
156 :			reconfig (me, size, SIZE{wid=wid,ht=ht},true)
157 :			| _ => me
158 :
159 :			fun handleReqEvt (SetVals arg, me as {curx,swid}) =
160 :			let
161 :			val me' as {curx=curx',swid=swid'} = newVals (me, size, arg)
162 :			in
163 :			if curx <> curx' orelse swid <> swid' then
164 :			move (curx, swid, curx', swid')
165 :			else ();
166 :			me'
167 :			end
168 :			| handleReqEvt (DoRealize _,me) = me
169 :
170 :
171 :			fun handleMEvt (Grab p, me as {curx,swid}) = let
172 :			val x = coord p
173 :			val maxx = size - swid
174 :			val (xoff, me') =
175 :			if curx <= x andalso x < curx + swid then ((x - curx), me)
176 :			else if 0 <= x andalso x < maxx+swid then
177 :			let
178 :			val curx' = min(maxx, max(0, x - (swid div 2)))
179 :			in
180 :			(x - curx', moveSlide (me, curx'))
181 :			end
182 :			else if x < 0 then (swid div 2, moveSlide (me, 0))
183 :			else (swid div 2, moveSlide (me, maxx))
184 :
185 :			fun hMEvt (Ungrab x, me) =
186 :			let
187 :			val me' = moveSlide (me, (coord x) - xoff)
188 :			in
189 :			sendVal (#curx me', ScrEnd);
190 :			(false, me')
191 :			end
192 :			| hMEvt (Move x, me) =
193 :			let
194 :			val me' = moveSlide (me, (coord x) - xoff)
195 :			in
196 :			if (#curx me <> #curx me') then sendVal (#curx me', ScrMove)
197 :			else ();
198 :			(true, me')
199 :			end
200 :			| hMEvt (_, me) = (true, me) (* protocol error *)
201 :
202 :			fun loop me = select [
203 :			wrap (reqevt,fn evt => loop (handleReqEvt (evt, me))),
204 :			wrap (ci, fn evt => loop (handleCIEvt (evt, me))),
205 :			wrap (mevt, fn evt =>
206 :			case hMEvt (evt, me) of
207 :			(true, m) => loop m
208 :			| (false, m) => m)
209 :			]
210 :
211 :			in
212 :			sendVal (#curx me', ScrStart);
213 :			loop me' end
214 :			| handleMEvt (UpGrab _,me) = let
215 :
216 :			fun hMEvt (UpUngrab x, me) = (sendVal (coord x, ScrUp); (false, me))
217 :			| hMEvt (_, me) = (true, me) (* protocol error *)
218 :
219 :			fun loop me =
220 :			select [
221 :			wrap (reqevt,fn evt => loop (handleReqEvt (evt, me))),
222 :			wrap (ci, fn evt => loop (handleCIEvt (evt, me))),
223 :			wrap (mevt, fn evt =>
224 :			case hMEvt (evt, me) of
225 :			(true, m) => loop m
226 :			| (false, m) => m)
227 :			]
228 :			in
229 :			loop me
230 :			end
231 :			| handleMEvt (DownGrab p,me) = let
232 :
233 :			fun hMEvt (DownUngrab x, me) = (sendVal (coord x, ScrDown); (false, me))
234 :			| hMEvt (_, me) = (true, me) (* protocol error *)
235 :
236 :			fun loop me =
237 :			select [
238 :			wrap (reqevt,fn evt => loop (handleReqEvt (evt, me))),
239 :			wrap (ci, fn evt => loop (handleCIEvt (evt, me))),
240 :			wrap (mevt, fn evt =>
241 :			case hMEvt (evt, me) of
242 :			(true, m) => loop m
243 :			| (false, m) => m)
244 :			]
245 :			in
246 :			loop me
247 :			end
248 :			| handleMEvt (_,me) = me (* protocol error *)
249 :
250 :			fun cmdLoop me =
251 :			cmdLoop (select [
252 :			wrap (reqevt, fn evt => handleReqEvt (evt, me)),
253 :			wrap (mevt, fn evt => handleMEvt (evt, me)),
254 :			wrap (ci, fn evt => handleCIEvt (evt, me))
255 :			])
256 :			in
257 :			cmdLoop me
258 :			end
259 :			in
260 :			spawn (fn () => mseP m);
261 :			spawn (fn() => (reconfig (me, initSize, winsz,false);()));
262 :			()
263 :			end
264 :
265 :			fun initLoop vals =
266 :			case recv reqchan of
267 :			SetVals arg => initLoop (newVals (vals, initSize, arg))
268 :			| DoRealize arg => realizeScroll arg vals
269 :			in
270 :			spawn (fn () => initLoop {curx=0,swid=initSize});
271 :			Scrollbar {
272 :			widget =
273 :			mkWidget{
274 :			root=root,
275 :			args= fn () => {background = bg},
276 :			boundsOf=bounds_of dim,
277 :			realize=fn arg => send(reqchan, DoRealize arg)
278 :			},
279 :			evt = recvEvt valchan,
280 :			setvals = (fn arg => send (reqchan, SetVals arg))
281 :			}
282 :			end
283 :
284 :			val attrs = [
285 :			(Attrs.attr_width, Attrs.AT_Int, Attrs.AV_Int 12),
286 :			(Attrs.attr_background, Attrs.AT_Color, Attrs.AV_Str "gray"),
287 :			(Attrs.attr_color, Attrs.AT_Color, Attrs.AV_NoValue)
288 :			]
289 :
290 :			fun scrollbar scrollView (root,view,args) = let
291 :			val attrs = W.findAttr (W.attrs(view,attrs,args))
292 :			val sz = Attrs.getInt(attrs Attrs.attr_width)
293 :			val bg = Attrs.getColor(attrs Attrs.attr_background)
294 :			val color = case Attrs.getColorOpt(attrs Attrs.attr_color) of
295 :			NONE => bg
296 :			| SOME c => c
297 :			in mkScroll(root,sz,color,SOME bg,scrollView) end
298 :
299 :			val hScrollbar = scrollbar horzScrollbar
300 :			val vScrollbar = scrollbar vertScrollbar
301 :
302 :			fun mkHScrollbar root {sz, color} = let
303 :			val color = case color of
304 :			SOME c => c
305 :			| NONE => colorOfScr (screenOf root) (CMS_Name "gray")
306 :			in mkScroll (root, sz, color, NONE, horzScrollbar) end
307 :
308 :			fun mkVScrollbar root {sz, color} = let
309 :			val color = case color of
310 :			SOME c => c
311 :			| NONE => colorOfScr (screenOf root) (CMS_Name "gray")
312 :			in mkScroll (root, sz, color, NONE, vertScrollbar) end
313 :
314 :			fun widgetOf (Scrollbar {widget,...}) = widget
315 :			fun evtOf (Scrollbar {evt,...}) = evt
316 :			fun setVals (Scrollbar{setvals,...}) arg = setvals arg
317 :
318 :			end (* ScrollBar *)
319 :
320 :

---

root@smlnj-gforge.cs.uchicago.edu	ViewVC Help
Powered by ViewVC 1.0.0