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/examples/triangle/tri.sml
ViewVC logotype

Annotation of /sml/trunk/src/eXene/examples/triangle/tri.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2 - (view) (download)

1 : monnier 2 (* tri.sml
2 :     *
3 :     * COPYRIGHT (c) 1992 by AT&T Bell Laboratories. See COPYRIGHT file for details.
4 :     *)
5 :    
6 :     structure Main : sig
7 :    
8 :     val doit' : string list * string -> unit
9 :     val doit : string -> unit
10 :     val main : (string * string list) -> OS.Process.status
11 :    
12 :     end = struct
13 :    
14 :     open CML Geometry EXeneBase
15 :     structure I = Interact
16 :     structure D = Drawing
17 :    
18 :     val minWid = 300 and minHt = 300
19 :     val minSz = SIZE{wid = minWid, ht = minHt}
20 :    
21 :     val buttonWid = 100 and buttonHt = 30
22 :     val buttonCornerRad = 8
23 :     fun buttonWinGeom (wid, ht) = WGEOM{
24 :     pos = PT{x = (wid - buttonWid) div 2, y = ht-(buttonHt+10)},
25 :     sz = SIZE{wid=buttonWid, ht=buttonHt},
26 :     border = 0
27 :     }
28 :    
29 :     fun drawWinGeom (wid, ht) = WGEOM{
30 :     pos = PT{x = 5, y = 5},
31 :     sz = SIZE{wid = wid - 10, ht = ht - (buttonHt+25)},
32 :     border = 1
33 :     }
34 :    
35 :     fun init dpyName = let
36 :     val dpy = openDisplay (dpyName,NONE)
37 :     val scr = defaultScreenOf dpy
38 :     val winSz = SIZE{wid = 450, ht = 400}
39 :     val (win, inEnv) =
40 :     EXeneWin.createSimpleTopWin scr {
41 :     geom = WGEOM{pos=PT{x=0, y=0}, sz=winSz, border=1},
42 :     border = blackOfScr scr,
43 :     backgrnd = whiteOfScr scr
44 :     }
45 :     val iconTile = createTileFromImage scr IconBitmap.icon_bitmap
46 :     in
47 :     EXeneWin.setWMProperties win {
48 :     argv = SMLofNJ.getArgs(),
49 :     win_name = SOME "Triangle",
50 :     icon_name = SOME "triangle",
51 :     size_hints = [
52 :     ICCC.HINT_PPosition,
53 :     ICCC.HINT_PSize,
54 :     ICCC.HINT_PMinSize minSz
55 :     ],
56 :     wm_hints = [ICCC.HINT_IconTile iconTile],
57 :     class_hints = SOME{res_name="triangle", res_class="Triangle"}
58 :     };
59 :     EXeneWin.mapWin win;
60 :     (scr, win, inEnv)
61 :     end
62 :    
63 :     fun allocWindows dpy = let
64 :     val (scr, topWin, topEnv) = init dpy
65 :     val (SIZE{wid, ht}) = sizeOfWin topWin
66 :     val drawWin = EXeneWin.createSimpleSubwin topWin {
67 :     geom = drawWinGeom(wid, ht),
68 :     border = SOME(blackOfScr scr),
69 :     backgrnd = SOME(whiteOfScr scr)
70 :     }
71 :     val buttonWin = EXeneWin.createSimpleSubwin topWin {
72 :     geom = buttonWinGeom(wid, ht),
73 :     border = NONE,
74 :     backgrnd = SOME(whiteOfScr scr)
75 :     }
76 :     in
77 :     EXeneWin.mapWin drawWin;
78 :     EXeneWin.mapWin buttonWin;
79 :     {top_win=topWin, top_env=topEnv, draw_win=drawWin, but_win=buttonWin}
80 :     end
81 :    
82 :     fun mkButtonThreads (win, env) = let
83 :     val I.InEnv{m, ci, ...} = I.ignoreKey env
84 :     val mouseEvt = wrap (m, I.msgBodyOf)
85 :     val cmdEvt = wrap (ci, I.msgBodyOf)
86 :     val drawable = D.drawableOfWin win
87 :     val pen = D.newPen[
88 :     D.PV_Function D.OP_Copy,
89 :     D.PV_Foreground(blackOfScr(EXeneWin.screenOfWin win))
90 :     ]
91 :     val drawRect = RoundedRect.drawRoundedRect drawable pen
92 :     val text = "RESET"
93 :     val font = Font.openFont (EXeneWin.displayOfWin win) "9x15"
94 :     val textPt = let
95 :     val textWidth = Font.textWidth font text
96 :     val {ascent, descent} = Font.fontHt font
97 :     in
98 :     PT{
99 :     x = (buttonWid - textWidth) div 2,
100 :     y = ((buttonHt - (ascent + descent)) div 2) + ascent
101 :     }
102 :     end
103 :     val drawText = D.drawString drawable pen font
104 :     fun redraw () = (
105 :     drawRect {
106 :     rect = RECT{x = 0, y = 0, ht = buttonHt-1, wid = buttonWid-1},
107 :     c_wid = buttonCornerRad,
108 :     c_ht = buttonCornerRad
109 :     };
110 :     drawText (textPt, text))
111 :     val resetCh = channel()
112 :     fun loop () = let
113 :     fun mouseFn (I.MOUSE_FirstDown _) = send(resetCh, ())
114 :     | mouseFn _ = ()
115 :     fun cmdFn (I.CI_Redraw _) = redraw()
116 :     | cmdFn I.CI_OwnDeath = ()
117 :     | cmdFn _ = ()
118 :     in
119 :     select [
120 :     wrap (mouseEvt, mouseFn),
121 :     wrap (cmdEvt, cmdFn)
122 :     ];
123 :     loop ()
124 :     end
125 :     in
126 :     spawn loop;
127 :     recvEvt resetCh
128 :     end (* mkButtonThreads *)
129 :    
130 :     fun mkDrawThreads (win, resetEvt, env) = let
131 :     val I.InEnv{m, ci, ...} = I.ignoreKey env
132 :     val mouseEvt = wrap (m, I.msgBodyOf)
133 :     val cmdEvt = wrap (ci, I.msgBodyOf)
134 :     val drawCh = channel()
135 :     fun mouseThread () = (case (sync mouseEvt)
136 :     of I.MOUSE_FirstDown{pt, ...} => send(drawCh, pt)
137 :     | _ => ()
138 :     (* end case *);
139 :     mouseThread())
140 :     val drawEvt = recvEvt drawCh
141 :     val drawable = D.drawableOfWin win
142 :     val pen = D.newPen [
143 :     D.PV_Function D.OP_Copy,
144 :     D.PV_Foreground(blackOfScr(EXeneWin.screenOfWin win))
145 :     ]
146 :     val draw = D.fillPolygon drawable pen
147 :     fun drawTriangle (PT{x, y}) = draw {
148 :     verts = [PT{x=x, y=y-10}, PT{x=x-8, y=y+6}, PT{x=x+8, y=y+6}],
149 :     shape = D.ConvexShape
150 :     }
151 :     fun loop state = let
152 :     fun reset () = (D.clearDrawable drawable; loop[])
153 :     fun handleCmd (I.CI_Redraw _) = (
154 :     D.clearDrawable drawable;
155 :     app drawTriangle state;
156 :     loop state)
157 :     | handleCmd I.CI_OwnDeath = ()
158 :     | handleCmd _ = (loop state)
159 :     fun draw pt = (drawTriangle pt; loop(pt::state))
160 :     in
161 :     select [
162 :     wrap (resetEvt, reset),
163 :     wrap (cmdEvt, handleCmd),
164 :     wrap (drawEvt, draw)
165 :     ]
166 :     end
167 :     in
168 :     spawn mouseThread;
169 :     spawn (fn () => loop []);
170 :     ()
171 :     end (* mkDrawThreads *)
172 :    
173 :     fun mkTopLevelThreads {top_win, top_env=I.InEnv{k, m, ci, ...}, but_win, draw_win} = let
174 :     val (butInEnv, butOutEnv) = I.createWinEnv()
175 :     val (drawInEnv, drawOutEnv) = I.createWinEnv()
176 :     val (inEnv, outEnv) = I.createWinEnv()
177 :     val inEnv = I.ignoreAll inEnv
178 :     fun findEnv msg = (case (I.stripMsg msg)
179 :     of (I.Here _) => outEnv
180 :     | (I.ToChild msg') => (
181 :     if (I.toWindow(msg', draw_win))
182 :     then drawOutEnv
183 :     else if (I.toWindow(msg', but_win))
184 :     then butOutEnv
185 :     else raise (Fail "findEnv"))
186 :     (* end case *))
187 :     val kbdEvt = (wrap(k, fn msg => let
188 :     val I.OutEnv{k, ...} = findEnv msg
189 :     in
190 :     sync (k msg)
191 :     end))
192 :     val mouseEvt = (wrap(m, fn msg => let
193 :     val I.OutEnv{m, ...} = findEnv msg
194 :     in
195 :     sync (m msg)
196 :     end))
197 :     val cmdEvt = (wrap(ci, fn msg => let
198 :     val I.OutEnv{ci, ...} = findEnv msg
199 :     in
200 :     sync (ci msg)
201 :     end))
202 :     fun router () = (
203 :     select [kbdEvt, mouseEvt, cmdEvt];
204 :     router())
205 :     in
206 :     spawn router;
207 :     {but_env = butInEnv, draw_env = drawInEnv}
208 :     end
209 :    
210 :     fun triangle dpy = let
211 :     open CML Interact
212 :     val (x as {but_win, draw_win, ...}) = allocWindows dpy
213 :     val {but_env, draw_env} = mkTopLevelThreads x
214 :     in
215 :     mkDrawThreads (draw_win, mkButtonThreads (but_win, but_env), draw_env)
216 :     end
217 :    
218 :     fun doit' (flgs, dpy) = (
219 :     XDebug.init flgs;
220 :     RunCML.doit (
221 :     fn () => (XDebug.xspawn("triangle", fn () => triangle dpy); ()),
222 :     SOME(Time.fromMilliseconds 20)))
223 :     fun doit s = doit' ([],s)
224 :    
225 :     fun main (prog, server::_) = (doit server; OS.Process.success)
226 :     | main _ = (doit ""; OS.Process.success)
227 :    
228 :     end (* Main *)
229 :    

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