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/button-ctrl.sml
ViewVC logotype

Annotation of /sml/trunk/src/eXene/widgets/simple/button-ctrl.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1911 - (view) (download)

1 : monnier 2 (* button-ctrl.sml
2 :     *
3 :     * COPYRIGHT (c) 1994 by AT&T Bell Laboratories. See COPYRIGHT file for details.
4 :     *
5 :     * Protocol for buttons.
6 :     *
7 :     * TODO: Allow disabling of highlighting
8 :     *)
9 :    
10 :     signature BUTTON_CTRL =
11 :     sig
12 :    
13 :     structure W : WIDGET
14 :    
15 :     val button : (W.root * W.view * W.arg list) -> ButtonType.button
16 :    
17 :     val commandBtn : (W.root * W.view * W.arg list) ->
18 :     (unit -> unit) -> ButtonType.button
19 :    
20 :     end (* BUTTON_CTRL *)
21 :    
22 :     functor ButtonCtrl (BV : BUTTON_VIEW) : BUTTON_CTRL =
23 :     struct
24 :    
25 :     structure W = Widget
26 :     structure BT = ButtonType
27 :    
28 :     open CML Geometry ButtonBase
29 :    
30 :     val attrs = [
31 :     (Attrs.attr_repeatDelay, Attrs.AT_Int, Attrs.AV_NoValue),
32 :     (Attrs.attr_repeatInterval, Attrs.AT_Int, Attrs.AV_Int 100),
33 :     (Attrs.attr_isActive, Attrs.AT_Bool, Attrs.AV_Bool true),
34 :     (Attrs.attr_isSet, Attrs.AT_Bool, Attrs.AV_Bool false)
35 :     ]
36 :    
37 :     fun timerP (bttn, outch, inch, delay, interval) () = let
38 :     fun signal () =
39 :     select[
40 :     wrap(sendEvt(outch,BT.BtnDown bttn), fn () => wait(timeOutEvt interval)),
41 :     wrap(recvEvt inch, exit)
42 :     ]
43 :     and wait (timeEvt) =
44 :     select[
45 :     wrap(timeEvt, signal),
46 :     wrap(recvEvt inch, exit)
47 :     ]
48 :     in wait(timeOutEvt delay) end
49 :    
50 : mblume 1911 fun realize {env=inenv, win, sz} (state,(quanta,reqc,
51 :     (* next line type added ddeboer: *)
52 :     evtc: ButtonType.button_act CML.chan,
53 :     bv)) = let
54 : monnier 2 open Interact
55 :     val InEnv{m,ci,...} = ignoreKey inenv
56 :     val mchan = channel ()
57 :     val timec = channel ()
58 :     val rcvm = recvEvt mchan
59 :     val drawf = BV.config(bv,win,sz)
60 :     val q = (case quanta of
61 :     NONE => NONE
62 :     | SOME(d,i) => SOME(d,i,channel()))
63 :    
64 :     fun handleReq (GetActive v,state) =
65 :     (SyncVar.iPut (v, getActive state); state)
66 :     | handleReq (SetActive arg,state) = setActive (arg,state)
67 :     | handleReq (GetBounds arg,state) =
68 :     (SyncVar.iPut(arg,BV.bounds bv); state)
69 :     | handleReq (GetArgs arg,state) =
70 :     (SyncVar.iPut(arg,BV.win_args bv); state)
71 :     | handleReq (_,state) = state
72 :    
73 :     fun handleCI (CI_Redraw _, me as (state,drawf)) =
74 :     (drawf state; me)
75 :     | handleCI (CI_Resize (RECT{wid,ht,...}), (state,_)) =
76 :     (state, BV.config (bv,win,SIZE{wid=wid,ht=ht}))
77 :     | handleCI (_,me) = me
78 :    
79 :     fun handleM (MseIn v,me as ((s,r,false),drawf)) =
80 :     if v = r then me
81 :     else let
82 :     val state' = (s,v,false)
83 :     in
84 :     drawf state';
85 :     send(evtc,if v then BT.BtnReady else BT.BtnNormal);
86 :     (state',drawf)
87 :     end
88 :     | handleM (MseIn v,((s,r,true),drawf)) = let
89 :     val state' = (s,v,true)
90 :     in
91 :     drawf state';
92 :     (state',drawf)
93 :     end
94 :     | handleM (MseDown bttn,((s,r,isdown),drawf)) = let
95 :     val state' = (s,true,true)
96 :     in
97 :     drawf state';
98 :     send(evtc,BT.BtnDown bttn);
99 :     case q of
100 :     NONE => ()
101 :     | SOME(d,i,tc) =>
102 :     (spawn(timerP(bttn,timec,tc,d,i)); ());
103 :     (state',drawf)
104 :     end
105 :     | handleM (MseUp bttn,((s,isin,isdown),drawf)) = let
106 :     val state' = (s,isin,false)
107 :     in
108 :     drawf state';
109 :     send(evtc,if isin then BT.BtnUp bttn else BT.BtnNormal);
110 :     case q of
111 :     NONE => ()
112 :     | SOME(_,_,tc) => send(tc,());
113 :     (state',drawf)
114 :     end
115 :    
116 :     fun activeCmdP (me as (state,drawf)) =
117 :     select [
118 :     wrap(recvEvt reqc, fn evt => let
119 :     val state' = handleReq (evt,state)
120 :     in
121 :     if state' = state then activeCmdP me
122 :     else (
123 :     drawf state';
124 :     if #2 state' orelse #3 state' then send(evtc,BT.BtnNormal) else ();
125 :     inactiveCmdP (state',drawf)
126 :     )
127 :     end),
128 :     wrap(rcvm, fn m => activeCmdP(handleM(m,me))),
129 :     wrap(recvEvt timec, fn m => (send(evtc,m);activeCmdP me)),
130 :     wrap(ci, fn evt => activeCmdP(handleCI (msgBodyOf evt,me)))
131 :     ]
132 :    
133 :     and inactiveCmdP (me as (state,drawf)) =
134 :     select [
135 :     wrap(recvEvt reqc, fn evt => let
136 :     val state' = handleReq (evt,state)
137 :     in
138 :     if state' = state then inactiveCmdP me
139 :     else (
140 :     drawf state';
141 :     if #2 state' then send(evtc,BT.BtnReady) else ();
142 :     activeCmdP (state',drawf)
143 :     )
144 :     end),
145 :     wrap(rcvm, fn (MseIn v) => inactiveCmdP ((#1 state,v,#3 state),drawf)
146 :     | _ => inactiveCmdP me),
147 :     wrap(ci, fn evt => inactiveCmdP(handleCI (msgBodyOf evt,me)))
148 :     ]
149 :     in
150 :     spawn (fn () => mseP(m,mchan));
151 :     if getActive state then activeCmdP(state,drawf)
152 :     else inactiveCmdP(state,drawf)
153 :     end
154 :    
155 :     fun init (env as (quanta,reqc,evtc,bv)) state = let
156 :     fun loop state =
157 :     case recv reqc of
158 :     GetActive v => (SyncVar.iPut (v, getActive state); loop state)
159 :     | SetActive arg => loop (setActive (arg,state))
160 :     | DoRealize arg => realize arg (state,env)
161 :     | GetBounds arg => (SyncVar.iPut(arg,BV.bounds bv); loop state)
162 :     | GetArgs arg => (SyncVar.iPut(arg,BV.win_args bv); loop state)
163 :     | _ => loop state
164 :     in loop state end
165 :    
166 :     fun button (root,view,args) = let
167 :     open Attrs
168 :     val attrs = W.findAttr(W.attrs(view,attrs,args))
169 :     val evtc = channel ()
170 :     val reqc = channel ()
171 :     val quanta = (case getIntOpt(attrs attr_repeatDelay)
172 : mblume 1911 of NONE => NONE
173 :     | SOME d => let
174 : monnier 2 val i = getInt(attrs attr_repeatInterval)
175 : mblume 1911 val millisecs = Time.fromMilliseconds o Int.toLarge
176 : monnier 2 in
177 : mblume 1911 SOME(millisecs d, millisecs i)
178 :     end
179 :     (* end case *))
180 : monnier 2 val state = mkWState(getBool(attrs attr_isActive),
181 :     getBool(attrs attr_isSet))
182 :     val bv = BV.buttonView (root,view,args)
183 :     fun getval msg () = let
184 :     val v = SyncVar.iVar ()
185 :     in send (reqc,msg v); SyncVar.iGet v end
186 :     in
187 :     spawn (fn () => init (quanta,reqc,evtc,bv) (state,false,false));
188 :     BT.Button {
189 :     widget = Widget.mkWidget{
190 :     root=root,
191 :     args = getval GetArgs,
192 :     boundsOf = getval GetBounds,
193 :     realize = fn arg => send(reqc,DoRealize arg)
194 :     },
195 :     rqst = reqc,
196 : mblume 1911 (* modified by ddeboer; original: *)
197 :     (* evt = recvEvt evtc *)
198 :     evt = (WidgetBase.wrapQueue (recvEvt evtc))
199 : monnier 2 }
200 :     end
201 :    
202 :     fun commandBtn args action = let
203 :     val BT.Button{widget,rqst,evt} = button args
204 :     fun listener () =
205 :     listener (case sync evt of
206 :     BT.BtnUp btn => action ()
207 :     | _ => ()
208 :     )
209 :     in
210 :     spawn listener;
211 :     BT.Button {
212 :     widget = widget,
213 :     rqst = rqst,
214 :     evt = SyncVar.iGetEvt(SyncVar.iVar())
215 :     }
216 :     end
217 :    
218 :     end (* ButtonCtrl *)

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