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/nbody/display.sml
ViewVC logotype

Annotation of /sml/trunk/src/eXene/examples/nbody/display.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 845 - (view) (download)

1 : blume 845 functor AnimateSimFun
2 :     (structure Sim: SIM
3 :     val bodyData: (Sim.vect * Sim.vect * real * int * string option) list) =
4 :     struct
5 :    
6 :     structure V = Sim.V
7 :     structure W = Widget
8 :     structure D = Drawing
9 :     structure G = Geometry
10 :     structure I = Interact
11 :     structure S = Styles
12 :     structure A = Attrs
13 :    
14 :     val contr_size = 12
15 :    
16 :     val G = 6.67e~8
17 :     val dt = (* 500.0 *) 2000.0
18 :     val max = 7.80e13 * 2.1
19 :    
20 :     val N = (* 30 *) 15
21 :    
22 :     fun spacer n = Box.Glue { nat = n, min = n, max = SOME n }
23 :     fun rubber n = Box.Glue { nat = n, min = 1, max = NONE }
24 :    
25 :     val sp5 = spacer 5
26 :    
27 :     fun mkSimDisplay (root, view) = let
28 :    
29 :     fun quit () = let
30 :     fun q () =
31 :     (CML.sync (CML.timeOutEvt (Time.fromMilliseconds 20));
32 :     Root.delRoot root;
33 :     RunCML.shutdown OS.Process.success)
34 :     in
35 :     CML.spawn q; ()
36 :     end
37 :    
38 :     val scr = W.screenOf root
39 :     val display = W.displayOf root
40 :     val black = W.EXB.blackOfScr scr
41 :     val white = W.EXB.whiteOfScr scr
42 :     val colorByName = (W.EXB.colorOfScr scr) o W.EXB.CMS_Name
43 :    
44 :     local
45 :     val recalCh = CML.channel ()
46 :     in
47 :     val recalEvt = CML.recvEvt recalCh
48 :     fun recal () = CML.send (recalCh, ())
49 :     end
50 :    
51 :     val s_args = [(A.attr_isVertical, A.AV_Bool false),
52 :     (A.attr_background, A.AV_Str "gray"),
53 :     (A.attr_width, A.AV_Int contr_size),
54 :     (A.attr_fromValue, A.AV_Int 0),
55 :     (A.attr_toValue, A.AV_Int 100)]
56 :     val q_args = [(A.attr_label, A.AV_Str "Q")]
57 :     val r_args = [(A.attr_label, A.AV_Str "R")]
58 :     val slider = Slider.slider (root, view, s_args)
59 :     fun centerSlider () = Slider.setValue slider 50
60 :     val (qbuttonW, rbuttonW) = let
61 :     val s = 2 * contr_size
62 :     val qb = Button.textCmd (root, view, q_args) quit
63 :     val rb = Button.textCmd (root, view, r_args) recal
64 :     in
65 :     (Shape.fixSize (Button.widgetOf qb, G.SIZE { wid = s, ht = s }),
66 :     Shape.fixSize (Button.widgetOf rb, G.SIZE { wid = s, ht = s }))
67 :     end
68 :     val controls_line = Box.HzCenter
69 :     [sp5, Box.WBox rbuttonW,
70 :     sp5, Box.WBox (Slider.widgetOf slider),
71 :     sp5, Box.WBox qbuttonW, sp5]
72 :    
73 :     local
74 :     val sliderEvt = Slider.evtOf slider
75 :     val zoomCh = CML.channel ()
76 :     in
77 :     val zoomEvt = CML.recvEvt zoomCh
78 :     fun sliderThread base = let
79 :     fun loop (base, cur) =
80 :     CML.select
81 :     [CML.wrap (sliderEvt,
82 :     fn sp => handleSlider (base, sp)),
83 :     CML.wrap (recalEvt, fn () => handleRecal cur)]
84 :     and handleSlider (base, sp) = let
85 :     val fact = Math.pow (2.0, Real.fromInt (sp - 50) / 50.0)
86 :     val cur = base * fact
87 :     in
88 :     CML.send (zoomCh, cur);
89 :     loop (base, cur)
90 :     end
91 :     and handleRecal cur = (centerSlider (); loop (cur, cur))
92 :     in
93 :     centerSlider ();
94 :     loop (base, base)
95 :     end
96 :     end
97 :    
98 :     val drawPen = D.newPen [D.PV_Foreground white]
99 :     val erasePen = D.newPen [D.PV_Foreground black]
100 :     val timer = CML.timeOutEvt (Time.fromMilliseconds 20)
101 :    
102 :     fun mkBody (p, v, m, r, cs) = let
103 :     val color = getOpt (Option.map colorByName cs, white)
104 :     val pen = D.newPen [D.PV_Foreground color]
105 :     in
106 :     { p = p, v = v, m = m, data = { pen = pen, radius = r }}
107 :     end
108 :     val bodies = map mkBody bodyData
109 :    
110 :     val reqCh = CML.channel ()
111 :     val simT =
112 :     Sim.run { G = G, bodies = bodies, dt = dt, msgchan = reqCh, n = N }
113 :     val simDeathEvt = CML.joinEvt simT
114 :    
115 :     fun realize { win, sz = G.SIZE { wid, ht }, env } = let
116 :    
117 :     val depth = W.EXB.depthOfWin win
118 :     val drawwin = D.drawableOfWin win
119 :     val drawwin = D.feedback drawwin
120 :     val drawCircle = D.fillCircle drawwin
121 :     val I.InEnv { ci, m, ... } = I.ignoreKey env
122 :    
123 :     datatype panCmd = PAN of { horiz: int, vert: int }
124 :    
125 :     val panCh = CML.channel ()
126 :     val panEvt = CML.recvEvt panCh
127 :    
128 :     fun mouseThread () = let
129 :     fun idle () =
130 :     case I.msgBodyOf (CML.sync m) of
131 :     I.MOUSE_FirstDown { but = I.MButton 1, pt, ... } =>
132 :     pan pt
133 :     | I.MOUSE_FirstDown { but = I.MButton 3, ... } =>
134 :     (quit (); idle ())
135 :     | _ => idle ()
136 :    
137 :     and pan (pt' as G.PT { x = x', y = y' }) =
138 :     case I.msgBodyOf (CML.sync m) of
139 :     I.MOUSE_Motion { pt = pt as G.PT { x, y }, ... } =>
140 :     (CML.send (panCh,
141 :     PAN { horiz = x - x', vert = y - y' });
142 :     pan pt)
143 :     | I.MOUSE_Up { but = I.MButton 1, ... } => idle ()
144 :     | I.MOUSE_LastUp _ => idle ()
145 :     | _ => pan pt'
146 :     in
147 :     idle ()
148 :     end
149 :    
150 :     fun newTranslation { ocl, wid, ht, WZx, WZy, zoom } = let
151 :    
152 :     fun winCircle { p, v, m, data = { pen, radius } } = let
153 :     val { x, y } = V.proj2d p
154 :     val scrx = Real.round ((x - WZx) * zoom) handle _ => 0
155 :     val scry = Real.round ((y - WZy) * zoom) handle _ => 0
156 :     in
157 :     { center = G.PT { x = scrx, y = scry }, rad = radius }
158 :     end
159 :    
160 :     fun drawBody (new as { data = { pen, ... }, ... }) = let
161 :     val nc = winCircle new
162 :     in
163 :     drawCircle pen nc; nc
164 :     end
165 :    
166 :     fun moveBody (oc, new) =
167 :     (drawCircle erasePen oc; drawBody new)
168 :    
169 :     fun update ol = let
170 :     val ch = CML.channel ()
171 :     val _ = CML.send (reqCh, Sim.QUERY ch)
172 :     val nl = CML.recv ch
173 :     in
174 :     SOME (case ol of
175 :     SOME ol => ListPair.map moveBody (ol, nl)
176 :     | NONE => List.map drawBody nl)
177 :     end
178 :    
179 :     fun death cl = (print "Simulation has died!\n"; quit ();
180 :     loop cl)
181 :    
182 :     and loop cl = CML.select
183 :     [CML.wrap (simDeathEvt, fn () => death cl),
184 :     CML.wrap (timer, fn () => (loop (update cl))),
185 :     CML.wrap (ci, fn x => handleCI (cl, I.msgBodyOf x)),
186 :     CML.wrap (panEvt, fn p => handlePan (cl, p)),
187 :     CML.wrap (zoomEvt, fn z => handleZoom (cl, z))]
188 :    
189 :     and handleCI (cl, I.CI_Resize (G.RECT r)) =
190 :     let
191 :     val { wid = nw, ht = nh, ... } = r
192 :     val f = 0.5 / zoom
193 :     in
194 :     D.clearDrawable drawwin;
195 :     newTranslation
196 :     { ocl = cl, wid = nw, ht = nh,
197 :     WZx = WZx - Real.fromInt (nw - wid) * f,
198 :     WZy = WZy - Real.fromInt (nh - ht) * f,
199 :     zoom = zoom }
200 :     end
201 :     | handleCI (cl, _) = loop cl
202 :    
203 :     and handlePan (cl, PAN { horiz, vert }) =
204 :     newTranslation
205 :     { ocl = cl, wid = wid, ht = ht, zoom = zoom,
206 :     WZx = WZx - Real.fromInt horiz / zoom,
207 :     WZy = WZy - Real.fromInt vert / zoom }
208 :    
209 :     and handleZoom (cl, z) = let
210 :     val f = 0.5 * (1.0 / zoom - 1.0 / z)
211 :     in
212 :     newTranslation
213 :     { ocl = cl, wid = wid, ht = ht, zoom = z,
214 :     WZx = WZx + Real.fromInt wid * f,
215 :     WZy = WZy + Real.fromInt ht * f }
216 :     end
217 :     in
218 :     loop ocl
219 :     end
220 :    
221 :     fun threadBody () = let
222 :     val zoom = Real.fromInt wid / max
223 :     val f = ~0.5 / zoom;
224 :     val WZx = Real.fromInt wid * f
225 :     val WZy = Real.fromInt ht * f
226 :     in
227 :     CML.spawn (fn () => sliderThread zoom);
228 :     newTranslation { ocl = NONE,
229 :     wid = wid, ht = ht,
230 :     WZx = WZx, WZy = WZy, zoom = zoom }
231 :     end
232 :     (* val gcTimeOut = CML.timeOutEvt (Time.fromSeconds 10)
233 :     fun gcThread () =
234 :     (CML.sync gcTimeOut; SMLofNJ.Internals.GC.doGC 5; gcThread ())
235 :     *)
236 :     in
237 :     (* CML.spawn gcThread; *)
238 :     CML.spawn mouseThread;
239 :     CML.spawn threadBody;
240 :     ()
241 :     end
242 :     val size = W.fixBounds (500, 500)
243 :     val dispW =
244 :     Shape.mkFlex (W.mkWidget
245 :     { boundsOf = fn () => size,
246 :     args = fn () => { background = SOME black },
247 :     root = root,
248 :     realize = realize })
249 :     in
250 :     Box.widgetOf (Box.mkLayout root (Box.VtCenter
251 :     [sp5, controls_line, sp5, Box.WBox dispW, sp5]))
252 :     end
253 :    
254 :     fun simdisplay root = let
255 :     val style = W.styleFromStrings (root, [])
256 :     val name = S.mkView { name = S.styleName [],
257 :     aliases = [S.styleName []] }
258 :     val view = (name,style)
259 :     val sd = mkSimDisplay (root, view)
260 :     val args = [(A.attr_title, A.AV_Str "N-Body"),
261 :     (A.attr_iconName, A.AV_Str "n-body")]
262 :     val shell = Shell.shell (root, view, args) sd
263 :     in
264 :     Shell.init shell
265 :     end
266 :    
267 :     fun doit' (debugFlags, server) =
268 :     (XDebug.init debugFlags;
269 :     RunEXene.runWArgs simdisplay { dpy = SOME server, timeq = SOME 20 })
270 :    
271 :     fun doit () = RunEXene.run simdisplay
272 :    
273 :     fun main (_: string, prog :: server :: _) = doit' ([], server)
274 :     | main _ = doit ()
275 :    
276 :     val main = (fn () => OS.Process.success) o main
277 :     end

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