Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/eXene/widgets/simple/scrollbar.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1188 - (view) (download)

1 : monnier 2 (* scrollbar.sml
2 :     *
3 : jhr 1188 * COPYRIGHT (c) 1994, 2002 by AT&T Bell Laboratories See COPYRIGHT file for details.
4 : monnier 2 *
5 :     * Scrollbar widget.
6 : jhr 1188 *
7 :     * CHANGE LOG
8 :     *
9 :     * 12 Mar 02 - Allen Stoughton - Changed widget so that, when it's
10 :     * trying to communicate a value to the application on the scroll_evt
11 :     * channel, it's still willing to process the application's setvals
12 :     * operations. (This was necessary to avoid deadlock.) Also modified
13 :     * widget to cope with resize events during ScrStart, ..., ScrMove, ...,
14 :     * ScrEnd, sequences. (Previously, the user would lose control of the
15 :     * mouse, and a ScrEnd event wouldn't be generated.)
16 : monnier 2 *)
17 :    
18 : jhr 1188 structure Scrollbar : SCROLLBAR =
19 :     struct
20 : monnier 2
21 : jhr 1188 structure CML = CML
22 :     structure W = Widget
23 : monnier 2
24 : jhr 1188 open CML Geometry EXeneBase Interact Widget ScrollView
25 : monnier 2
26 : jhr 1188 type scroll_state = { (* since not exported from ScrollView; the variable "data" *)
27 :     size : int, (* ranges over this type *)
28 :     coord : Geometry.point -> int,
29 :     draw : int * int -> unit,
30 :     move : int * int * int * int -> unit
31 :     }
32 :    
33 : monnier 2 val min = Int.min
34 :     val max = Int.max
35 :    
36 : jhr 1188 datatype scroll_evt
37 :     = ScrUp of real
38 :     | ScrDown of real
39 :     | ScrStart of real
40 :     | ScrMove of real
41 :     | ScrEnd of real
42 : monnier 2
43 : jhr 1188 datatype scrollbar = Scrollbar of {
44 :     widget : Widget.widget,
45 :     evt : scroll_evt CML.event,
46 :     setvals : {top : real option, sz : real option} -> unit
47 :     }
48 : monnier 2
49 : jhr 1188 datatype mseMsg
50 :     = Grab of point
51 :     | Move of point
52 :     | Ungrab of point
53 :     | UpGrab of point
54 :     | UpUngrab of point
55 :     | DownGrab of point
56 :     | DownUngrab of point
57 : monnier 2
58 : jhr 1188 datatype rqst
59 :     = SetVals of {top : real option, sz : real option }
60 :     | DoRealize of {
61 :     env : in_env,
62 :     win : window,
63 :     sz : size
64 :     }
65 :    
66 :     type scroll = { (* the variable "me" ranges over this type *)
67 :     curx : int,
68 :     swid : int
69 : monnier 2 }
70 :    
71 : jhr 1188 val initSize = 1000
72 :     val minSwid = 8
73 : monnier 2
74 : jhr 1188 fun newVals (me as {curx, swid}, size, arg) = (case arg
75 :     of {top=NONE, sz=NONE} => me
76 :     | {top=SOME top, sz=NONE} => {
77 :     curx=min(size-swid,max(0,floor(top * (real size)))),
78 :     swid=swid
79 :     }
80 :     | {top=NONE, sz=SOME sz} => {
81 :     curx=curx,
82 :     swid=min(size-curx,max(minSwid,ceil(sz * (real size))))
83 :     }
84 :     | {top=SOME top, sz=SOME sz} => let
85 :     val sz'=min(size,max(minSwid,ceil(sz * (real size))))
86 :     val top'=min(size-sz',max(0,floor(top * (real size))))
87 :     in
88 :     {curx=top',swid=sz'}
89 :     end
90 :     (* end case *))
91 : monnier 2
92 : jhr 1188 fun mkScroll (root, dim, color, bg, {bounds_of, realize} : scroll_view) = let
93 :     val _ = if dim < 4
94 :     then LibBase.failure {module="Scrollbar", func="mkScroll", msg="dim < 4"}
95 :     else ()
96 :     val scr = screenOf root
97 :     val msechan = channel () (* mouse to scrollbar *)
98 :     val valchan = channel () (* scrollbar to user *)
99 :     val reqchan = channel () (* user to scrollbar *)
100 :     val mevt = recvEvt msechan
101 :     val reqevt = recvEvt reqchan
102 : monnier 2
103 : jhr 1188 (* mouse reader *)
104 :     fun mseProc m = let
105 :     fun downLoop (movef, upf) = let
106 :     fun loop () = (case msgBodyOf (sync m)
107 :     of MOUSE_LastUp {pt,...} => upf pt
108 :     | MOUSE_Motion {pt,...} => (movef pt;loop ())
109 :     | _ => loop ()
110 :     (* end case *))
111 :     in
112 :     loop ()
113 :     end
114 : monnier 2
115 : jhr 1188 fun loop () = (case msgBodyOf (sync m)
116 :     of MOUSE_FirstDown {but=btn as MButton 1,pt,...} => (
117 :     send (msechan, UpGrab pt);
118 :     downLoop (fn _ => (), fn p => send(msechan, UpUngrab p));
119 :     loop ())
120 :     | MOUSE_FirstDown {but=btn as (MButton 2),pt,...} => (
121 :     send (msechan, Grab pt);
122 :     downLoop (
123 :     fn p => send(msechan, Move p),
124 :     fn p => send(msechan, Ungrab p)
125 :     );
126 :     loop ())
127 :     | MOUSE_FirstDown {but=btn as MButton 3,pt,...} => (
128 :     send (msechan, DownGrab pt);
129 :     downLoop (fn _ => (),fn p => send(msechan, DownUngrab p));
130 :     loop ())
131 :     | _ => loop ()
132 :     (* end case *))
133 :     in
134 :     loop ()
135 :     end
136 : monnier 2
137 : jhr 1188 val config = realize (root,color)
138 : monnier 2
139 : jhr 1188 fun realizeScroll {env=inenv, win, sz=winsz} me = let
140 :     val InEnv{m,ci,...} = Interact.ignoreKey inenv
141 :     val config = config (Drawing.drawableOfWin win)
142 : monnier 2
143 : jhr 1188 (* returns (me, data) *)
144 :     fun reconfig ({curx, swid}, size, sz, redraw) = let
145 :     val data as {size=size', draw, ...} = config sz
146 :     val scale = 1.0 / real size
147 :     val size' = real size'
148 :     val curx' = floor((scale * real curx) * size')
149 :     val swid' = ceil((scale * real swid) * size')
150 :     in
151 :     if redraw then draw (curx',swid') else ();
152 :     ({curx=curx', swid=swid'}, data)
153 :     end
154 : monnier 2
155 : jhr 1188 (* returns (b, me', data'), where b is true iff scrollbar has been reconfigured *)
156 :     fun handleCIEvt (evt, me : scroll, data as {size, draw, ...} : scroll_state) = (
157 :     case msgBodyOf evt
158 :     of CI_OwnDeath => (false, me, data)
159 :     | CI_Redraw _ => (draw (#curx me, #swid me); (false, me, data))
160 :     | CI_Resize (RECT{wid,ht,...}) => let
161 :     val (me', data') = reconfig (me, size, SIZE{wid=wid,ht=ht}, true)
162 :     in (true, me', data') end
163 :     | _ => (false, me, data)
164 :     (* end case *))
165 : monnier 2
166 : jhr 1188 fun handleReqEvt (SetVals arg,
167 :     me as {curx, swid}, (* application's version *)
168 :     me' as {curx = curx', swid = swid'}, (* scrollbar's version *)
169 :     {size, move, ...} : scroll_state) = let
170 :     val me'' as {curx=curx'', swid=swid''} = newVals (me, size, arg)
171 :     in
172 :     if curx' <> curx'' orelse swid' <> swid''
173 :     then move (curx', swid', curx'', swid'')
174 :     else ();
175 :     me''
176 :     end
177 :     | handleReqEvt (DoRealize _, _, me, _) = me
178 : monnier 2
179 : jhr 1188 fun sendValAbortOnReq (v, f, me,
180 :     data as {size, ...} : scroll_state) = let
181 :     val v = min(size - 1, max(0, v))
182 :     val valevt = sendEvt (valchan, f (real v / real size))
183 :     in select [
184 :     wrap (valevt, fn () => me),
185 :     wrap (reqevt, fn evt => handleReqEvt (evt, me, me, data))
186 :     ]
187 :     end
188 : monnier 2
189 : jhr 1188 (* xoff, me is widget's view;
190 :     x is new position of mouse pointer, relative to beginning of widget's window;
191 :     returns (xoff', me') *)
192 :     fun moveSlide (xoff, me as {curx, swid}, {size, move, ...} : scroll_state, x) = let
193 :     val curx' = x - xoff
194 :     val maxx = size - swid
195 :     val (xoff', curx'') =
196 :     if curx' < 0
197 :     then (x - curx, 0)
198 :     else if curx' > maxx
199 :     then (x - curx, maxx)
200 :     else (xoff, curx')
201 :     in
202 :     if curx'' <> curx
203 :     then (move (curx, swid, curx'', swid);
204 :     (xoff', {curx=curx'',swid=swid}))
205 :     else (xoff', me)
206 :     end
207 : monnier 2
208 : jhr 1188 (* returns (me', data') *)
209 :     fun handleMEvt (Grab p, me as {curx,swid}, data as {size, coord, ...}) = let
210 :     val x = coord p
211 :     val maxx = size - swid
212 :     val (xoff, me') =
213 :     if curx <= x andalso x < curx + swid
214 :     then ((x - curx), me)
215 :     else
216 :     let
217 :     val curx' = min (maxx, max (0, x - (swid div 2)))
218 :     in
219 :     (x - curx', #2(moveSlide (0 (* irrelevant *), me, data, curx')))
220 :     end
221 : monnier 2
222 : jhr 1188 (* xoff, me are scrollbar's view, and tell us where mouse pointer was;
223 :     me' is what application has asked that scroll be;
224 :     returns xoff relative to me' *)
225 :     fun newxoff(xoff, me : scroll, me' : scroll) =
226 :     #curx me + xoff - #curx me'
227 : monnier 2
228 : jhr 1188 (* me is application's view;
229 :     xoff, me' are scrollbar's view;
230 :     force is true iff insist on communication with application, even if
231 :     it makes request;
232 :     returns (xoff', me''), shared by application and scrollbar *)
233 :     fun sendVal (me, xoff, me', f, force, data as {size, ...}) = let
234 :     val v = #curx me'
235 :     val valevt = sendEvt (valchan, f (real v / real size))
236 : monnier 2
237 : jhr 1188 fun loop (me, xoff, me', valevt) =
238 :     select [
239 :     wrap (valevt, fn () => (xoff, me')),
240 :     wrap (reqevt, fn evt => let
241 :     val me'' = handleReqEvt (evt, me, me', data)
242 :     val xoff' = newxoff(xoff, me', me'')
243 :     in if force
244 :     then let val v' = #curx me''
245 :     val valevt' =
246 :     sendEvt (valchan, f (real v' / real size))
247 :     in loop(me'', xoff', me'', valevt') end
248 :     else (xoff', me'')
249 :     end)
250 :     ]
251 :     in loop(me, xoff, me', valevt) end
252 : monnier 2
253 : jhr 1188 (* xoffOpt is NONE when we've lost track of where mouse was - which is
254 :     when a CI_Resize has been processed;
255 :     returns (b, (xoffOpt', me')), where b is true iff an Ungrab has been processed *)
256 :     fun hMEvt (Ungrab x, xoffOpt, me, data) = (case xoffOpt
257 :     of NONE => (false,
258 :     let val (_, me') =
259 :     sendVal (me, 0 (* irrelevant *), me, ScrEnd, true, data)
260 :     in (NONE (* irrelevant *), me') end)
261 :     | SOME xoff => let
262 :     val me' = #2(moveSlide (xoff, me, data, coord x))
263 :     in (false,
264 :     let val (_, me'') =
265 :     sendVal (me, 0 (* irrelevant *), me', ScrEnd, true, data)
266 :     in (NONE (* irrelevant *), me'') end)
267 :     end
268 :     (* end case *))
269 :     | hMEvt (Move x, xoffOpt, me, data) = (case xoffOpt
270 :     of NONE => (true, (SOME(coord x - #curx me), me))
271 :     | SOME xoff => let
272 :     val (xoff', me') = moveSlide (xoff, me, data, coord x)
273 :     in if #curx me <> #curx me'
274 :     then (true,
275 :     let val (xoff'', me'') =
276 :     sendVal (me, xoff', me', ScrMove, false, data)
277 :     in (SOME xoff'', me'') end)
278 :     else (true, (SOME xoff', me'))
279 :     end
280 :     (* end case *))
281 :     | hMEvt (_, xoffOpt, me, _) = (true, (xoffOpt, me)) (* protocol error *)
282 :    
283 :     (* xoffOpt is NONE when we've lost track of where mouse was - which is
284 :     when a CI_Resize has been processed;
285 :     returns (me', data') *)
286 :     fun loop (xoffOpt, me, data) = select [
287 :     wrap (reqevt, fn evt => let
288 :     val me' = handleReqEvt (evt, me, me, data)
289 :     in case xoffOpt
290 :     of NONE => loop(NONE, me, data)
291 :     | SOME xoff => loop(SOME(newxoff(xoff, me, me')), me', data)
292 :     (* end case *)
293 :     end),
294 :     wrap (ci, fn evt => let
295 :     val (reconf, me', data') = handleCIEvt (evt, me, data)
296 :     in if reconf
297 :     then loop (NONE, me', data')
298 :     else loop (xoffOpt, me', data')
299 :     end),
300 :     wrap (mevt, fn evt =>
301 :     case hMEvt (evt, xoffOpt, me, data)
302 :     of (true, (xoffOpt, me)) => loop(xoffOpt, me, data)
303 :     | (false, (_, me)) => (me, data)
304 :     (* end case *))
305 :     ]
306 :    
307 :     val (xoff', me'') = sendVal(me, xoff, me', ScrStart, true, data)
308 :     in
309 :     loop (SOME xoff', me'', data)
310 :     end
311 :     | handleMEvt (UpGrab _, me, data) = let
312 :     fun hMEvt (UpUngrab x, me, data as {coord, ...}) =
313 :     (false, sendValAbortOnReq (coord x, ScrUp, me, data))
314 :     | hMEvt (_, me, _) = (true, me) (* protocol error *)
315 :    
316 :     fun loop (me, data) =
317 :     select [
318 :     wrap (reqevt, fn evt => loop (handleReqEvt (evt, me, me, data), data)),
319 :     wrap (ci, fn evt => let
320 :     val (_, me', data') = handleCIEvt (evt, me, data)
321 :     in loop (me', data') end),
322 :     wrap (mevt, fn evt =>
323 :     case hMEvt (evt, me, data)
324 :     of
325 :     (true, me) => loop (me, data)
326 :     | (false, me) => (me, data)
327 :     (* end case *))
328 :     ]
329 :     in
330 :     loop (me, data)
331 :     end
332 :     | handleMEvt (DownGrab p, me, data) = let
333 :     fun hMEvt (DownUngrab x, me, data as {coord, ...}) =
334 :     (false, sendValAbortOnReq (coord x, ScrDown, me, data))
335 :     | hMEvt (_, me, _) = (true, me) (* protocol error *)
336 :    
337 :     fun loop (me, data) =
338 :     select [
339 :     wrap (reqevt, fn evt => loop (handleReqEvt (evt, me, me, data), data)),
340 :     wrap (ci, fn evt => let
341 :     val (_, me', data') = handleCIEvt (evt, me, data)
342 :     in loop(me', data') end),
343 :     wrap (mevt, fn evt =>
344 :     case hMEvt (evt, me, data)
345 :     of (true, me) => loop (me, data)
346 :     | (false, me) => (me, data)
347 :     (* end case *))
348 :     ]
349 :     in
350 :     loop (me, data)
351 :     end
352 :     | handleMEvt (_, me, data) = (me, data) (* protocol error *)
353 :    
354 :     fun cmdProc (me, data) = cmdProc (select [
355 :     wrap (reqevt, fn evt => (handleReqEvt (evt, me, me, data), data)),
356 :     wrap (mevt, fn evt => handleMEvt (evt, me, data)),
357 :     wrap (ci, fn evt => let
358 :     val (_, me', data') = handleCIEvt (evt, me, data)
359 :     in (me', data') end)
360 :     ])
361 : monnier 2 in
362 : jhr 1188 spawn (fn () => mseProc m);
363 :     spawn (fn () => (cmdProc(reconfig (me, initSize, winsz, false)); ()));
364 :     ()
365 :     end (* realizeScroll *)
366 :     fun initLoop vals = case recv reqchan
367 :     of SetVals arg => initLoop (newVals (vals, initSize, arg))
368 :     | DoRealize arg => realizeScroll arg vals
369 :     (* end case *)
370 :     in
371 :     spawn (fn () => initLoop {curx=0,swid=initSize});
372 :     Scrollbar {
373 :     widget =
374 :     mkWidget{
375 :     root=root,
376 :     args=fn () => {background = bg},
377 :     boundsOf=bounds_of dim,
378 :     realize=fn arg => send(reqchan, DoRealize arg)
379 :     },
380 :     evt = recvEvt valchan,
381 :     setvals = (fn arg => send (reqchan, SetVals arg))
382 :     }
383 :     end (* mkScroll *)
384 : monnier 2
385 : jhr 1188 val attrs = [
386 :     (Attrs.attr_width, Attrs.AT_Int, Attrs.AV_Int 12),
387 :     (Attrs.attr_background, Attrs.AT_Color, Attrs.AV_Str "gray"),
388 :     (Attrs.attr_color, Attrs.AT_Color, Attrs.AV_NoValue)
389 :     ]
390 : monnier 2
391 : jhr 1188 fun scrollbar scrollView (root,view,args) = let
392 :     val attrs = W.findAttr (W.attrs(view,attrs,args))
393 :     val sz = Attrs.getInt(attrs Attrs.attr_width)
394 :     val bg = Attrs.getColor(attrs Attrs.attr_background)
395 :     val color = (case Attrs.getColorOpt(attrs Attrs.attr_color)
396 :     of NONE => bg
397 :     | SOME c => c
398 :     (* end case *))
399 : monnier 2 in
400 : jhr 1188 mkScroll(root, sz, color, SOME bg, scrollView)
401 : monnier 2 end
402 :    
403 : jhr 1188 val hScrollbar = scrollbar horzScrollbar
404 :     val vScrollbar = scrollbar vertScrollbar
405 : monnier 2
406 : jhr 1188 fun mk scrollView root {sz, color} = let
407 :     val color = (case color
408 :     of SOME c => c
409 :     | NONE => colorOfScr (screenOf root) (CMS_Name "gray")
410 :     (* end case *))
411 : monnier 2 in
412 : jhr 1188 mkScroll (root, sz, color, NONE, scrollView)
413 : monnier 2 end
414 :    
415 : jhr 1188 val mkHScrollbar = mk horzScrollbar
416 :     val mkVScrollbar = mk vertScrollbar
417 : monnier 2
418 : jhr 1188 fun widgetOf (Scrollbar {widget,...}) = widget
419 :     fun evtOf (Scrollbar {evt,...}) = evt
420 :     fun setVals (Scrollbar{setvals,...}) arg = setvals arg
421 : monnier 2
422 : jhr 1188 end (* ScrollBar *)

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