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

Parent Directory | Revision Log | Patch

	revision 651, Thu Jun 1 18:34:03 2000 UTC	revision 1188, Wed Apr 17 15:17:31 2002 UTC
#	Line 1	Line 1
1	(* scrollbar.sml	(* scrollbar.sml
2	*	*
3	* COPYRIGHT (c) 1994 by AT&T Bell Laboratories  See COPYRIGHT file for details.	* COPYRIGHT (c) 1994, 2002 by AT&T Bell Laboratories  See COPYRIGHT file for details.
4	*	*
5	* Scrollbar widget.	* Scrollbar widget.
6		*
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	*)	*)
17
18	structure Scrollbar : SCROLLBAR = struct	structure Scrollbar : SCROLLBAR =
19		struct
20
21	structure CML = CML	structure CML = CML
22	structure W = Widget	structure W = Widget
23
24	open CML Geometry EXeneBase Interact Widget ScrollView	open CML Geometry EXeneBase Interact Widget ScrollView
25
26		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	val min = Int.min	val min = Int.min
34	val max = Int.max	val max = Int.max
35
36	datatype scroll_evt =	datatype scroll_evt
37	ScrUp of real	= ScrUp of real
38	| ScrDown of real	| ScrDown of real
39	| ScrStart of real	| ScrStart of real
40	| ScrMove of real	| ScrMove of real
41	| ScrEnd of real	| ScrEnd of real
42
43	datatype scrollbar =	datatype scrollbar = Scrollbar of {
	Scrollbar of {
44	widget : Widget.widget,	widget : Widget.widget,
45	evt : scroll_evt CML.event,	evt : scroll_evt CML.event,
46	setvals : {top : real option, sz : real option } -> unit	setvals : {top : real option, sz : real option } -> unit
47	}	}
48
49	datatype mseMsg =	datatype mseMsg
50	Grab of point	= Grab of point
51	| Move of point	| Move of point
52	| Ungrab of point	| Ungrab of point
53	| UpGrab of point	| UpGrab of point
#	Line 38	Line 55
55	| DownGrab of point	| DownGrab of point
56	| DownUngrab of point	| DownUngrab of point
57
58	datatype rqst =	datatype rqst
59	SetVals of {top : real option, sz : real option }	= SetVals of {top : real option, sz : real option }
60	| DoRealize of {	| DoRealize of {
61	env : in_env,	env : in_env,
62	win : window,	win : window,
63	sz : size	sz : size
64	}	}
65
66	type scroll = {	type scroll = {  (* the variable "me" ranges over this type *)
67	curx : int,	curx : int,
68	swid : int	swid : int
69	}	}
#	Line 54	Line 71
71	val initSize = 1000	val initSize = 1000
72	val minSwid = 8	val minSwid = 8
73
74	fun newVals (me as {curx, swid}, size, arg) =	fun newVals (me as {curx, swid}, size, arg) = (case arg
75	case arg of	of {top=NONE, sz=NONE} => me
76	{top=NONE, sz=NONE} => me	| {top=SOME top, sz=NONE} => {
77	| {top=SOME top, sz=NONE} =>	curx=min(size-swid,max(0,floor(top * (real size)))),
78	{curx=min(size-swid,max(0,floor(top * (real size)))),swid=swid}	swid=swid
79	| {top=NONE, sz=SOME sz} =>	}
80	{curx=curx,swid=min(size-curx,max(minSwid,ceil(sz * (real size))))}	| {top=NONE, sz=SOME sz} => {
81	| {top=SOME top, sz=SOME sz} =>	curx=curx,
82	let	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))))	val sz' = min(size,max(minSwid,ceil(sz * (real size))))
86	val top' = min(size-sz',max(0,floor(top * (real size))))	val top' = min(size-sz',max(0,floor(top * (real size))))
87	in	in
88	{curx=top',swid=sz'}	{curx=top',swid=sz'}
89	end	end
90		(* end case *))
91
92	fun mkScroll (root, dim, color, bg, {bounds_of, realize} : scroll_view) = let	fun mkScroll (root, dim, color, bg, {bounds_of, realize} : scroll_view) = let
93	val _ = if dim < 4	val _ = if dim < 4
#	Line 81	Line 101
101	val reqevt = recvEvt reqchan	val reqevt = recvEvt reqchan
102
103	(* mouse reader *)	(* mouse reader *)
104	fun mseP m = let	fun mseProc m = let
105	fun downLoop (movef,upf) = let	fun downLoop (movef,upf) = let
106	fun loop () =	fun loop () = (case msgBodyOf (sync m)
107	case msgBodyOf (sync m) of	of MOUSE_LastUp {pt,...} => upf pt
	MOUSE_LastUp {pt,...} => upf pt
108	| MOUSE_Motion {pt,...} => (movef pt;loop ())	| MOUSE_Motion {pt,...} => (movef pt;loop ())
109	| _ => loop ()	| _ => loop ()
110		(* end case *))
111	in	in
112	loop ()	loop ()
113	end	end
114
115	fun loop () =	fun loop () = (case msgBodyOf (sync m)
116	case msgBodyOf (sync m) of	of MOUSE_FirstDown {but=btn as MButton 1,pt,...} => (
	MOUSE_FirstDown {but=btn as MButton 1,pt,...} => (
117	send (msechan, UpGrab pt);	send (msechan, UpGrab pt);
118	downLoop (fn _ => (), fn p => send(msechan, UpUngrab p));	downLoop (fn _ => (), fn p => send(msechan, UpUngrab p));
119	loop ()	loop ())
	)
120	| MOUSE_FirstDown {but=btn as (MButton 2),pt,...} => (	| MOUSE_FirstDown {but=btn as (MButton 2),pt,...} => (
121	send (msechan, Grab pt);	send (msechan, Grab pt);
122	downLoop (	downLoop (
123	fn p => send(msechan, Move p),	fn p => send(msechan, Move p),
124	fn p => send(msechan, Ungrab p)	fn p => send(msechan, Ungrab p)
125	);	);
126	loop ()	loop ())
	)
127	| MOUSE_FirstDown {but=btn as MButton 3,pt,...} => (	| MOUSE_FirstDown {but=btn as MButton 3,pt,...} => (
128	send (msechan, DownGrab pt);	send (msechan, DownGrab pt);
129	downLoop (fn _ => (),fn p => send(msechan, DownUngrab p));	downLoop (fn _ => (),fn p => send(msechan, DownUngrab p));
130	loop ()	loop ())
	)
131	| _ => loop ()	| _ => loop ()
132		(* end case *))
133	in	in
134	loop ()	loop ()
135	end	end
#	Line 124	Line 140
140	val InEnv{m,ci,...} = Interact.ignoreKey inenv	val InEnv{m,ci,...} = Interact.ignoreKey inenv
141	val config = config (Drawing.drawableOfWin win)	val config = config (Drawing.drawableOfWin win)
142
143		(* returns (me, data) *)
144	fun reconfig ({curx,swid},size,sz,redraw) = let	fun reconfig ({curx,swid},size,sz,redraw) = let
145	val data as {size=size',draw,...} = config sz	val data as {size=size',draw,...} = config sz
146	val curx' = (curx*size') div size	val scale = 1.0 / real size
147	val swid' = (swid*size') div size	val size' = real size'
148		val curx' = floor((scale * real curx) * size')
149		val swid' = ceil((scale * real swid) * size')
150	in	in
151	if redraw then draw (curx',swid') else ();	if redraw then draw (curx',swid') else ();
152	cmdP ({curx=curx', swid=swid'}, data)	({curx=curx', swid=swid'}, data)
153	end	end
154
155	and cmdP (me, {size,coord,draw,move}) = let	(* 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	fun sendVal (v, f) = send (valchan, f ((real v)/(real (size))))	case msgBodyOf evt
158		of CI_OwnDeath => (false, me, data)
159	fun moveSlide (me as {curx,swid}, x) = let	| CI_Redraw _ => (draw (#curx me, #swid me); (false, me, data))
160	val curx' = min(size-swid,max(0,x))	| CI_Resize (RECT{wid,ht,...}) => let
161	in	val (me', data') = reconfig (me, size, SIZE{wid=wid,ht=ht}, true)
162	if curx' <> curx then let	in (true, me', data') end
163		| _ => (false, me, data)
164		(* end case *))
165
166		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	in
172	move (curx, swid, curx', swid);	if curx' <> curx'' orelse swid' <> swid''
173	{curx=curx',swid=swid}	then move (curx', swid', curx'', swid'')
174	end	else ();
175	else me	me''
176	end	end
177		| handleReqEvt (DoRealize _, _, me, _) = me
178
179	fun handleCIEvt (evt, me : scroll) =	fun sendValAbortOnReq (v, f, me,
180	case msgBodyOf evt of	data as {size, ...} : scroll_state) = let
181	CI_OwnDeath => me	val v = min(size - 1, max(0, v))
182	| CI_Redraw _ => (draw (#curx me, #swid me); me)	val valevt = sendEvt (valchan, f (real v / real size))
183	| CI_Resize (RECT{wid,ht,...}) =>	in select [
184	reconfig (me, size, SIZE{wid=wid,ht=ht},true)	wrap (valevt, fn () => me),
185	| _ => me	wrap (reqevt, fn evt => handleReqEvt (evt, me, me, data))
186		]
	fun handleReqEvt (SetVals arg, me as {curx,swid}) =
	let
	val me' as {curx=curx',swid=swid'} = newVals (me, size, arg)
	in
	if curx <> curx' orelse swid <> swid' then
	move (curx, swid, curx', swid')
	else ();
	me'
187	end	end
	| handleReqEvt (DoRealize _,me) = me
188
189		(* 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
208	fun handleMEvt (Grab p, me as {curx,swid}) = let	(* returns (me', data') *)
209		fun handleMEvt (Grab p, me as {curx,swid}, data as {size, coord, ...}) = let
210	val x = coord p	val x = coord p
211	val maxx = size - swid	val maxx = size - swid
212	val (xoff, me') =	val (xoff, me') =
213	if curx <= x andalso x < curx + swid then ((x - curx), me)	if curx <= x andalso x < curx + swid
214	else if 0 <= x andalso x < maxx+swid then	then ((x - curx), me)
215		else
216	let	let
217	val curx' = min(maxx, max(0, x - (swid div 2)))	val curx' = min(maxx, max(0, x - (swid div 2)))
218	in	in
219	(x - curx', moveSlide (me, curx'))	(x - curx', #2(moveSlide (0 (* irrelevant *), me, data, curx')))
220	end	end
	else if x < 0 then (swid div 2, moveSlide (me, 0))
	else (swid div 2, moveSlide (me, maxx))
221
222	fun hMEvt (Ungrab x, me) =	(* xoff, me are scrollbar's view, and tell us where mouse pointer was;
223	let	me' is what application has asked that scroll be;
224	val me' = moveSlide (me, (coord x) - xoff)	returns xoff relative to me' *)
225	in	fun newxoff(xoff, me : scroll, me' : scroll) =
226	sendVal (#curx me', ScrEnd);	#curx me + xoff - #curx me'
227	(false, me')
228	end	(* me is application's view;
229	| hMEvt (Move x, me) =	xoff, me' are scrollbar's view;
230	let	force is true iff insist on communication with application, even if
231	val me' = moveSlide (me, (coord x) - xoff)	it makes request;
232	in	returns (xoff', me''), shared by application and scrollbar *)
233	if (#curx me <> #curx me') then sendVal (#curx me', ScrMove)	fun sendVal (me, xoff, me', f, force, data as {size, ...}) = let
234	else ();	val v = #curx me'
235	(true, me')	val valevt = sendEvt (valchan, f (real v / real size))
	end
	| hMEvt (_, me) = (true, me)  (* protocol error *)
236
237	fun loop me = select [	fun loop (me, xoff, me', valevt) =
238	wrap (reqevt,fn evt => loop (handleReqEvt (evt, me))),	select [
239	wrap (ci, fn evt => loop (handleCIEvt (evt, me))),	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
253		(* 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 =>	wrap (mevt, fn evt =>
301	case hMEvt (evt, me) of	case hMEvt (evt, xoffOpt, me, data)
302	(true, m) => loop m	of (true, (xoffOpt, me)) => loop(xoffOpt, me, data)
303	| (false, m) => m)	|    (false, (_, me)) => (me, data)
304		(* end case *))
305	]	]
306
307		val (xoff', me'') = sendVal(me, xoff, me', ScrStart, true, data)
308	in	in
309	sendVal (#curx me', ScrStart);	loop (SOME xoff', me'', data)
310	loop me' end	end
311	| handleMEvt (UpGrab _,me) = let	| handleMEvt (UpGrab _, me, data) = let
312		fun hMEvt (UpUngrab x, me, data as {coord, ...}) =
313	fun hMEvt (UpUngrab x, me) = (sendVal (coord x, ScrUp); (false, me))	(false, sendValAbortOnReq (coord x, ScrUp, me, data))
314	| hMEvt (_, me) = (true, me)  (* protocol error *)	| hMEvt (_, me, _) = (true, me)  (* protocol error *)
315
316	fun loop me =	fun loop (me, data) =
317	select [	select [
318	wrap (reqevt,fn evt => loop (handleReqEvt (evt, me))),	wrap (reqevt, fn evt => loop (handleReqEvt (evt, me, me, data), data)),
319	wrap (ci, fn evt => loop (handleCIEvt (evt, me))),	wrap (ci, fn evt => let
320		val (_, me', data') = handleCIEvt (evt, me, data)
321		in loop (me', data') end),
322	wrap (mevt, fn evt =>	wrap (mevt, fn evt =>
323	case hMEvt (evt, me) of	case hMEvt (evt, me, data)
324	(true, m) => loop m	of
325	| (false, m) => m)	(true, me) => loop (me, data)
326		| (false, me) => (me, data)
327		(* end case *))
328	]	]
329	in	in
330	loop me	loop (me, data)
331	end	end
332	| handleMEvt (DownGrab p,me) = let	| handleMEvt (DownGrab p, me, data) = let
333		fun hMEvt (DownUngrab x, me, data as {coord, ...}) =
334	fun hMEvt (DownUngrab x, me) = (sendVal (coord x, ScrDown); (false, me))	(false, sendValAbortOnReq (coord x, ScrDown, me, data))
335	| hMEvt (_, me) = (true, me)  (* protocol error *)	| hMEvt (_, me, _) = (true, me)  (* protocol error *)
336
337	fun loop me =	fun loop (me, data) =
338	select [	select [
339	wrap (reqevt,fn evt => loop (handleReqEvt (evt, me))),	wrap (reqevt, fn evt => loop (handleReqEvt (evt, me, me, data), data)),
340	wrap (ci, fn evt => loop (handleCIEvt (evt, me))),	wrap (ci, fn evt => let
341		val (_, me', data') = handleCIEvt (evt, me, data)
342		in loop(me', data') end),
343	wrap (mevt, fn evt =>	wrap (mevt, fn evt =>
344	case hMEvt (evt, me) of	case hMEvt (evt, me, data)
345	(true, m) => loop m	of (true, me) => loop (me, data)
346	| (false, m) => m)	| (false, me) => (me, data)
347		(* end case *))
348	]	]
349	in	in
350	loop me	loop (me, data)
351	end	end
352	| handleMEvt (_,me) = me   (* protocol error *)	| handleMEvt (_, me, data) = (me, data)   (* protocol error *)
353
354	fun cmdLoop me =	fun cmdProc (me, data) = cmdProc (select [
355	cmdLoop (select [	wrap (reqevt, fn evt => (handleReqEvt (evt, me, me, data), data)),
356	wrap (reqevt, fn evt => handleReqEvt (evt, me)),	wrap (mevt, fn evt => handleMEvt (evt, me, data)),
357	wrap (mevt, fn evt => handleMEvt (evt, me)),	wrap (ci, fn evt => let
358	wrap (ci, fn evt => handleCIEvt (evt, me))	val (_, me', data') = handleCIEvt (evt, me, data)
359		in (me', data') end)
360	])	])
361	in	in
362	cmdLoop me	spawn (fn () => mseProc m);
363	end	spawn (fn () => (cmdProc(reconfig (me, initSize, winsz, false)); ()));
	in
	spawn (fn () => mseP m);
	spawn (fn() => (reconfig (me, initSize, winsz,false);()));
364	()	()
365	end	end (* realizeScroll *)
366		fun initLoop vals = case recv reqchan
367	fun initLoop vals =	of SetVals arg => initLoop (newVals (vals, initSize, arg))
	case recv reqchan of
	SetVals arg => initLoop (newVals (vals, initSize, arg))
368	| DoRealize arg => realizeScroll arg vals	| DoRealize arg => realizeScroll arg vals
369		(* end case *)
370	in	in
371	spawn (fn () => initLoop {curx=0,swid=initSize});	spawn (fn () => initLoop {curx=0,swid=initSize});
372	Scrollbar {	Scrollbar {
#	Line 279	Line 380
380	evt = recvEvt valchan,	evt = recvEvt valchan,
381	setvals = (fn arg => send (reqchan, SetVals arg))	setvals = (fn arg => send (reqchan, SetVals arg))
382	}	}
383	end	end (* mkScroll *)
384
385	val attrs = [	val attrs = [
386	(Attrs.attr_width,          Attrs.AT_Int,     Attrs.AV_Int 12),	(Attrs.attr_width,          Attrs.AT_Int,     Attrs.AV_Int 12),
#	Line 291	Line 392
392	val attrs = W.findAttr (W.attrs(view,attrs,args))	val attrs = W.findAttr (W.attrs(view,attrs,args))
393	val sz = Attrs.getInt(attrs Attrs.attr_width)	val sz = Attrs.getInt(attrs Attrs.attr_width)
394	val bg = Attrs.getColor(attrs Attrs.attr_background)	val bg = Attrs.getColor(attrs Attrs.attr_background)
395	val color = case Attrs.getColorOpt(attrs Attrs.attr_color) of	val color = (case Attrs.getColorOpt(attrs Attrs.attr_color)
396	NONE => bg	of NONE => bg
397	| SOME c => c	| SOME c => c
398	in mkScroll(root,sz,color,SOME bg,scrollView) end	(* end case *))
399		in
400		mkScroll(root, sz, color, SOME bg, scrollView)
401		end
402
403	val hScrollbar = scrollbar horzScrollbar	val hScrollbar = scrollbar horzScrollbar
404	val vScrollbar = scrollbar vertScrollbar	val vScrollbar = scrollbar vertScrollbar
405
406	fun mkHScrollbar root {sz, color} = let	fun mk scrollView root {sz, color} = let
407	val color = case color of	val color = (case color
408	SOME c => c	of SOME c => c
409	| NONE => colorOfScr (screenOf root) (CMS_Name "gray")	| NONE => colorOfScr (screenOf root) (CMS_Name "gray")
410	in mkScroll (root, sz, color, NONE, horzScrollbar) end	(* end case *))
411		in
412		mkScroll (root, sz, color, NONE, scrollView)
413		end
414
415	fun mkVScrollbar root {sz, color} = let	val mkHScrollbar = mk horzScrollbar
416	val color = case color of	val mkVScrollbar = mk vertScrollbar
	SOME c => c
	| NONE => colorOfScr (screenOf root) (CMS_Name "gray")
	in mkScroll (root, sz, color, NONE, vertScrollbar) end
417
418	fun widgetOf (Scrollbar {widget,...}) = widget	fun widgetOf (Scrollbar {widget,...}) = widget
419	fun evtOf (Scrollbar {evt,...}) = evt	fun evtOf (Scrollbar {evt,...}) = evt
420	fun setVals (Scrollbar{setvals,...}) arg = setvals arg	fun setVals (Scrollbar{setvals,...}) arg = setvals arg
421
422	end (* ScrollBar *)	end (* ScrollBar *)

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

Legend: Removed from v.651   changed lines   Added in v.1188

---

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