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 2 - (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