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/composite/pile.sml
ViewVC logotype

Annotation of /sml/trunk/src/eXene/widgets/composite/pile.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2 - (view) (download)

1 : monnier 2 (* pile.sml
2 :     *
3 :     * COPYRIGHT (c) 1992 by AT&T Bell Laboratories See COPYRIGHT file for details.
4 :     *
5 :     * Pile widget, for managing a collection of widgets, one piled on top of
6 :     * another.
7 :     *)
8 :    
9 :     signature PILE =
10 :     sig
11 :    
12 :     structure W : WIDGET
13 :    
14 :     type pile
15 :    
16 :     exception NoWidgets
17 :     exception BadIndex
18 :    
19 :     val pile : (W.root * W.view * W.arg list) -> W.widget list -> pile
20 :     val mkPile : W.root -> W.widget list -> pile
21 :     val widgetOf : pile -> W.widget
22 :    
23 :     val insert : pile -> (int * W.widget list) -> unit
24 :     val append : pile -> (int * W.widget list) -> unit
25 :     val delete : pile -> int list -> unit
26 :    
27 :     val mkVisible : pile -> int -> unit
28 :     val visible : pile -> int
29 :     val size : pile -> int
30 :    
31 :     end (* PILE *)
32 :    
33 :     structure Pile : PILE =
34 :     struct
35 :    
36 :     structure W = Widget
37 :     structure I = Index
38 :    
39 :     exception NoWidgets
40 :     exception BadIndex = I.BadIndex
41 :    
42 :     datatype request =
43 :     Bounds
44 :     | DoRealize of {
45 :     env : Interact.in_env,
46 :     win : W.EXB.window,
47 :     sz : W.G.size
48 :     }
49 :     | Visible of int option CML.chan
50 :     | Size of int CML.chan
51 :     | MakeVis of int
52 :     | Insert of int * W.widget list
53 :     | Delete of int list
54 :    
55 :     datatype reply =
56 :     Okay
57 :     | Error of exn
58 :    
59 :     datatype pile = Pile of {
60 :     widget : W.widget,
61 :     repChan : reply CML.chan,
62 :     reqChan : request CML.chan
63 :     }
64 :    
65 :     datatype item = W of {
66 :     widget : W.widget,
67 :     win : W.EXB.window,
68 :     co : Interact.cmd_out CML.event
69 :     }
70 :    
71 :     datatype 'a pile_rep =
72 :     Empty
73 :     | P of {
74 :     top : int,
75 :     widget : 'a,
76 :     wlist : 'a list
77 :     }
78 :    
79 :     fun cloop co () = (CML.sync co; cloop co ())
80 :    
81 :     fun isValid (Empty,0) = true
82 :     | isValid (Empty,_) = false
83 :     | isValid (P{wlist,...},i) = Index.isValid(wlist,i)
84 :    
85 :     fun topIndex Empty = NONE
86 :     | topIndex (P{top,...}) = SOME top
87 :    
88 :     fun topi Empty = raise LibBase.Impossible "Pile.topi"
89 :     | topi (P{top,...}) = top
90 :    
91 :     fun topWidget Empty = raise LibBase.Impossible "Pile.topWidget"
92 :     | topWidget (P{widget,...}) = widget
93 :    
94 :     fun topWin Empty = raise LibBase.Impossible "Pile.topWin"
95 :     | topWin (P{widget=W{win,...},...}) = win
96 :    
97 :     fun size Empty = 0
98 :     | size (P{wlist,...}) = length wlist
99 :    
100 :     val dfltDim = W.DIM {base=1, incr=1, min=0, nat=0, max=NONE}
101 :     val dfltBounds = { x_dim = dfltDim, y_dim = dfltDim }
102 :     fun bounds f Empty = dfltBounds
103 :     | bounds f (P{widget,...}) = f widget
104 :    
105 :     fun deleteW (Empty,_) = raise BadIndex
106 :     | deleteW (P{wlist,top,widget},indices) = let
107 :     val indices = I.chkSort indices
108 :     in
109 :     case I.delete(wlist,indices) of
110 :     ([],dlist) => (Empty,dlist)
111 :     | (wlist',dlist) => case I.preIndices (top,indices) of
112 :     NONE => (P{wlist=wlist',top=0,widget= hd wlist'},dlist)
113 :     | SOME j => (P{wlist=wlist',top= top-j,widget= widget},dlist)
114 :     end handle _ => raise BadIndex
115 :    
116 :     (* insertW:
117 :     * Assume wl <> []
118 :     *)
119 :     fun insertW (Empty,0,wl) = P{wlist=wl,top=0,widget= hd wl}
120 :     | insertW (Empty,_,_) = raise BadIndex
121 :     | insertW (P{wlist,top,widget},index,wl) = let
122 :     val wlist' = I.insert(wlist,index,wl)
123 :     val top' = if index <= top then top + (length wl) else top
124 :     in
125 :     P{wlist=wlist',top=top',widget=widget}
126 :     end handle _ => raise BadIndex
127 :    
128 :     fun makeVis (Empty,_) = raise BadIndex
129 :     | makeVis (P{wlist,...},i) = let
130 :     val w = List.nth(wlist,i)
131 :     in
132 :     (P{wlist=wlist,top=i,widget=w}, w)
133 :     end handle _ => raise BadIndex
134 :    
135 :     fun makeReal (mkr, Empty) = Empty
136 :     | makeReal (mkr, P{top,widget,wlist}) = let
137 :     val wl = map mkr wlist
138 :     in
139 :     P{top = top,wlist = wl,widget = List.nth(wl,top)}
140 :     end
141 :    
142 :     fun destroy (W{win,co,...}) = (W.EXW.destroyWin win; CML.spawn (cloop co); ())
143 :    
144 :     fun mkPile root widgets = let
145 :     open CML Geometry Interact W.EXB W.EXW
146 :     val repChan = channel ()
147 :     val reqChan = channel ()
148 :     val sizeChan = channel ()
149 :     val reqEvt = recvEvt reqChan
150 :    
151 :     fun makeCOEvt Empty = choose []
152 :     | makeCOEvt (P{wlist,...}) = let
153 :     fun mkEvt(W{co,...},i) = wrap(co, fn evt => (i,evt))
154 :     fun mkL ([],_) = []
155 :     | mkL (w::wl,i) = (mkEvt(w,i))::(mkL(wl,i+1))
156 :     in
157 :     choose(mkL(wlist,0))
158 :     end
159 :    
160 :     fun realize {env = inenv as InEnv{co=myco,...}, win, sz} widgets = let
161 :     val (my_inenv, my_outenv) = createWinEnv ()
162 :     val InEnv{ci=myci,...} = ignoreInput my_inenv
163 :     val router = Router.mkRouter (inenv, my_outenv, [])
164 :     val bounds = bounds (fn W{widget,...} => W.boundsOf widget)
165 :    
166 :     fun mkReal sz = let
167 :     val rect = mkRect(originPt, sz)
168 :     in
169 :     fn widget => let
170 :     val cwin = W.wrapCreate (win, rect,W.argsOf widget)
171 :     val (cinenv, coutenv as OutEnv{co,...}) = createWinEnv ()
172 :     in
173 :     Router.addChild router (cwin, coutenv);
174 :     configureWin cwin [WC_StackMode Below];
175 :     W.realizeFn widget {env=cinenv, win=cwin, sz=sz};
176 :     mapWin cwin;
177 :     W{
178 :     widget = widget,
179 :     win = cwin,
180 :     co = co
181 :     }
182 :     end
183 :     end
184 :    
185 :     fun zombie me = let
186 :     val childco = makeCOEvt me
187 :     fun handleReq (Visible rc) = send(rc,topIndex me)
188 :     | handleReq (Size rc) = send(rc,size me)
189 :     | handleReq Bounds = send(sizeChan, bounds me)
190 :     | handleReq _ = ()
191 :     fun loop () =
192 :     loop(select [
193 :     wrap(reqEvt, handleReq),
194 :     wrap (myci, fn _ => ()),
195 :     wrap (childco, fn _ => ())
196 :     ])
197 :     in
198 :     loop()
199 :     end
200 :    
201 :     (* FIX child requests own death *)
202 :     fun handleCO(me,i,CO_ResizeReq) =
203 :     (case topIndex me of
204 :     SOME j => if i = j then sync(myco CO_ResizeReq) else ()
205 :     | NONE => ())
206 :     | handleCO(_,_,CO_KillReq) = ()
207 :    
208 :     fun handleCI (me, CI_Resize (RECT{x,y,wid,ht})) = let
209 :     val sz = SIZE{wid=wid,ht=ht}
210 :     in
211 :     let val win = topWin me in resizeWin win sz end handle _ => ();
212 :     main(sz,me)
213 :     end
214 :     | handleCI (_, CI_ChildDeath w) = Router.delChild router w
215 :     | handleCI (me, CI_OwnDeath) = zombie me
216 :     | handleCI _ = ()
217 :    
218 :     and main (sz,me) = let
219 :     val childco = makeCOEvt me
220 :    
221 :     fun handleReq (Visible repc) = send(repc, topIndex me)
222 :     | handleReq (Size repc) = send(repc, size me)
223 :     | handleReq Bounds = send(sizeChan, bounds me)
224 :     | handleReq (MakeVis i) = (let
225 :     val (me',W{win,widget,...}) = makeVis(me,i)
226 :     in
227 :     configureWin win [WC_StackMode Above, WC_Size sz];
228 :     if W.okaySize(widget, sz) then () else sync(myco CO_ResizeReq);
229 :     send(repChan,Okay);
230 :     main (sz,me')
231 :     end handle e => send(repChan, Error e))
232 :     | handleReq (Delete indices) = (let
233 :     val (me',dlist) = deleteW(me,indices)
234 :     val W{win,...} = topWidget me
235 :     in
236 :     send(repChan,Okay);
237 :     let val W{win=win', widget,...} = topWidget me' in
238 :     if sameWindow(win,win') then ()
239 :     else (
240 :     configureWin win' [WC_StackMode Above, WC_Size sz];
241 :     if W.okaySize(widget, sz) then () else sync(myco CO_ResizeReq)
242 :     )
243 :     end handle _ => sync(myco CO_ResizeReq);
244 :     app destroy dlist;
245 :     main(sz,me')
246 :     end handle e => send(repChan, Error e))
247 :     | handleReq (Insert (index,wl)) =
248 :     ((if isValid(me,index) then
249 :     case topIndex me of
250 :     NONE => let
251 :     val sz' = W.natSize (hd wl)
252 :     val me' = insertW(me,index,map (mkReal sz') wl)
253 :     in
254 :     send(repChan, Okay);
255 :     sync(myco CO_ResizeReq);
256 :     main(sz', me')
257 :     end
258 :     | _ => let
259 :     val me' = insertW(me,index,map (mkReal sz) wl)
260 :     in
261 :     send(repChan, Okay);
262 :     main(sz, me')
263 :     end handle e => send(repChan, Error e)
264 :     else send(repChan, Error BadIndex))
265 :     handle e => send(repChan, Error e))
266 :     | handleReq _ = ()
267 :    
268 :     fun loop () =
269 :     loop(select [
270 :     wrap(reqEvt, handleReq),
271 :     wrap (myci, fn evt => handleCI(me,msgBodyOf evt)),
272 :     wrap (childco, fn (child,cevt) => handleCO(me,child,cevt))
273 :     ])
274 :     in
275 :     loop ()
276 :     end
277 :     in
278 :     main (sz, makeReal (mkReal sz, widgets))
279 :     end
280 :    
281 :     val bounds = bounds (fn widget => W.boundsOf widget)
282 :     fun initLoop me = (
283 :     case (recv reqChan) of
284 :     Visible repc => send(repc, topIndex me)
285 :     | Size repc => send(repc, size me)
286 :     | Bounds => send(sizeChan, bounds me)
287 :     | DoRealize arg => realize arg me
288 :     | MakeVis i => (let
289 :     val (me',_) = makeVis(me,i)
290 :     in
291 :     send(repChan,Okay);
292 :     initLoop me'
293 :     end handle e => send(repChan, Error e))
294 :     | Insert (index,wl) => (let
295 :     val me' = insertW(me,index,wl)
296 :     in
297 :     send(repChan, Okay);
298 :     initLoop me'
299 :     end handle e => send(repChan, Error e))
300 :     | Delete indices => (let
301 :     val (me',_) = deleteW(me, indices)
302 :     in
303 :     send(repChan, Okay);
304 :     initLoop me'
305 :     end handle e => send(repChan, Error e));
306 :     initLoop me
307 :     )
308 :     in
309 :     case widgets of
310 :     [] => spawn (fn () => initLoop Empty)
311 :     | w::_ => spawn (fn () => initLoop (P{top=0,widget=w,wlist=widgets}));
312 :     Pile {
313 :     widget=W.mkWidget {
314 :     root=root,
315 :     args= fn () => {background = NONE},
316 :     boundsOf = (fn () => (send (reqChan, Bounds); recv sizeChan)),
317 :     realize = (fn arg => (send (reqChan, DoRealize arg)))
318 :     },
319 :     repChan = repChan,
320 :     reqChan = reqChan
321 :     }
322 :     end
323 :    
324 :     fun pile (root,view,_) widgets = mkPile root widgets
325 :    
326 :     fun widgetOf (Pile{widget,...}) = widget
327 :     fun visible (Pile{reqChan,...}) = let
328 :     val retc = CML.channel()
329 :     in
330 :     CML.send(reqChan, Visible retc);
331 :     case CML.recv retc of
332 :     NONE => raise NoWidgets
333 :     | SOME i => i
334 :     end
335 :     fun size (Pile{reqChan,...}) = let
336 :     val retc = CML.channel()
337 :     in
338 :     CML.send(reqChan, Size retc);
339 :     CML.recv retc
340 :     end
341 :     local
342 :     fun command wrapfn (Pile{reqChan,repChan,...}) =
343 :     fn arg =>
344 :     (CML.send(reqChan,wrapfn arg);
345 :     case CML.recv repChan of Error e => raise e | Okay => ())
346 :     in
347 :     val mkVisible = command MakeVis
348 :     val insert' = command Insert
349 :     fun insert pile (i,[]) = ()
350 :     | insert pile arg = insert' pile arg
351 :     fun append pile (i,bl) = insert pile (i+1,bl)
352 :     val delete' = command Delete
353 :     fun delete pile [] = ()
354 :     | delete pile arg = delete' pile arg
355 :     end (* local *)
356 :    
357 :     end (* Pile *)
358 :    

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