Home My Page Projects Code Snippets Project Openings 3D graphics for Standard ML
Summary Activity SCM

SCM Repository

[sml3d] Diff of /trunk/sml3d/src/particles/compiler/translate.sml
ViewVC logotype

Diff of /trunk/sml3d/src/particles/compiler/translate.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 873, Wed May 5 20:18:00 2010 UTC revision 1160, Sun May 22 21:55:20 2011 UTC
# Line 1  Line 1 
1  (* translate.sml  (* translate.sml
2   *  
3   * COPYRIGHT (c) 2009 John Reppy (http://cs.uchicago.edu/~jhr)   * COPYRIGHT (c) 2009 John Reppy (http://cs.uchicago.edu/~jhr)
4   * All rights reserved.   * All rights reserved.
5   *   *
# Line 8  Line 8 
8    
9  structure Translate : sig  structure Translate : sig
10    
11      val compile : Particles.particle_group -> PSysIR.program      val compile : Particles.program -> PSysIR.program
12    
13    end = struct    end = struct
14    
# Line 20  Line 20 
20    
21      fun printErr s = TextIO.output(TextIO.stdErr, s ^ "\n")      fun printErr s = TextIO.output(TextIO.stdErr, s ^ "\n")
22    
     datatype particle_state = PS of {  
         pos : IR.var,           (* vec3 *)  
         vel : IR.var,           (* vec3 *)  
         size : IR.var,          (* float *)  
         isDead : IR.var,        (* bool *)  
         color : IR.var,         (* vec3 (NOTE: should be vector4) *)  
         dummy : IR.var  
       }  
   
23    (* special PSV global variables *)    (* special PSV global variables *)
     val timeStep = PSV.new("g_timeStep", PSV.T_FLOAT)   (* physics timestep *)  
     val numDead = PSV.new("g_numDead", PSV.T_INT)       (* # of dead particles *)  
24      val epsilon = PSV.constf(0.00001)      val epsilon = PSV.constf(0.00001)
25    
26    (* constants *)    (* constants *)
27      val pi = 3.14159265358979      val pi = 3.14159265358979
28    
29    (* dummy placeholder *)    (* translation environment *)
30      fun dummy (state, k) =      datatype ir_env = TE of (IR.block list ref * IR.var PSV.Map.map * IR.var PSV.SVMap.map)
31            IR.mkPRIM(      fun insertVar (TE(blks, v_env, sv_env), x, x') = TE(blks, PSV.Map.insert (v_env, x, x'), sv_env)
32              IR.newLocal(      fun insertSVar (TE(blks, v_env, sv_env), x, x') = (case (PSV.SVMap.find (sv_env, x))
33                "temp",          of NONE => raise Fail("Changing mapping to state var that doesn't exist.")
34                IR.T_BOOL,           | SOME var => (
35                (IR.COPY, [IR.newConst("c", IR.C_BOOL false)])             IR.setRenderVar(x', IR.isRenderVar var);
36              ),             TE(blks, v_env, PSV.SVMap.insert (sv_env, x, x'))
             IR.COPY,  
             [IR.newConst("c", IR.C_BOOL false)],  
             k state  
37            )            )
38          (* end case *))
39    
40        fun retState (TE(_, _, sv_env)) = IR.mkRETURN (PSV.SVMap.listItems sv_env)
41    
42      fun retState s = let    (* Interaction with environment and psys variables *)
43        val PS{pos, vel, size, isDead, color, dummy} = s      fun psvToIRVar (TE(_, env, _), x as PSV.V{name, id, ...}) = (case PSV.Map.find(env, x)
      in  
       IR.mkRETURN [pos, vel, size, isDead, color, dummy]  
      end  
   
   (* translation environment *)  
     datatype env = TE of (IR.block list ref * IR.var PSV.Map.map)  
   
     fun psvToIRVar (TE(_, env), x as PSV.V{name, id, ...}) = (case PSV.Map.find(env, x)  
44             of SOME x' => x'             of SOME x' => x'
45              | NONE => raise Fail (String.concat["unknown variable ", name, " with ID ", Int.toString id])              | NONE => raise Fail (String.concat["unknown variable ", name, " with ID ", Int.toString id])
46            (* end case *))            (* end case *))
47    
48      fun insert (TE(blks, env), x, x') = TE(blks, PSV.Map.insert (env, x, x'))      fun pssvToIRVar (TE(_, _, env), x as PSV.SV{name, id, ...}) = (case PSV.SVMap.find(env, x)
49               of SOME x' => x'
50                | NONE => raise Fail (String.concat["unknown state variable ", name, " with ID ", Int.toString id])
51                (* end case *))
52    
53    (* create a block that implements the given continuation *)    (* create a block that implements the given continuation *)
54      fun newBlock (TE(blks, _), k : particle_state -> IR.stmt) = let      fun newBlockWithArgs (env as TE(blks, _, sv_env), args, k : ir_env -> IR.stmt) = let
55            val pos = IR.newParam ("ps_pos", IR.T_VEC)         fun copyVar(v as IR.V{name, varType, ...}) = IR.newParam(name, varType)
56            val vel = IR.newParam ("ps_vel", IR.T_VEC)         val newState = List.map copyVar (PSV.SVMap.listItems sv_env)
57            val size = IR.newParam ("ps_size", IR.T_FLOAT)         fun inssv((oldv, newv), TE(theBlks, v_env, svenv)) = let
58            val isDead = IR.newParam ("ps_isDead", IR.T_BOOL)           val theKey =
59            val color = IR.newParam ("ps_color", IR.T_VEC)             List.find
60            val dummy = IR.newParam ("ps_dummy", IR.T_FLOAT)              (fn v => IR.varEq(PSV.SVMap.lookup(svenv, v), oldv))
61            val state = PS{pos=pos, vel=vel, size=size, isDead=isDead, color=color, dummy=dummy}              (PSV.SVMap.listKeys svenv)
62            val blk = IR.newBlock ([pos, vel, size, isDead, color, dummy], k state)           val sv = (case theKey
63               of SOME x => x
64                | NONE => raise Fail("Trying to create new mapping for variable that doesn't already exist.")
65             (* end case *))
66            in            in
67              blks := blk :: !blks;           IR.setRenderVar(newv, IR.isRenderVar oldv);
68              blk           TE(theBlks, v_env, PSV.SVMap.insert(svenv, sv, newv))
69            end            end
70    
71          fun newBlockWithArgs (TE(blks, _), args, k : particle_state -> IR.stmt) = let             val blk = IR.newBlock (
72            val pos = IR.newParam ("ps_pos", IR.T_VEC)                 newState @ args,
73            val vel = IR.newParam ("ps_vel", IR.T_VEC)                 k (List.foldl inssv env
74            val size = IR.newParam ("ps_size", IR.T_FLOAT)                     (ListPair.zipEq
75            val isDead = IR.newParam ("ps_isDead", IR.T_BOOL)                         (PSV.SVMap.listItems sv_env, newState)
76            val color = IR.newParam ("ps_color", IR.T_VEC)                     )
77            val dummy = IR.newParam ("ps_dummy", IR.T_FLOAT)                 )
78            val state = PS{pos=pos, vel=vel, size=size, isDead=isDead, color=color, dummy = dummy}              )
           val blk = IR.newBlock ([pos, vel, size, isDead, color, dummy] @ args, k state)  
79            in            in
80              blks := blk :: !blks;              blks := blk :: !blks;
81              blk              blk
82            end            end
83    
84      fun goto (PS{pos, vel, size, isDead, color, dummy}, blk) =          fun newBlock (env, k) = newBlockWithArgs(env, [], k)
           IR.mkGOTO(blk, [pos, vel, size, isDead, color, dummy])  
   
         fun gotoWithArgs(PS{pos, vel, size, isDead, color, dummy}, args, blk) =  
           IR.mkGOTO(blk, [pos, vel, size, isDead, color, dummy] @ args)  
85    
86      fun letPRIM (x, ty, p, args, body) = let      fun letPRIM (x, ty, p, args, body) = let
87            val x' = IR.newLocal(x, ty, (p, args))            val x' = IR.newLocal(x, ty, (p, args))
# Line 108  Line 89 
89              IR.mkPRIM(x', p, args, body x')              IR.mkPRIM(x', p, args, body x')
90            end            end
91    
92    (* prim bound to state variable (S_LOCAL for now) *)     fun gotoWithArgs(TE(_, _, env), args, blk) = let
93      fun letSPRIM(x, ty, p, args, body) = let  
94            val x' = IR.new(x, IR.S_LOCAL(ref (p, args)), ty)       fun copyVar(v as IR.V{name, varType, ...}) = IR.newLocal(name^"_copy", varType, (IR.RAND, []))
95    
96         fun copyRenderVar (oldv, newv) = IR.setRenderVar (newv, IR.isRenderVar oldv)
97    
98         val vars = ((PSV.SVMap.listItems env) @ args)
99         val varCopies = List.map copyVar vars
100    
101         fun mkCopy(newv, oldv, k) = IR.mkPRIM(newv, IR.COPY, [oldv], k)
102            in            in
103              IR.mkPRIM(x', p, args, body x')       List.app copyRenderVar (ListPair.zipEq (vars, varCopies));
104         ListPair.foldr mkCopy (IR.mkGOTO(blk, varCopies)) (varCopies, vars)
105            end            end
106    
107       fun goto (env, blk) = gotoWithArgs(env, [], blk)
108    
109    
110    (* Not sure if this should be made into a primitive or not, but    (* Not sure if this should be made into a primitive or not, but
111     * basically this creates the XOR'd value of var1 and var2 and     * basically this creates the XOR'd value of var1 and var2 and
112     * stores it in result.     * stores it in result. *)
    *)  
113      fun mkXOR (result, var1, var2, stmt : IR.var -> IR.stmt) =      fun mkXOR (result, var1, var2, stmt : IR.var -> IR.stmt) =
114            letPRIM("testOR", IR.T_BOOL, IR.OR, [var1, var2], fn testOR =>            letPRIM("testOR", IR.T_BOOL, IR.OR, [var1, var2], fn testOR =>
115            letPRIM("testAND", IR.T_BOOL, IR.AND, [var1, var2], fn testAND =>            letPRIM("testAND", IR.T_BOOL, IR.AND, [var1, var2], fn testAND =>
116            letPRIM("testNAND", IR.T_BOOL, IR.NOT, [testAND], fn testNAND =>            letPRIM("testNAND", IR.T_BOOL, IR.NOT, [testAND], fn testNAND =>
117            letPRIM(result, IR.T_BOOL, IR.AND, [testOR, testNAND], stmt))))            letPRIM(result, IR.T_BOOL, IR.AND, [testOR, testNAND], stmt))))
118    
119        fun genFloatVar (fltVar, env, domain : Float.float P.domain, dist, stmt : IR.var -> IR.stmt) = let
120          fun genRandVal(var, stmt : IR.var -> IR.stmt) = (case dist
121            of P.DIST_UNIFORM =>
122              letPRIM(var, IR.T_FLOAT, IR.RAND, [], stmt)
123    
124             (* The PDF here is f(x) = 2x when 0 < x <= 1, so the CDF is going
125              * to be the integral of f from 0 -> y => y^2. Hence, whenever we
126              * generate a random number, in order to get the random value according
127              * to this probability distribution, we just square it. *)
128             | P.DIST_INC_LIN =>
129              letPRIM("randVal", IR.T_FLOAT, IR.RAND, [], fn randVal =>
130              letPRIM(var, IR.T_FLOAT, IR.MULT, [randVal, randVal], stmt))
131    
132             (* The PDF here is f(x) = -2x + 2 when 0 <= x < 1, so the CDF is going
133              * to be the integral of f from 0 -> y => -(y^2) + 2y. Hence, whenever we
134              * generate a random number, in order to get the random value according
135              * to this probability distribution, we just square it.
136              *)
137             | P.DIST_DEC_LIN =>
138              letPRIM("randVal", IR.T_FLOAT, IR.RAND, [], fn randVal =>
139              letPRIM("randSq", IR.T_FLOAT, IR.MULT, [randVal, randVal], fn randSq =>
140              letPRIM("termOne", IR.T_FLOAT, IR.MULT, [randSq, IR.newConst("negOne", IR.C_FLOAT ~1.0)], fn termOne =>
141              letPRIM("termTwo", IR.T_FLOAT, IR.MULT, [randVal, IR.newConst("negOne", IR.C_FLOAT 2.0)], fn termTwo =>
142              letPRIM(var, IR.T_FLOAT, IR.ADD, [termOne, termTwo], stmt)
143              ))))
144    
145             | _ => raise Fail "Unable to create random float for specified distribution"
146           (* end case *))
147         in
148         (case domain
149          of P.D_POINT(pt) =>
150             (* Our options here are pretty limited... *)
151             letPRIM (fltVar, IR.T_FLOAT, IR.COPY, [psvToIRVar(env, pt)], stmt)
152    
153           | P.D_BOX{max, min} =>
154             genRandVal("randf", fn rand =>
155             letPRIM("boxDiff", IR.T_FLOAT, IR.SUB, [psvToIRVar(env, max), psvToIRVar(env, max)], fn diff =>
156             letPRIM("scale", IR.T_FLOAT, IR.MULT, [diff, rand], fn scale =>
157             letPRIM( fltVar, IR.T_FLOAT, IR.ADD, [psvToIRVar(env, max), scale], stmt )
158             )))
159           | _ => raise Fail ("Cannot generate float in specified domain: " ^ (P.dToStr domain))
160         (* end case *))
161        end
162    
163    (* Generates a random vector within the given domain and puts it in vecVar *)    (* Generates a random vector within the given domain and puts it in vecVar *)
164      fun genVecVar (vecVar, env, domain, stmt : IR.var -> IR.stmt) = (case domain      fun genVecVar (
165          vecVar,
166          env,
167          domain : Vec3f.vec3 P.domain,
168          dist : Vec3f.vec3 P.distribution,
169          stmt : IR.var -> IR.stmt
170        ) = (case domain
171             of P.D_POINT(pt) =>             of P.D_POINT(pt) =>
172               (* Our options here are pretty limited... *)               (* Our options here are pretty limited... *)
173                  letPRIM (vecVar, IR.T_VEC, IR.COPY, [psvToIRVar(env, pt)], stmt)                  letPRIM (vecVar, IR.T_VEC, IR.COPY, [psvToIRVar(env, pt)], stmt)
174    
175              | P.D_LINE({pt1, pt2}) =>              | P.D_LINE({pt1, pt2}) =>
176    
177                (* Lerp between the points. *)                (* Lerp between the points. *)
178                  letPRIM ("randVal", IR.T_FLOAT, IR.RAND, [], fn randVal =>                  letPRIM ("randVal", IR.T_FLOAT, IR.RAND, [], fn randVal =>
179                  letPRIM ("randInv", IR.T_FLOAT, IR.SUB, [IR.newConst("one", IR.C_FLOAT 1.0), randVal], fn randInv =>                  letPRIM ("randInv", IR.T_FLOAT, IR.SUB, [IR.newConst("one", IR.C_FLOAT 1.0), randVal], fn randInv =>
# Line 177  Line 219 
219    
220    
221              | P.D_TRIANGLE{pt1, pt2, pt3} =>              | P.D_TRIANGLE{pt1, pt2, pt3} =>
222    
223                  letPRIM ("pt1ToPt2", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt2), psvToIRVar(env, pt1)], fn pt1ToPt2 =>                  letPRIM ("pt1ToPt2", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt2), psvToIRVar(env, pt1)], fn pt1ToPt2 =>
224                  letPRIM ("pt1ToPt3", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt3), psvToIRVar(env, pt1)], fn pt1ToPt3 =>                  letPRIM ("pt1ToPt3", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt3), psvToIRVar(env, pt1)], fn pt1ToPt3 =>
225                  letPRIM ("randOne", IR.T_FLOAT, IR.RAND, [], fn rand1 =>                  letPRIM ("randOne", IR.T_FLOAT, IR.RAND, [], fn rand1 =>
# Line 188  Line 231 
231                  letPRIM ("tempAdd", IR.T_VEC, IR.ADD_VEC, [psvToIRVar(env, pt1), nextScale1], fn tempAdd =>                  letPRIM ("tempAdd", IR.T_VEC, IR.ADD_VEC, [psvToIRVar(env, pt1), nextScale1], fn tempAdd =>
232                  letPRIM (vecVar, IR.T_VEC, IR.ADD_VEC, [tempAdd, scale2], stmt))))))))))                  letPRIM (vecVar, IR.T_VEC, IR.ADD_VEC, [tempAdd, scale2], stmt))))))))))
233    
234            | P.D_PLANE _ => raise Fail ("Cannot generate point in plane because domain is unbounded.")
235    
236            | P.D_RECT{pt, htvec, wdvec} =>
237    
238                letPRIM ("randOne", IR.T_FLOAT, IR.RAND, [], fn rand1 =>
239                letPRIM ("randTwo", IR.T_FLOAT, IR.RAND, [], fn rand2 =>
240                letPRIM ("htScale", IR.T_VEC, IR.SCALE, [rand1, psvToIRVar(env, htvec)], fn htScale =>
241                letPRIM ("wdScale", IR.T_VEC, IR.SCALE, [rand2, psvToIRVar(env, wdvec)], fn wdScale =>
242                letPRIM ("overTheRiver", IR.T_VEC, IR.ADD_VEC, [psvToIRVar(env, pt), htScale], fn stepOne =>
243                letPRIM (vecVar, IR.T_VEC, IR.ADD_VEC, [stepOne, wdScale], stmt)
244                )))))
245    
246              | P.D_CYLINDER {pt1, pt2, irad, orad} => let              | P.D_CYLINDER {pt1, pt2, irad, orad} => let
247                    val normVar = PSV.new("local_ht", PSV.T_VEC3F)                    val normVar = PSV.new("local_ht", PSV.T_VEC3F)
248                   in                   in
# Line 197  Line 252 
252                    letPRIM("htInv", IR.T_FLOAT, IR.DIV, [IR.newConst("one", IR.C_FLOAT 1.0), height], fn htInv =>                    letPRIM("htInv", IR.T_FLOAT, IR.DIV, [IR.newConst("one", IR.C_FLOAT 1.0), height], fn htInv =>
253                    letPRIM("n", IR.T_VEC, IR.SCALE, [htInv, normVec], fn norm =>                    letPRIM("n", IR.T_VEC, IR.SCALE, [htInv, normVec], fn norm =>
254                    (* Generate a point in the lower disc. *)                    (* Generate a point in the lower disc. *)
255                      genVecVar("ptInDisc", insert(env, normVar, norm), P.D_DISC{pt = pt1, normal = normVar, irad = irad, orad = orad}, fn ptInDisc =>                      genVecVar("ptInDisc",
256                          insertVar(env, normVar, norm),
257                          P.D_DISC{pt = pt1, normal = normVar, irad = irad, orad = orad},
258                          dist,
259                          fn ptInDisc =>
260                    (* Now add this point to a random scaling of the normVec. *)                    (* Now add this point to a random scaling of the normVec. *)
261                      letPRIM("s", IR.T_FLOAT, IR.MULT, [height, ourRand], fn scale =>                      letPRIM("s", IR.T_FLOAT, IR.MULT, [height, ourRand], fn scale =>
262                      letPRIM("sn", IR.T_VEC, IR.SCALE, [scale, normVec], fn scaledNormVec =>                      letPRIM("sn", IR.T_VEC, IR.SCALE, [scale, normVec], fn scaledNormVec =>
263                      letPRIM(vecVar, IR.T_VEC, IR.ADD_VEC, [ptInDisc, scaledNormVec], stmt)))))))))                      letPRIM(vecVar, IR.T_VEC, IR.ADD_VEC, [ptInDisc, scaledNormVec], stmt)))))))))
264                   end                   end
265    
266              | P.D_DISC {pt, normal, irad, orad} =>          | P.D_DISC {pt, normal, irad, orad} => let
267                val up = IR.newConst("up", IR.C_VEC (Vec3f.pack (0.0, 1.0, 0.0)))
268              in
269    
270                (* Get a random angle... *)                (* Get a random angle... *)
271                  letPRIM ("r", IR.T_FLOAT, IR.RAND, [], fn randForAng =>                  letPRIM ("r", IR.T_FLOAT, IR.RAND, [], fn randForAng =>
272                  letPRIM ("t", IR.T_FLOAT, IR.MULT, [randForAng, IR.newConst("fullCir", IR.C_FLOAT (2.0 * pi))], fn randAng =>                  letPRIM ("t", IR.T_FLOAT, IR.MULT, [randForAng, IR.newConst("fullCir", IR.C_FLOAT (2.0 * pi))], fn randAng =>
273    
274                (* Get a random radius *)                (* Get a random radius *)
275                  letPRIM ("e0", IR.T_FLOAT, IR.RAND, [], fn newRand =>                  letPRIM ("e0", IR.T_FLOAT, IR.RAND, [], fn newRand =>
276                  letPRIM ("e0sq", IR.T_FLOAT, IR.MULT, [newRand, newRand], fn randRadSq =>              letPRIM ("e0sq", IR.T_FLOAT, IR.SQRT, [newRand], fn randRadSq =>
277                  letPRIM ("radDiff", IR.T_FLOAT, IR.SUB, [psvToIRVar(env, orad), psvToIRVar(env, irad)], fn radDiff =>                  letPRIM ("radDiff", IR.T_FLOAT, IR.SUB, [psvToIRVar(env, orad), psvToIRVar(env, irad)], fn radDiff =>
278                  letPRIM ("newRadDist", IR.T_FLOAT, IR.MULT, [randRadSq, radDiff], fn newRadDist =>                  letPRIM ("newRadDist", IR.T_FLOAT, IR.MULT, [randRadSq, radDiff], fn newRadDist =>
279                  letPRIM ("newRad", IR.T_FLOAT, IR.ADD, [psvToIRVar(env, irad), newRadDist], fn newRad =>                  letPRIM ("newRad", IR.T_FLOAT, IR.ADD, [psvToIRVar(env, irad), newRadDist], fn newRad =>
               (* Find a vector in the plane of the disc, and then  
                * translate it to the center.  
                *)  
                 letPRIM ("ntoc", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt), psvToIRVar(env, normal)], fn normToCen =>  
                 letPRIM ("v", IR.T_VEC, IR.CROSS, [psvToIRVar(env, pt), normToCen], fn vecInDisc =>  
                 letPRIM ("vidn", IR.T_VEC, IR.NORM, [vecInDisc], fn vecInDiscNorm =>  
                 letPRIM ("p", IR.T_VEC, IR.CROSS, [vecInDiscNorm, psvToIRVar(env, normal)], fn ptInDisc =>  
                 letPRIM ("pidn", IR.T_VEC, IR.NORM, [ptInDisc], fn ptInDiscNorm =>  
               (* Figure out x and y values for our new radius and angle *)  
                 letPRIM ("rx", IR.T_FLOAT, IR.COS, [randAng], fn radX =>  
                 letPRIM ("ar1", IR.T_FLOAT, IR.MULT, [newRad, radX], fn amtVecOne =>  
                 letPRIM ("rv1", IR.T_VEC, IR.SCALE, [amtVecOne, vecInDiscNorm], fn resVecOne =>  
                 letPRIM ("ry", IR.T_FLOAT, IR.SIN, [randAng], fn radY =>  
                 letPRIM ("ar2", IR.T_FLOAT, IR.MULT, [newRad, radY], fn amtVecTwo =>  
                 letPRIM ("rv2", IR.T_VEC, IR.SCALE, [amtVecTwo, ptInDiscNorm], fn resVecTwo =>  
                 letPRIM ("res", IR.T_VEC, IR.ADD_VEC, [resVecOne, resVecTwo], fn result =>  
                 letPRIM (vecVar, IR.T_VEC, IR.ADD_VEC, [result, psvToIRVar(env, pt)], stmt))))))))))))))))))))  
280    
281                (* Build vector in unit disc *)
282                letPRIM("sinRandAng", IR.T_FLOAT, IR.SIN, [randAng], fn randSin =>
283                letPRIM("cosRandAng", IR.T_FLOAT, IR.COS, [randAng], fn randCos =>
284                letPRIM("unitV", IR.T_VEC, IR.GEN_VEC, [randCos, IR.newConst("zero", IR.C_FLOAT 0.0), randSin], fn unitV =>
285                letPRIM("genV", IR.T_VEC, IR.SCALE, [newRad, unitV], fn genV =>
286    
287                (* Figure out angle and axis of rotation for disc. *)
288                letPRIM("rotVec", IR.T_VEC, IR.CROSS, [psvToIRVar(env, normal), up], fn rotVec =>
289                letPRIM("dotN", IR.T_FLOAT, IR.DOT, [psvToIRVar(env, normal), up], fn cosRotAng =>
290                letPRIM("rotAng", IR.T_FLOAT, IR.ACOS, [cosRotAng], fn rotAng =>
291    
292                (* Rotate our unit vector that we generated so that it lies in the same plane as the
293                 * disc using the following formula:
294                 *
295                 * Given a vector v to rotate about an axis r by angle a, the resulting vector is
296                 * (v - dot(v, r) * r) cos(a) + cross(v, r) * sin(a) + dot(v, r) * r
297                 *)
298                letPRIM ("vDotR", IR.T_FLOAT, IR.DOT, [genV, rotVec], fn vDotR =>
299                letPRIM ("vPara", IR.T_VEC, IR.SCALE, [vDotR, rotVec], fn vPara =>
300                letPRIM ("vPerp", IR.T_VEC, IR.SUB_VEC, [genV, vPara], fn vPerp =>
301                letPRIM ("vCrossR", IR.T_VEC, IR.CROSS, [genV, rotVec], fn vCrossR =>
302                (* cosA is cosRotAng *)
303                letPRIM ("sinA", IR.T_FLOAT, IR.SIN, [rotAng], fn sinRotAng =>
304                letPRIM ("scaleCross", IR.T_VEC, IR.SCALE, [sinRotAng, vCrossR], fn scaleCross =>
305                letPRIM ("scalePerp", IR.T_VEC, IR.SCALE, [cosRotAng, vPerp], fn scalePerp =>
306                letPRIM ("scaleAdd", IR.T_VEC, IR.ADD_VEC, [scalePerp, scaleCross], fn scaleAdd =>
307                letPRIM ("result", IR.T_VEC, IR.ADD_VEC, [scaleAdd, vPara], fn result =>
308    
309                letPRIM (vecVar, IR.T_VEC, IR.ADD_VEC, [result, psvToIRVar(env, pt)], stmt)
310                )))))))))))))))))))))))
311              end
312    
313            (* In order to generate a normal distribution in a cone you need to choose a hight whose
314             * density is proportional to the area of the corresponding disc cross-section. The way
315             * I did this is by choosing a uniformly random area (basically the sqrt of a random
316             * variable) and then generating a uniformly distributed point in the corresponding
317             * cross section. I'm not 100% sure that this is the right way to do it, but it's definitely
318             * better than what I was doing before (check the SVN logs) *)
319              | P.D_CONE{pt1, pt2, irad, orad} => let              | P.D_CONE{pt1, pt2, irad, orad} => let
320                  val normVar = PSV.new("local_ht", PSV.T_VEC3F)                  val normVar = PSV.new("local_ht", PSV.T_VEC3F)
321                 val ptVar = PSV.new("local_pt", PSV.T_VEC3F)
322                 val newORad = PSV.new("local_orad", PSV.T_FLOAT)
323                 val newIRad = PSV.new("local_irad", PSV.T_FLOAT)
324                  in                  in
325                    letPRIM("eh",  IR.T_FLOAT, IR.RAND, [], fn ourRand =>                    letPRIM("eh",  IR.T_FLOAT, IR.RAND, [], fn ourRand =>
326                 letPRIM("randVal", IR.T_FLOAT, IR.SQRT, [ourRand], fn randVal =>
327                 letPRIM("randORad", IR.T_FLOAT, IR.MULT, [randVal, psvToIRVar(env, orad)], fn randORad =>
328                 letPRIM("randIRad", IR.T_FLOAT, IR.MULT, [randVal, psvToIRVar(env, irad)], fn randIRad =>
329                    letPRIM("nv", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt2), psvToIRVar(env, pt1)], fn normVec =>                    letPRIM("nv", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt2), psvToIRVar(env, pt1)], fn normVec =>
330                    letPRIM("n", IR.T_VEC, IR.NORM, [normVec], fn norm =>                    letPRIM("n", IR.T_VEC, IR.NORM, [normVec], fn norm =>
331                      genVecVar("ptInDisc", insert(env, normVar, norm), P.D_DISC{pt = pt1, normal = normVar, irad = irad, orad = orad}, fn ptInDisc =>               letPRIM("vecToRandPt", IR.T_VEC, IR.SCALE, [randVal, normVec], fn vecToRandPt =>
332                      letPRIM("gptt", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt2), ptInDisc], fn genPtToTip =>               letPRIM("discCenter", IR.T_VEC, IR.ADD, [psvToIRVar(env, pt1), vecToRandPt], fn discCenter =>
333                      letPRIM("gpttlen", IR.T_FLOAT, IR.LEN, [genPtToTip], fn genPtToTipLen =>               genVecVar(vecVar,
334                      letPRIM("s", IR.T_FLOAT, IR.MULT, [genPtToTipLen, ourRand], fn scale =>                insertVar(insertVar(insertVar(insertVar(env,
335                      letPRIM("sn", IR.T_VEC, IR.SCALE, [scale, genPtToTip], fn scaledNormVec =>                  ptVar, discCenter),
336                      letPRIM(vecVar, IR.T_VEC, IR.ADD_VEC, [ptInDisc, scaledNormVec], stmt)))))))))                  normVar, norm),
337                  end                  newORad, randORad),
338                    newIRad, randIRad),
339                  P.D_DISC{pt = ptVar, normal = normVar, irad = newIRad, orad = newORad},
340                  dist, stmt)
341                 ))))))))
342                end
343    
344                    | P.D_SPHERE{center, irad, orad} =>
345    
346                      (* Source: http://mathworld.wolfram.com/SpherePointPicking.html *)
347    
348              (* generate two random values... one will be called u and will
349               * represent cos(theta), and the other will be called v and will
350               * represent a random value in [0, 2 * pi] *)
351              letPRIM("randVal", IR.T_FLOAT, IR.RAND, [], fn rv =>
352              letPRIM("dblRandVal", IR.T_FLOAT, IR.MULT, [rv, IR.newConst("Two", IR.C_FLOAT 2.0)], fn drv =>
353              letPRIM("rand", IR.T_FLOAT, IR.SUB, [drv, IR.newConst("One", IR.C_FLOAT 1.0)], fn u =>
354    
355              letPRIM("rv2", IR.T_FLOAT, IR.RAND, [], fn rv2 =>
356              letPRIM("rand2", IR.T_FLOAT, IR.MULT, [rv2, IR.newConst("TwoPi", IR.C_FLOAT (2.0 * Float.M_PI))], fn theta =>
357    
358              letPRIM("cosTheta", IR.T_FLOAT, IR.COS, [theta], fn cosT =>
359              letPRIM("sinTheta", IR.T_FLOAT, IR.SIN, [theta], fn sinT =>
360    
361              letPRIM("usq", IR.T_FLOAT, IR.MULT, [u, u], fn usq =>
362              letPRIM("usqInv", IR.T_FLOAT, IR.SUB, [IR.newConst("One", IR.C_FLOAT 1.0), usq], fn usqInv =>
363              letPRIM("sinPhi", IR.T_FLOAT, IR.SQRT, [usqInv], fn sinP =>
364    
365              letPRIM("xVal", IR.T_FLOAT, IR.MULT, [sinP, cosT], fn xVal =>
366              letPRIM("yVal", IR.T_FLOAT, IR.MULT, [sinP, sinT], fn yVal =>
367              (* zval is just u *)
368    
369              letPRIM("vec", IR.T_VEC, IR.GEN_VEC, [xVal, yVal, u], fn vec =>
370    
371              (* Generate a random radius... *)
372                      letPRIM("ratio", IR.T_FLOAT, IR.DIV, [psvToIRVar(env, irad), psvToIRVar(env, orad)], fn ratio =>
373                      letPRIM("invRatio", IR.T_FLOAT, IR.SUB, [IR.newConst("one", IR.C_FLOAT 1.0), ratio], fn invRatio =>
374                      letPRIM("randVar", IR.T_FLOAT, IR.RAND, [], fn rand =>
375                      letPRIM("randScale", IR.T_FLOAT, IR.MULT, [rand, invRatio], fn randScale =>
376                      letPRIM("randVal", IR.T_FLOAT, IR.ADD, [randScale, ratio], fn randVal =>
377                      letPRIM("randValSq", IR.T_FLOAT, IR.SQRT, [randVal], fn randValSq =>
378                      letPRIM("radDiff", IR.T_FLOAT, IR.SUB, [psvToIRVar(env, orad), psvToIRVar(env, irad)], fn radDiff =>
379                      letPRIM("randRadVal", IR.T_FLOAT, IR.MULT, [radDiff, randValSq], fn randRadVal =>
380                      letPRIM("rad", IR.T_FLOAT, IR.ADD, [psvToIRVar(env, irad), randRadVal], fn rad =>
381    
382              | _ => raise Fail "Cannot generate point in specified domain."                    (* Normalize the vector and scale it by the radius. *)
383            (* end case *))                    letPRIM("scaledVec", IR.T_VEC, IR.SCALE, [rad, vec], fn sVec =>
384            (*                    letPRIM(vecVar, IR.T_VEC, IR.ADD_VEC, [sVec, psvToIRVar(env, center)], stmt)
385            | generate (Dplane{pt, n}) = Vec3f.unpack pt                    ))))))))))
386        | generate (Drectangle{pt, u, v}) = Vec3f.unpack pt                    )))))))))))))
       | generate (Dsphere{c, orad, irad}) = Vec3f.unpack c  
       | generate (Dblob{c, stddev}) = Vec3f.unpack c  
           *)  
387    
388              (* end case *))
389    
390    (* This function takes an IR boolean, its environment, a particle state, domain,    (* This function takes an IR boolean, its environment, a particle state, domain,
391     * and continuation.     * and continuation.
# Line 262  Line 393 
393     * We set the boolean to whether or not the current particle given by the particle     * We set the boolean to whether or not the current particle given by the particle
394     * state is within the domain, and then pass the continuation on.     * state is within the domain, and then pass the continuation on.
395     *)     *)
396      fun mkWithinVar (boolVar, env, var, d, stmt : IR.var -> IR.stmt) = let      fun mkVecWithinVar (boolVar, env, var, d : Vec3f.vec3 P.domain, stmt : IR.var -> IR.stmt) = let
397            val pos = var            val pos = var
398            in            in
399              case d              case d
400               of P.D_POINT(pt) =>               of P.D_POINT(pt) =>
401                    letPRIM("subVec", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt), pos], fn subVec =>                    letPRIM("subVec", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt), pos], fn subVec =>
402                    letPRIM("vecLen", IR.T_FLOAT, IR.LEN, [subVec], fn vecLen =>                    letPRIM("vecLen", IR.T_FLOAT, IR.LEN_SQ, [subVec], fn vecLen =>
403                    letPRIM(boolVar, IR.T_BOOL, IR.GT, [psvToIRVar(env, epsilon), vecLen], stmt)))                    letPRIM(boolVar, IR.T_BOOL, IR.GT, [psvToIRVar(env, epsilon), vecLen], stmt)))
404    
405          (* Take the vectors going from our position to pt1, and pt2. Then          (* Take the vectors going from our position to pt1, and pt2. Then
# Line 291  Line 422 
422               * behind it (with respect to the normal)               * behind it (with respect to the normal)
423               *)               *)
424                | P.D_PLANE{pt, normal} =>                | P.D_PLANE{pt, normal} =>
425                    letPRIM("posToPt", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt), pos], fn posToPt =>                    letPRIM("posToPt", IR.T_VEC, IR.SUB_VEC, [pos, psvToIRVar(env, pt)], fn posToPt =>
426                    letPRIM("dot", IR.T_FLOAT, IR.DOT, [posToPt, psvToIRVar(env, normal)], fn dotProd =>                    letPRIM("dot", IR.T_FLOAT, IR.DOT, [posToPt, psvToIRVar(env, normal)], fn dotProd =>
427                    letPRIM(boolVar, IR.T_BOOL, IR.GT, [dotProd, IR.newConst("zero", IR.C_FLOAT 0.0)], stmt)))                    letPRIM(boolVar, IR.T_BOOL, IR.GT, [dotProd, IR.newConst("zero", IR.C_FLOAT 0.0)], stmt)))
428    
# Line 302  Line 433 
433               * orad.               * orad.
434               *)               *)
435                | P.D_DISC{pt, normal, orad, irad} =>                | P.D_DISC{pt, normal, orad, irad} =>
436                    letPRIM("posToPt", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt), pos], fn posToPt =>              letPRIM("posToPt", IR.T_VEC, IR.SUB_VEC, [pos, psvToIRVar(env, pt)], fn posToPt =>
                   letPRIM("posToPtLen", IR.T_FLOAT, IR.LEN, [posToPt], fn posToPtLen =>  
437                    letPRIM("dot", IR.T_FLOAT, IR.DOT, [posToPt, psvToIRVar(env, normal)], fn dotProd =>                    letPRIM("dot", IR.T_FLOAT, IR.DOT, [posToPt, psvToIRVar(env, normal)], fn dotProd =>
438                    letPRIM("inDisc", IR.T_BOOL, IR.GT, [IR.newConst("small", IR.C_FLOAT 0.01), dotProd], fn inDisc =>                    letPRIM("inDisc", IR.T_BOOL, IR.GT, [IR.newConst("small", IR.C_FLOAT 0.01), dotProd], fn inDisc =>
439                    letPRIM("inOrad", IR.T_BOOL, IR.GT, [psvToIRVar(env, orad), posToPtLen], fn inOrad =>  
440                    letPRIM("inIrad", IR.T_BOOL, IR.GT, [posToPtLen, psvToIRVar(env, irad)], fn inIrad =>              letPRIM("parPosToP", IR.T_VEC, IR.SCALE, [dotProd, psvToIRVar(env, normal)], fn posToPtParallelToNormal =>
441                letPRIM("perpPosToP", IR.T_VEC, IR.SUB_VEC, [posToPt, posToPtParallelToNormal], fn posToPtPerpToNormal =>
442                letPRIM("inDiscLen", IR.T_FLOAT, IR.LEN, [posToPtPerpToNormal], fn posToPtLen =>
443    
444                letPRIM("inOradGt", IR.T_BOOL, IR.GT, [psvToIRVar(env, orad), posToPtLen], fn inOradGt =>
445                letPRIM("inOradEq", IR.T_BOOL, IR.EQUALS, [psvToIRVar(env, orad), posToPtLen], fn inOradEq =>
446                letPRIM("inOrad", IR.T_BOOL, IR.OR, [inOradGt, inOradEq], fn inOrad =>
447    
448                letPRIM("inIradGt", IR.T_BOOL, IR.GT, [posToPtLen, psvToIRVar(env, irad)], fn inIradGt =>
449                letPRIM("inIradEq", IR.T_BOOL, IR.EQUALS, [posToPtLen, psvToIRVar(env, irad)], fn inIradEq =>
450                letPRIM("inIrad", IR.T_BOOL, IR.OR, [inIradGt, inIradEq], fn inIrad =>
451    
452                    letPRIM("inBothRad", IR.T_BOOL, IR.AND, [inIrad, inOrad], fn inBothRad =>                    letPRIM("inBothRad", IR.T_BOOL, IR.AND, [inIrad, inOrad], fn inBothRad =>
453                    letPRIM(boolVar, IR.T_BOOL, IR.AND, [inDisc, inBothRad], stmt))))))))  
454                letPRIM(boolVar, IR.T_BOOL, IR.AND, [inDisc, inBothRad], stmt))))))))))))))
455    
456              (* Simply see whether or not the distance from the center is within the              (* Simply see whether or not the distance from the center is within the
457               * specified bounds.               * specified bounds.
# Line 320  Line 462 
462                    letPRIM("inOrad", IR.T_BOOL, IR.GT, [psvToIRVar(env, orad), posToCLen], fn inOrad =>                    letPRIM("inOrad", IR.T_BOOL, IR.GT, [psvToIRVar(env, orad), posToCLen], fn inOrad =>
463                    letPRIM("inIrad", IR.T_BOOL, IR.GT, [posToCLen, psvToIRVar(env, irad)], fn inIrad =>                    letPRIM("inIrad", IR.T_BOOL, IR.GT, [posToCLen, psvToIRVar(env, irad)], fn inIrad =>
464                    letPRIM(boolVar, IR.T_BOOL, IR.AND, [inIrad, inOrad], stmt)))))                    letPRIM(boolVar, IR.T_BOOL, IR.AND, [inIrad, inOrad], stmt)))))
465  (*  
466                | P.D_TRIANGLE {pt1: vec3f var, pt2: vec3f var, pt3: vec3f var}                    | P.D_CYLINDER {pt1, pt2, irad, orad} =>
467                | P.D_PLANE {pt: vec3f var, normal: vec3f var}  
468                | P.D_RECT {pt: vec3f var, htvec: vec3f var, wdvec: vec3f var}                    (* !FIXME! Right now, we see whether or not the point is within the two planes defined
469                | P.D_BOX {min: vec3f var, max: vec3f var}                     * by the endpoints of the cylinder, and then testing to see whether or not the smallest
470                | P.D_SPHERE {center: vec3f var, irad: vec3f var, orad: vec3f var}                     * distance to the line segment falls within the radii. It might be faster to find the
471                | P.D_CYLINDER {pt1: vec3f var, pt2: vec3f var, irad: float var, orad: float var}                     * closest point to the line defined by the endpoints and then see whether or not the point
472                | P.D_CONE {pt1: vec3f var, pt2: vec3f var, irad: float var, orad: float var}                     * is within the segment.
473                | P.D_BLOB {center: vec3f var, stddev: float var}                     *)
474                | P.D_DISC {pt: vec3f var, normal: vec3f var, irad: float var, orad: float var}  
475  *)                    (* Is it in one plane *)
476                | _ => raise Fail "Cannot determine within-ness for specified domain."                    letPRIM("plane1Norm", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt2), psvToIRVar(env, pt1)], fn plane1Norm =>
477                      letPRIM("posToPt1", IR.T_VEC, IR.SUB_VEC, [pos, psvToIRVar(env, pt1)], fn posToPt1 =>
478                      letPRIM("dot1", IR.T_FLOAT, IR.DOT, [posToPt1, plane1Norm], fn dot1Prod =>
479                      letPRIM("inPlane1", IR.T_BOOL, IR.GT, [dot1Prod, IR.newConst("zero", IR.C_FLOAT 0.0)], fn inPlane1=>
480    
481                      (* Is it in another plane *)
482                      letPRIM("plane2Norm", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt1), psvToIRVar(env, pt2)], fn plane2Norm =>
483                      letPRIM("posToPt2", IR.T_VEC, IR.SUB_VEC, [pos, psvToIRVar(env, pt2)], fn posToPt2 =>
484                      letPRIM("dot2", IR.T_FLOAT, IR.DOT, [posToPt2, plane2Norm], fn dot2Prod =>
485                      letPRIM("inPlane2", IR.T_BOOL, IR.GT, [dot2Prod, IR.newConst("zero", IR.C_FLOAT 0.0)], fn inPlane2=>
486    
487                      (* Is it in both planes? *)
488                      letPRIM("inPlanes", IR.T_BOOL, IR.AND, [inPlane1, inPlane2], fn inPlanes =>
489    
490                      (* Find distance from segment *)
491                      letPRIM("a", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt2), psvToIRVar(env, pt1)], fn a =>
492                      letPRIM("b", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt1), pos], fn b =>
493                      letPRIM("alen", IR.T_FLOAT, IR.LEN, [a], fn alen =>
494                      letPRIM("axb", IR.T_VEC, IR.CROSS, [a, b], fn axb =>
495                      letPRIM("axblen", IR.T_FLOAT, IR.LEN, [axb], fn axblen =>
496                      letPRIM("dist", IR.T_FLOAT, IR.DIV, [axblen, alen], fn dist =>
497    
498                      (* Is distance in both radii? *)
499                      letPRIM("inOradGt", IR.T_BOOL, IR.GT, [psvToIRVar(env, orad), dist], fn inOradGt =>
500                      letPRIM("inOradEq", IR.T_BOOL, IR.EQUALS, [psvToIRVar(env, orad), dist], fn inOradEq =>
501                      letPRIM("inOrad", IR.T_BOOL, IR.OR, [inOradGt, inOradEq], fn inOrad =>
502    
503                      letPRIM("inIradGt", IR.T_BOOL, IR.GT, [dist, psvToIRVar(env, irad)], fn inIradGt =>
504                      letPRIM("inIradEq", IR.T_BOOL, IR.EQUALS, [dist, psvToIRVar(env, irad)], fn inIradEq =>
505                      letPRIM("inIrad", IR.T_BOOL, IR.OR, [inIradGt, inIradEq], fn inIrad =>
506    
507                      letPRIM("inBothRad", IR.T_BOOL, IR.AND, [inIrad, inOrad], fn inBothRad =>
508    
509                      (* It's in the cylinder (tube) if it's within both radii and in both planes... *)
510                      letPRIM(boolVar, IR.T_BOOL, IR.AND, [inPlanes, inBothRad], stmt)
511                      ))))))))))))))))))))))
512    
513                  | _ => raise Fail ("Cannot determine within-ness for specified vec3 domain: " ^ (P.dToStr d))
514              (* end case *)              (* end case *)
515            end (*end let *)            end (*end let *)
516    
517            fun mkFloatWithinVar (boolVar, env, var, d : Float.float P.domain, stmt : IR.var -> IR.stmt) = (case d
518              of P.D_POINT(pt) => letPRIM(boolVar, IR.T_BOOL, IR.EQUALS, [psvToIRVar(env, pt), var], stmt)
519               | P.D_BOX {min, max} =>
520                 letPRIM("bigMin", IR.T_BOOL, IR.GT, [var, psvToIRVar(env, min)], fn bigMin =>
521                 letPRIM("smallMax", IR.T_BOOL, IR.GT, [psvToIRVar(env, max), var], fn smallMax =>
522                 letPRIM(boolVar, IR.T_BOOL, IR.AND, [bigMin, smallMax], stmt)))
523               | _ => raise Fail ("Cannot determine within-ness for specified float domain: " ^ (P.dToStr d))
524             (* end case *))
525    
526    (* generate code to produce a random particle state from a domain *)          fun mkIntBool(env, p1var, p2var, d : Vec3f.vec3 P.domain, k : IR.var -> ir_env -> IR.stmt) = let
527      fun newParticle (posDomain, velDomain, colDomain, env, k : particle_state -> IR.stmt) =            val _ = ()
528              (* genVecVar (vecVar, env, domain, stmt) *)           in
529              genVecVar("ps_pos", env, posDomain, fn newPos =>            (case d
530              genVecVar("ps_vel", env, velDomain, fn newVel =>              of P.D_POINT(pt) =>
531              genVecVar("ps_col", env, colDomain, fn newCol =>  
532              letSPRIM ("ps_size", IR.T_FLOAT, IR.RAND, [], fn newSize =>               (* Get vectors *)
533              letSPRIM ("ps_isDead", IR.T_BOOL, IR.COPY, [IR.newConst("fbool", IR.C_BOOL false)], fn newIsDead =>               letPRIM("p1ToPt", IR.T_VEC, IR.SUB_VEC, [psvToIRVar (env, pt), p1var], fn p1ToPt =>
534                k(PS{pos = newPos,               letPRIM("p2ToPt", IR.T_VEC, IR.SUB_VEC, [psvToIRVar (env, pt), p2var], fn p2ToPt =>
535                     vel = newVel,               letPRIM("p1ToP2", IR.T_VEC, IR.SUB_VEC, [p2var, p1var], fn p1ToP2 =>
536                     size = newSize,  
537                     isDead = newIsDead,               (* Get distances *)
538                     color = newCol,               letPRIM("p1ToPtLen", IR.T_FLOAT, IR.LEN, [p1ToPt], fn p1ToPtLen =>
539                     dummy = IR.newConst("dmy", IR.C_FLOAT 0.01)})               letPRIM("p2ToPtLen", IR.T_FLOAT, IR.LEN, [p2ToPt], fn p2ToPtLen =>
540              )))))               letPRIM("p1ToP2Len", IR.T_FLOAT, IR.LEN, [p1ToP2], fn p1ToP2Len =>
541    
542                 (* Add & subtract ... *)
543                 letPRIM("distSum", IR.T_FLOAT, IR.ADD, [p1ToPtLen, p2ToPtLen], fn distSum =>
544                 letPRIM("distDiff", IR.T_FLOAT, IR.SUB, [distSum, p1ToP2Len], fn distDiff =>
545                 letPRIM("distDiffAbs", IR.T_FLOAT, IR.ABS, [distDiff], fn distDiffAbs =>
546    
547                 (* Do the boolean stuff... *)
548                 letPRIM("intersect", IR.T_BOOL, IR.GT, [psvToIRVar(env, epsilon), distDiffAbs], fn intVar => k intVar env)
549    
550                 )))
551                 )))
552                 )))
553    
554                | P.D_PLANE {pt, normal} =>
555                  letPRIM("d", IR.T_FLOAT, IR.DOT, [psvToIRVar(env, pt), psvToIRVar(env, normal)], fn d =>
556                  letPRIM("p1d", IR.T_FLOAT, IR.DOT, [p1var, psvToIRVar(env, normal)], fn p1d =>
557                  letPRIM("p2d", IR.T_FLOAT, IR.DOT, [p2var, psvToIRVar(env, normal)], fn p2d =>
558                  letPRIM("p1dist", IR.T_FLOAT, IR.SUB, [d, p1d], fn p1dist =>
559                  letPRIM("p2dist", IR.T_FLOAT, IR.SUB, [d, p2d], fn p2dist =>
560                  letPRIM("distProd", IR.T_FLOAT, IR.MULT, [p1dist, p2dist], fn distProd =>
561                  letPRIM("intersect", IR.T_BOOL, IR.GT, [IR.newConst("zero", IR.C_FLOAT 0.0), distProd], fn intVar => k intVar env)
562                  ))))))
563    
564                | P.D_DISC {pt, normal, orad, irad} => let
565                  val boolVar = IR.newParam("intersect", IR.T_BOOL)
566                  val newBlk = newBlockWithArgs(env, [boolVar], k boolVar)
567                 in
568                  letPRIM("d", IR.T_FLOAT, IR.DOT, [psvToIRVar(env, pt), psvToIRVar(env, normal)], fn d =>
569                  letPRIM("p1d", IR.T_FLOAT, IR.DOT, [p1var, psvToIRVar(env, normal)], fn p1d =>
570    
571                  (* Early out... does it intersect the plane?
572                   *
573                   * !SPEED! Due to the perceived slowness of branching on
574                   * GPUs, this might not actually be faster on all runtime environments *)
575    
576                  letPRIM("p2d", IR.T_FLOAT, IR.DOT, [p2var, psvToIRVar(env, normal)], fn p2d =>
577                  letPRIM("p1dist", IR.T_FLOAT, IR.SUB, [d, p1d], fn p1dist =>
578                  letPRIM("p2dist", IR.T_FLOAT, IR.SUB, [d, p2d], fn p2dist =>
579                  letPRIM("distProd", IR.T_FLOAT, IR.MULT, [p1dist, p2dist], fn distProd =>
580                  letPRIM("earlyOut", IR.T_BOOL, IR.GT, [distProd, IR.newConst("zero", IR.C_FLOAT 0.0)], fn earlyOut =>
581                  IR.mkIF(earlyOut,
582                    (* then *)
583                    letPRIM("intersect", IR.T_BOOL, IR.NOT, [earlyOut], fn var => gotoWithArgs(env, [var], newBlk)),
584                    (* else *)
585                    letPRIM("v", IR.T_VEC, IR.SUB_VEC, [p2var, p1var], fn v =>
586                    letPRIM("vDotn", IR.T_FLOAT, IR.DOT, [v, psvToIRVar(env, normal)], fn vdn =>
587                    letPRIM("t", IR.T_FLOAT, IR.DIV, [p1dist, vdn], fn t =>
588    
589                    (* !TODO! Add some sort of assert mechanism to make sure that t is
590                     * in the interval [0, 1]... *)
591                    letPRIM("vscale", IR.T_VEC, IR.SCALE, [t, v], fn vscale =>
592                    letPRIM("ppt", IR.T_VEC, IR.ADD_VEC, [p1var, vscale], fn ppt =>
593                    letPRIM("lenVec", IR.T_VEC, IR.SUB_VEC, [ppt, psvToIRVar(env, pt)], fn cv =>
594                    letPRIM("len", IR.T_FLOAT, IR.LEN, [cv], fn len =>
595    
596                    (* Check to see whether or not it's within the radius... *)
597                    letPRIM("gtirad", IR.T_BOOL, IR.GT, [len, psvToIRVar(env, irad)], fn gtirad =>
598                    letPRIM("ltorad", IR.T_BOOL, IR.GT, [psvToIRVar(env, orad), len], fn ltorad =>
599                    letPRIM("intersect", IR.T_BOOL, IR.AND, [gtirad, ltorad], fn var => gotoWithArgs(env, [var], newBlk))
600                   ))))))))))
601                 )))))))
602                end (* P.D_DISC *)
603    
604                | _ => raise Fail ("Cannot calculate intersection bool for specified domain: " ^ (P.dToStr d))
605              (* end case *))
606    
607             end (* mkIntBool *)
608    
609            (* We assume that the segment already intersects with the domain. *)
610            fun mkIntPt(env, p1var, p2var, d : Vec3f.vec3 P.domain, k : IR.var -> IR.stmt) = let
611              val _ = ()
612             in
613              (case d
614                of P.D_POINT(pt) => k (psvToIRVar (env, pt))
615    
616                 | P.D_PLANE {pt, normal} =>
617                   letPRIM("d", IR.T_FLOAT, IR.DOT, [psvToIRVar(env, pt), psvToIRVar(env, normal)], fn d =>
618                   letPRIM("p1d", IR.T_FLOAT, IR.DOT, [p1var, psvToIRVar(env, normal)], fn p1d =>
619                   letPRIM("num", IR.T_FLOAT, IR.SUB, [d, p1d], fn num =>
620                   letPRIM("v", IR.T_VEC, IR.SUB_VEC, [p2var, p1var], fn v =>
621                   letPRIM("den", IR.T_FLOAT, IR.DOT, [v, psvToIRVar(env, normal)], fn den =>
622                   letPRIM("t", IR.T_FLOAT, IR.DIV, [num, den], fn t =>
623                   letPRIM("vsc", IR.T_VEC, IR.SCALE, [t, v], fn vs =>
624                   letPRIM("intPt", IR.T_VEC, IR.ADD_VEC, [p1var, vs], k)
625                   )))))))
626    
627                 (* Since we already know they intersect, the intersection point must be
628                  * just the point that's on the plane... *)
629                 | P.D_DISC {pt, normal, orad, irad} => mkIntPt(env, p1var, p2var, P.D_PLANE{pt = pt, normal = normal}, k)
630                 | _ => raise Fail ("Cannot calculate intersection point for specified domain: "  ^ (P.dToStr d))
631              (* end case *))
632             end (* mkIntPt *)
633    
634      (* Find the normal at the given position of the particle for the specified      (* Find the normal at the given position of the particle for the specified
635       * domain. Note, that the particle doesn't necessarily need to be on the       * domain. Note, that the particle doesn't necessarily need to be on the
636       * domain, but if it's not then the behavior is undefined.       * domain, but if it's not then the behavior is undefined. *)
637       *)      fun normAtPoint(retNorm, d, env, pos, k : IR.var -> ir_env -> IR.stmt) = let
     fun normAtPoint(retNorm, d, env, state, k : IR.var -> particle_state -> IR.stmt) = let  
638        val newNorm = IR.newParam("n", IR.T_VEC)        val newNorm = IR.newParam("n", IR.T_VEC)
639        val nextBlk = newBlockWithArgs(env, [newNorm], k(newNorm))        val nextBlk = newBlockWithArgs(env, [newNorm], k(newNorm))
       val PS{pos, ...} = state  
640       in       in
641        (case d        (case d
642            of P.D_PLANE{pt, normal} => letPRIM(retNorm, IR.T_VEC, IR.COPY, [psvToIRVar(env, normal)],            of P.D_POINT(pt) =>
643                fn newNormVar => gotoWithArgs(state, [newNormVar], nextBlk))               letPRIM("sv", IR.T_VEC, IR.SUB_VEC, [pos, psvToIRVar(env, pt)], fn subVec =>
644                 letPRIM(retNorm, IR.T_VEC, IR.NORM, [subVec], fn newNormVar => k newNormVar env
645                    ))
646    
647               | P.D_PLANE{pt, normal} =>
648                 letPRIM("inVec", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt), pos], fn inVec =>
649                 letPRIM("dotNorm", IR.T_FLOAT, IR.DOT, [psvToIRVar(env, normal), inVec], fn dotNorm =>
650                 letPRIM("absDot", IR.T_FLOAT, IR.ABS, [dotNorm], fn absDot =>
651                 letPRIM("avoidZero", IR.T_FLOAT, IR.MAX, [psvToIRVar(env, epsilon), absDot], fn dot =>
652             letPRIM("dnRecip", IR.T_FLOAT, IR.DIV, [IR.newConst("One", IR.C_FLOAT 1.0), dot], fn dnRecip =>
653             letPRIM("sign", IR.T_FLOAT, IR.MULT, [dnRecip, dotNorm], fn sign =>
654             (* sign here can still be zero... *)
655             letPRIM("signOffset", IR.T_FLOAT, IR.ADD, [sign, IR.newConst("half", IR.C_FLOAT 0.5)], fn signOffset =>
656             letPRIM("soRecip", IR.T_FLOAT, IR.DIV, [IR.newConst("One", IR.C_FLOAT 1.0), signOffset], fn soRecip =>
657             letPRIM("absSign", IR.T_FLOAT, IR.ABS, [soRecip], fn absSign =>
658             letPRIM("signFinal", IR.T_FLOAT, IR.MULT, [absSign, signOffset], fn signFinal =>
659    
660             letPRIM("notNorm", IR.T_VEC, IR.SCALE, [signFinal, psvToIRVar(env, normal)], fn notNorm =>
661             letPRIM(retNorm, IR.T_VEC, IR.NORM, [notNorm],
662               fn newNormVar => gotoWithArgs(env, [newNormVar], nextBlk)))))
663             ))))))))
664    
665             | P.D_DISC{pt, normal, irad, orad} =>             | P.D_DISC{pt, normal, irad, orad} =>
666                mkWithinVar("inP", env, pos, d, fn inPlane =>                normAtPoint(retNorm, P.D_PLANE{pt=pt, normal=normal}, env, pos, k)
667                    IR.mkIF(inPlane,  
668               | P.D_SPHERE{center, irad, orad} =>
669                        letPRIM("sv", IR.T_VEC, IR.SUB_VEC, [pos, psvToIRVar(env, center)], fn subVec =>
670                        letPRIM("svLen", IR.T_FLOAT, IR.LEN, [subVec], fn svLen =>
671                        letPRIM("inIrad", IR.T_BOOL, IR.GT, [svLen, psvToIRVar(env, irad)], fn inIrad =>
672                        IR.mkIF(inIrad,
673                      (* then *)                      (* then *)
674                      letPRIM(retNorm, IR.T_VEC, IR.COPY, [psvToIRVar(env, normal)],                        letPRIM("norm", IR.T_VEC, IR.NORM, [subVec], fn normVar =>
675                        fn newNormVar => gotoWithArgs(state, [newNormVar], nextBlk)),                        letPRIM(retNorm, IR.T_VEC, IR.NEG_VEC, [normVar], fn newNormVar =>
676                            gotoWithArgs(env, [newNormVar], nextBlk)
677                          )),
678                      (* else *)                      (* else *)
679                      letPRIM(retNorm,                        letPRIM(retNorm, IR.T_VEC, IR.NORM, [subVec], fn newNormVar =>
680                        IR.T_VEC,                          gotoWithArgs(env, [newNormVar], nextBlk)
681                            IR.SCALE,                      )))))
                           [IR.newConst("negOne", IR.C_FLOAT ~1.0), psvToIRVar(env, normal)],  
                           fn newNormVar => gotoWithArgs(state, [newNormVar], nextBlk))  
                    )  
                  )  
682    
683             | P.D_SPHERE{center, irad, orad} => let             | _ => raise Fail("Cannot find normal to point of specified domain." ^ (P.dToStr d))
684                val PS{pos, ...} = state           (* end case *))
               in  
                     letPRIM("sv", IR.T_VEC, IR.SUB_VEC, [pos, psvToIRVar(env, center)], fn subVec =>  
                 letPRIM(retNorm, IR.T_VEC, IR.NORM, [subVec], fn newNormVar => k newNormVar state  
                     ))  
685                end                end
686    
687             | _ => raise Fail("Cannot find normal to point of specified domain.")          fun trExpr(expr, env, k : IR.var -> ir_env -> IR.stmt) = (case expr
688              of P.CONSTF f => k (IR.newConst ("c", IR.C_FLOAT f)) env
689    
690           | P.CONST3F v => k (IR.newConst ("c", IR.C_VEC v)) env
691    
692           | P.VAR v => k (psvToIRVar (env, v)) env
693    
694           | P.STATE_VAR sv => k (pssvToIRVar (env, sv)) env
695    
696           | P.GENERATE3F (dom, dist) => genVecVar("genVec", env, dom, dist, fn var => k var env)
697    
698           | P.GENERATEF (dom, dist) => genFloatVar("genFlt", env, dom, dist, fn var => k var env)
699    
700           | P.ADD(e1, e2) =>
701             trExpr(e1, env, fn e1var => fn env' =>
702             trExpr(e2, env', fn e2var => fn env'' =>
703             let
704              val IR.V{varType=vt1, ...} = e1var
705              val IR.V{varType=vt2, ...} = e2var
706             in
707              (case (vt1, vt2)
708                of (IR.T_FLOAT, IR.T_FLOAT) => letPRIM("addVar", IR.T_FLOAT, IR.ADD, [e1var, e2var], fn var => k var env'')
709                 | (IR.T_VEC, IR.T_VEC) => letPRIM("addVar", IR.T_VEC, IR.ADD_VEC, [e1var, e2var], fn var => k var env'')
710                 | _ => raise Fail ("Type mismatch to ADD expression")
711              (* end case *))
712             end))
713    
714           | P.SCALE (e1, e2) =>
715             trExpr(e1, env, fn e1var => fn env' =>
716             trExpr(e2, env', fn e2var => fn env'' =>
717             let
718              val IR.V{varType=vt1, ...} = e1var
719              val IR.V{varType=vt2, ...} = e2var
720             in
721              (case (vt1, vt2)
722                of (IR.T_FLOAT, IR.T_VEC) => letPRIM("scaleVar", IR.T_VEC, IR.SCALE, [e1var, e2var], fn var => k var env'')
723                 | (IR.T_FLOAT, IR.T_FLOAT) => letPRIM("scaleVar", IR.T_FLOAT, IR.MULT, [e1var, e2var], fn var => k var env'')
724                 | _ => raise Fail (String.concat["Type mismatch to SCALE expression: ", IR.ty2Str vt1, ", ", IR.ty2Str vt2])
725              (* end case *))
726             end))
727    
728           | P.DIV (e1, e2) =>
729             trExpr(e1, env, fn e1var => fn env' =>
730             trExpr(e2, env', fn e2var => fn env'' =>
731             let
732              val IR.V{varType=vt1, ...} = e1var
733              val IR.V{varType=vt2, ...} = e2var
734             in
735              (case (vt1, vt2)
736                of (IR.T_FLOAT, IR.T_FLOAT) => letPRIM("divVar", IR.T_FLOAT, IR.DIV, [e1var, e2var], fn var => k var env'')
737                 | _ => raise Fail (String.concat["Type mismatch to DIV expression: ", IR.ty2Str vt1, ", ", IR.ty2Str vt2])
738           (* end case *))           (* end case *))
739             end))
740    
741           | P.NEG e =>
742             trExpr(e, env, fn evar => fn env' =>
743             let
744              val IR.V{varType, ...} = evar
745             in
746              (case varType
747                of IR.T_FLOAT => letPRIM("negVar", IR.T_FLOAT, IR.MULT, [evar, IR.newConst("negOne", IR.C_FLOAT ~1.0)], fn var => k var env')
748                 | IR.T_VEC => letPRIM("negVar", IR.T_VEC, IR.NEG_VEC, [evar], fn var => k var env')
749                 | _ => raise Fail ("Type mismatch to NEG expression")
750              (* end case *))
751             end)
752    
753           | P.DOT (e1, e2) =>
754             trExpr(e1, env, fn e1var => fn env' =>
755             trExpr(e2, env', fn e2var => fn env'' =>
756             let
757              val IR.V{varType=vt1, ...} = e1var
758              val IR.V{varType=vt2, ...} = e2var
759             in
760              (case (vt1, vt2)
761                of (IR.T_VEC, IR.T_VEC) => letPRIM("dotVar", IR.T_FLOAT, IR.DOT, [e1var, e2var], fn var => k var env'')
762                 | _ => raise Fail ("Type mismatch to DOT expression")
763              (* end case *))
764             end))
765    
766           | P.CROSS (e1, e2) =>
767             trExpr(e1, env, fn e1var => fn env' =>
768             trExpr(e2, env', fn e2var => fn env'' =>
769             let
770              val IR.V{varType=vt1, ...} = e1var
771              val IR.V{varType=vt2, ...} = e2var
772             in
773              (case (vt1, vt2)
774                of (IR.T_VEC, IR.T_VEC) => letPRIM("crossVar", IR.T_VEC, IR.CROSS, [e1var, e2var], fn var => k var env'')
775                 | _ => raise Fail ("Type mismatch to CROSS expression")
776              (* end case *))
777             end))
778    
779           | P.NORMALIZE e =>
780             trExpr(e, env, fn evar => fn env' =>
781             let
782              val IR.V{varType, ...} = evar
783             in
784              (case varType
785                of IR.T_VEC => letPRIM("normVar", IR.T_VEC, IR.NORM, [evar], fn var => k var env')
786                 | _ => raise Fail ("Type mismatch to NORMALIZE expression")
787              (* end case *))
788             end)
789    
790           | P.LENGTH e =>
791             trExpr(e, env, fn evar => fn env' =>
792             let
793              val IR.V{varType, ...} = evar
794             in
795              (case varType
796                of IR.T_VEC => letPRIM("lenVar", IR.T_FLOAT, IR.LEN, [evar], fn var => k var env')
797                 | _ => raise Fail ("Type mismatch to LENGTH expression")
798              (* end case *))
799             end)
800    
801           (* !SPEED! We're assuming that there is an intersection here... *)
802           | P.INTERSECT {p1, p2, d} =>
803             trExpr(p1, env, fn p1var => fn env' =>
804             trExpr(p2, env', fn p2var => fn env'' =>
805             let
806              val IR.V{varType=vt1, ...} = p1var
807              val IR.V{varType=vt2, ...} = p2var
808             in
809              (case (vt1, vt2)
810                of (IR.T_VEC, IR.T_VEC) => mkIntPt(env, p1var, p2var, d, fn var => k var env'')
811                 | _ => raise Fail("Type mismatch to INTERSECT expression")
812              (* end case *))
813             end))
814    
815           | P.NORMALTO (e, d) =>
816             trExpr(e, env, fn evar => fn env' =>
817             let
818              val IR.V{varType, ...} = evar
819              fun cont s = k s
820             in
821              (case varType
822                of IR.T_VEC => normAtPoint("normVar", d, env', evar, k)
823                 | _ => raise Fail("Type mismatch to NORMALTO expression")
824              (* end case *))
825             end)
826    
827              (* end case expr *))
828    
829            (* generate code to produce a random particle state from a domain *)
830        fun newParticle (sv_gens, env, k : ir_env -> IR.stmt) = let
831    
832          fun createVar(P.GEN{var, ...}) = let
833            val P.PSV.SV{name, ty, ...} = var
834           in
835            IR.newLocal("ps_" ^ name, IR.psvTyToIRTy ty, (IR.RAND, []))
836          end          end
837    
838          fun trEmitter(emit, env, state, k : particle_state -> IR.stmt) = let        val newState = List.map createVar sv_gens
839    
840            val PS{isDead, ...} = state        fun genVar((sv_gen, var), cont) = let
841            val P.EMIT{maxNum, posDomain, velDomain, colDomain, ...} = emit          val P.GEN{exp, var=svar} = sv_gen
842            val blk = newBlock (env, k)          val IR.V{varType, ...} = var
843           in           in
844            fn env' => trExpr(exp, env', fn newVal => fn env'' => cont (insertSVar(env'', svar, newVal)))
845           end (* genVar *)
846    
847         in
848          (List.foldr (fn (x, y) => genVar(x, y)) k (ListPair.zipEq (sv_gens, newState))) env
849         end (* new particle *)
850    
851        fun trEmitter(emit, env, k) = let
852          val P.EMIT{freq, sv_gens} = emit
853          val ttl = pssvToIRVar(env, P.sv_ttl)
854         in
855          letPRIM("isDead", IR.T_BOOL, IR.GT, [IR.newConst("small", IR.C_FLOAT 0.1), ttl], fn isDead =>
856        IR.mkIF(isDead,        IR.mkIF(isDead,
857         (* then *)         (* then *)
858         letPRIM("t1", IR.T_FLOAT, IR.ITOF, [psvToIRVar (env, maxNum)], fn t1 =>         trExpr(freq, env, fn t1 => fn env' =>
859         letPRIM("t2", IR.T_FLOAT, IR.ITOF, [psvToIRVar (env, numDead)], fn t2 =>         letPRIM("t2", IR.T_FLOAT, IR.ITOF, [psvToIRVar (env', PSV.numDead)], fn t2 =>
860         letPRIM("prob", IR.T_FLOAT, IR.DIV, [t1, t2], fn prob =>         letPRIM("prob", IR.T_FLOAT, IR.DIV, [t1, t2], fn prob =>
861         letPRIM("r", IR.T_FLOAT, IR.RAND, [], fn r =>         letPRIM("r", IR.T_FLOAT, IR.RAND, [], fn r =>
862         letPRIM("t3", IR.T_BOOL, IR.GT, [prob, r], fn t3 =>         letPRIM("t3", IR.T_BOOL, IR.GT, [prob, r], fn t3 =>
863         IR.mkIF(t3,         IR.mkIF(t3,
864          (* then *)          (* then *)
865          newParticle (posDomain, velDomain, colDomain, env,          newParticle (sv_gens, env', fn env'' => k env''),
          fn state' => retState state'),  
866          (* else *)          (* else *)
867          IR.DISCARD)))))),          IR.DISCARD)))))),
868         (* else *)         (* else *)
869         retState state)         k env))
      end  
   
         fun trPred(pred, env, state, thenk : particle_state -> IR.stmt, elsek : particle_state -> IR.stmt) = let  
           val PS{pos, vel, ...} = state  
           val P.PR{ifstmt, ...} = pred  
          in  
           case ifstmt  
            of P.WITHIN(d) => mkWithinVar("wv", env, pos, d, fn withinVar =>  
             IR.mkIF(withinVar, thenk(state), elsek(state)))  
             | P.WITHINVEL(d) => mkWithinVar("wv", env, vel, d, fn withinVar =>  
             IR.mkIF(withinVar, thenk(state), elsek(state)))  
          end  
   
     fun trAct (action, env, state, k : particle_state -> IR.stmt) = let  
           val PS{pos, vel, size, isDead, color, dummy} = state  
           in  
             case action  
              of P.BOUNCE{friction, resilience, cutoff, d} => let  
                   val blk = newBlock (env, k)  
                   val negOne = IR.newConst("negOne", IR.C_FLOAT ~1.0)  
                   in  
                     letPRIM("vs", IR.T_VEC, IR.SCALE, [psvToIRVar(env, timeStep), vel], fn velScale =>  
                     letPRIM("np", IR.T_VEC, IR.ADD_VEC, [pos, velScale], fn nextPos =>  
                     mkWithinVar("wnp", env, pos, d, fn withinNextPos =>  
                     IR.mkIF(withinNextPos,  
                       (*then*)  
                         normAtPoint("n", d, env, state, fn normAtD => fn state' => let  
                val PS{pos=nextPos, vel=nextVel, size=nextSize, isDead=nextIsDead, color=nextColor, dummy=nextDummy} = state'  
                           in  
                            letPRIM("negVel", IR.T_VEC, IR.SCALE, [negOne, nextVel], fn negVel =>  
                            letPRIM("dnv", IR.T_FLOAT, IR.DOT, [negVel, normAtD], fn dotNegVel =>  
                            letPRIM("sn", IR.T_VEC, IR.SCALE, [dotNegVel, normAtD], fn scaledN =>  
                            letPRIM("t", IR.T_VEC, IR.SUB_VEC, [negVel, scaledN], fn tang =>  
   
                            letPRIM("tlsq", IR.T_FLOAT, IR.LEN_SQ, [tang], fn tangLenSq =>  
                            letPRIM("cosq", IR.T_FLOAT, IR.MULT, [psvToIRVar(env, cutoff), psvToIRVar(env, cutoff)], fn cutoffSq =>  
                            letPRIM("inco", IR.T_BOOL, IR.GT, [tangLenSq, cutoffSq], fn inCutoff =>  
   
                            letPRIM("resNorm", IR.T_VEC, IR.SCALE, [psvToIRVar(env, resilience), scaledN], fn resNorm =>  
   
                            IR.mkIF(inCutoff,  
                              (*then*)  
                              letPRIM("fInv", IR.T_FLOAT, IR.SUB, [IR.newConst("one", IR.C_FLOAT 1.0), psvToIRVar(env, friction)], fn frictInv =>  
                              letPRIM("f", IR.T_FLOAT, IR.MULT, [negOne, frictInv], fn modFrict =>  
                              letPRIM("fTang", IR.T_VEC, IR.SCALE, [modFrict, tang], fn frictTang =>  
                              letPRIM("newVel", IR.T_VEC, IR.ADD_VEC, [frictTang, resNorm], fn newVel =>  
                               goto(PS{pos=nextPos, vel=newVel, size=nextSize, isDead=nextIsDead, color=nextColor, dummy=nextDummy}, blk)  
                             )))),  
                              (*else*)  
                              letPRIM("fTang", IR.T_VEC, IR.SCALE, [negOne, tang], fn frictTang =>  
                              letPRIM("newVel", IR.T_VEC, IR.ADD_VEC, [frictTang, resNorm], fn newVel =>  
                               goto(PS{pos=nextPos, vel=newVel, size=nextSize, isDead=nextIsDead, color=nextColor, dummy=nextDummy}, blk)  
                              ))  
                          )))))))))  
                          end  
                       ),  
                       (*else*)  
                       goto(state, blk)))))  
870                    end                    end
871    
872                | P.GRAVITY(dir) =>      (* trExpr(expr, env, state, k : IR.var -> IR.stmt) *)
873                      letPRIM("scaledVec", IR.T_VEC, IR.SCALE, [psvToIRVar(env, timeStep), psvToIRVar(env, dir)], fn theScale =>      (* mkFloatWithinVar (boolVar, env, var, d : Float.float P.domain, stmt : IR.var -> IR.stmt) *)
874                      letPRIM("nextVel", IR.T_VEC, IR.ADD_VEC, [theScale, vel], fn newVel =>      fun trPred(cond, env, thenk : ir_env -> IR.stmt, elsek : ir_env -> IR.stmt) = let
875                        k(PS{pos = pos, vel = newVel, size = size, isDead = isDead, color = color, dummy=dummy})))        fun grabVar(cond, env, k : IR.var -> ir_env -> IR.stmt) = (case cond
876            of P.WITHINF(d, expr) =>
877                | P.MOVE =>              trExpr(expr, env, fn checkMe => fn env' =>
878                  letPRIM("scaledVec", IR.T_VEC, IR.SCALE, [psvToIRVar(env, timeStep), vel], fn theScale =>              mkFloatWithinVar("wv", env', checkMe, d, fn var => k var env'))
879                      letPRIM("nextPos", IR.T_VEC, IR.ADD_VEC, [theScale, pos], fn newPos =>  
880                        k(PS{pos = newPos, vel = vel, size = size, isDead = isDead, color = color, dummy=dummy})))           | P.WITHIN3F(d, expr) =>
881                (*              trExpr(expr, env, fn checkMe => fn env' =>
882                | P.SINK({d, kill_inside}) =>              mkVecWithinVar("wv", env', checkMe, d, fn var => k var env'))
883                      mkWithinVar("isWithin", env, state, d, fn withinVal =>  
884                      mkXOR ("shouldNotKill", withinVal, psvToIRVar(env, kill_inside),           | P.DO_INTERSECT {p1, p2, d} =>
885                        fn shouldNotKill =>             trExpr(p1, env, fn p1var => fn env' =>
886                      letPRIM("shouldKill", IR.T_BOOL, IR.NOT, [shouldNotKill], fn shouldKill =>             trExpr(p2, env', fn p2var => fn env'' =>
887                      letPRIM("isReallyDead", IR.T_BOOL, IR.OR, [shouldKill, isDead], fn isReallyDead =>             mkIntBool(env'', p1var, p2var, d, k)))
888                      k(PS{pos = pos, vel = vel, size = size, isDead = isReallyDead, color = color})  
889                          ))))           | P.GTHAN (e1, e2) =>
890                *)             trExpr(e1, env, fn e1var => fn env' =>
891               trExpr(e2, env, fn e2var => fn env'' =>
892               letPRIM("gtVar", IR.T_BOOL, IR.GT, [e1var, e2var], fn var => k var env'')))
893    
894             | P.AND(c1, c2) =>
895               grabVar(c1, env, fn c1Var => fn env' =>
896               grabVar(c2, env', fn c2Var => fn env'' =>
897               letPRIM("andVar", IR.T_BOOL, IR.AND, [c1Var, c2Var], fn var => k var env'')))
898    
899             | P.OR(c1, c2) =>
900               grabVar(c1, env, fn c1Var => fn env' =>
901               grabVar(c2, env, fn c2Var => fn env'' =>
902               letPRIM("andVar", IR.T_BOOL, IR.OR, [c1Var, c2Var], fn var => k var env'')))
903    
904             | P.XOR(c1, c2) =>
905               grabVar(c1, env, fn c1Var => fn env' =>
906               grabVar(c2, env', fn c2Var => fn env'' =>
907               mkXOR ("xorVar", c1Var, c2Var, fn var => k var env'')))
908    
909             | P.NOT(c) =>
910               grabVar(c, env, fn cvar => fn env' =>
911               letPRIM("notVar", IR.T_BOOL, IR.NOT, [cvar], fn var => k var env'))
912    
913                | P.ORBITLINESEG {endp1, endp2, maxRad, mag} => let          (* end case *))
                   val blk = newBlock (env, k)  
914                  in                  in
915                  letPRIM("subVec", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, endp2), psvToIRVar(env, endp1)], fn subVec =>        grabVar(cond, env, fn result => fn env' =>
916                  letPRIM("vecToEndP", IR.T_VEC, IR.SUB_VEC, [pos, psvToIRVar(env, endp1)], fn vecToEndP =>        IR.mkIF(result, thenk(env'), elsek(env')))
                 letPRIM("basis", IR.T_VEC, IR.NORM, [subVec], fn basis =>  
                 letPRIM("parDot", IR.T_FLOAT, IR.DOT, [basis, vecToEndP], fn parDot =>  
                 letPRIM("parVec", IR.T_VEC, IR.SCALE, [parDot, basis], fn parVec =>  
                 letPRIM("closestP", IR.T_VEC, IR.ADD_VEC, [psvToIRVar(env, endp1), parVec], fn closestP =>  
                 letPRIM("vecToP", IR.T_VEC, IR.SUB_VEC, [closestP, pos], fn vecToP =>  
                 letPRIM("distToP", IR.T_FLOAT, IR.LEN, [vecToP], fn distToP =>  
                 letPRIM("effRad", IR.T_FLOAT, IR.SUB, [psvToIRVar(env, maxRad), distToP], fn effRad =>  
                 letPRIM("radInDist", IR.T_BOOL, IR.GT, [psvToIRVar(env, epsilon), effRad], fn radInDist =>  
                 IR.mkIF(radInDist,  
                   (*then*)  
                   goto(state, blk),  
                   (*else*)  
                   letPRIM("magRatio", IR.T_FLOAT, IR.DIV, [distToP, psvToIRVar(env, maxRad)], fn magRatio =>  
                   letPRIM("oneMinMR", IR.T_FLOAT, IR.SUB, [IR.newConst("one", IR.C_FLOAT 1.0), magRatio], fn oneMinMR =>  
                   letPRIM("gravityMag", IR.T_FLOAT, IR.MULT, [oneMinMR, psvToIRVar(env, mag)], fn gravityMag =>  
                   letPRIM("totalMag", IR.T_FLOAT, IR.MULT, [gravityMag, psvToIRVar(env, timeStep)], fn totMag =>  
                   letPRIM("accVec", IR.T_VEC, IR.SUB_VEC, [closestP, pos], fn accVec =>  
                   letPRIM("acc", IR.T_VEC, IR.SCALE, [totMag, accVec], fn acc =>  
                   letPRIM("newVel", IR.T_VEC, IR.ADD_VEC, [vel, acc], fn newVel =>  
                   goto(PS{pos = pos, vel = newVel, size = size, isDead = isDead, color = color, dummy=dummy}, blk)  
                   )))))))  
                 )))))))))))  
                 end  
   
               (* just kill it. *)  
               (* | P.DIE => k(PS{pos = pos, vel = vel, size = size, isDead = IR.newConst("falseVar", IR.C_BOOL true), color = color, dummy=dummy}) *)  
               | P.DIE => IR.DISCARD  
               | _ => raise Fail("Action not implemented...")  
             (* end case *)  
917            end            end
918    
919      fun compile (P.PG{      fun compile (P.PG{
920         emit as P.EMIT{maxNum, vars=emitVars, ...},         emit as P.EMIT{freq, sv_gens}, act, render,
921         act as P.PSAE{action=root_act, vars=actionVars},         vars, state_vars, render_vars
        render  
922      }) = let      }) = let
923            val blks = ref[]            val blks = ref[]
924            val env = let  
925          fun printVar (PSV.V{name, id, ...}) =
926            printErr (String.concat[name, ": ", Int.toString id])
927    
928          val v_env = let
929                (* add special globals to free vars *)                (* add special globals to free vars *)
930                  val vars = PSV.Set.union(emitVars, PSV.Set.addList(actionVars, [maxNum, numDead, timeStep, epsilon]))          val pgm_vars = PSV.Set.union(PSV.Set.singleton epsilon, vars)
931                  fun ins (x as PSV.V{name, ty, binding, id, ...}, map) = let          fun insv (x as PSV.V{name, ty, binding, id, ...}, map) = let
932                        val x' = (case (ty, !binding)                        val x' = (case (ty, !binding)
933                               of (PSV.T_BOOL,  PSV.UNDEF) => IR.newGlobal(x, IR.T_BOOL)                               of (PSV.T_BOOL,  PSV.UNDEF) => IR.newGlobal(x, IR.T_BOOL)
934                                | (PSV.T_BOOL,  PSV.BOOL boolVal) => IR.newConst(name, IR.C_BOOL(boolVal))                                | (PSV.T_BOOL,  PSV.BOOL boolVal) => IR.newConst(name, IR.C_BOOL(boolVal))
# Line 547  Line 938 
938                                | (PSV.T_FLOAT, PSV.FLOAT floatVal) => IR.newConst(name, IR.C_FLOAT(floatVal))                                | (PSV.T_FLOAT, PSV.FLOAT floatVal) => IR.newConst(name, IR.C_FLOAT(floatVal))
939                                | (PSV.T_VEC3F, PSV.UNDEF) => IR.newGlobal(x, IR.T_VEC)                                | (PSV.T_VEC3F, PSV.UNDEF) => IR.newGlobal(x, IR.T_VEC)
940                                | (PSV.T_VEC3F, PSV.VEC3F vecVal) => IR.newConst(name, IR.C_VEC(vecVal))                                | (PSV.T_VEC3F, PSV.VEC3F vecVal) => IR.newConst(name, IR.C_VEC(vecVal))
941                                | _ => raise Fail("Error in setup, type mismatch between IR and PSV vars.")                 | _ => raise Fail("Error in setup, type mismatch between PSV vars and their binding.")
942                              (* end case *))                              (* end case *))
943                        in                        in
944                          PSV.Map.insert (map, x, x')                          PSV.Map.insert (map, x, x')
945                        end                   end (* ins *)
                 in  
                   TE(blks, PSV.Set.foldl ins PSV.Map.empty vars)  
                 end  
946    
947               in
948                    PSV.Set.foldl insv PSV.Map.empty pgm_vars
949               end (* env *)
950    
951            fun evalActs f [] state = f [] state        fun evalActs theAct env f = (case theAct
             | evalActs f (psa :: psal) state = (case psa  
952                of P.SEQ(acts) => (case acts                of P.SEQ(acts) => (case acts
953                   of [] => raise Fail "Should never reach here."                  of [] => f env
954                    | [act] => trAct(act, env, state, evalActs f psal)                   | oneAct :: rest => evalActs oneAct env (fn env' => (evalActs (P.SEQ(rest)) env' f))
                   | act :: rest => trAct(act, env, state, evalActs f (P.SEQ(rest) :: psal))  
955                  (* end case *))                  (* end case *))
956                 | P.PRED(pred as P.PR{thenstmt=t, elsestmt=e, ...}) => let  
957                     val cblk = newBlock(env, evalActs f psal)                 | P.PRED(cond, thenAct, elseAct) => let
958                     fun trPredActs [] state' = goto(state', cblk)                     val joinBlk = newBlock (env, fn env' => f env')
959                       | trPredActs _ _ = raise Fail "Should never reach here."                     fun joinActs env = goto(env, joinBlk)
960                      in
961                       trPred(cond, env,
962                         fn env' => evalActs thenAct env' joinActs,
963                         fn env' => evalActs elseAct env' joinActs
964                       )
965                      end
966    
967                   | P.DIE => IR.DISCARD
968    
969                   | P.ASSIGN(sv, expr) => let
970                     val PSV.SV{name, ty, ...} = sv
971                    in                    in
972                     trPred(pred, env, state, evalActs trPredActs t, evalActs trPredActs e)                   trExpr(expr, env, fn newVar => fn env' =>
973                     letPRIM("ps_" ^ name, IR.psvTyToIRTy ty, IR.COPY, [newVar],
974                       fn thisVar => f (insertSVar(env', sv, thisVar))))
975                    end                    end
976    
977                (* end case *))                (* end case *))
978    
979            (* At the highest level, we want to return when we reach the end of the action list *)            val sv_env = let
980            fun trActs [] state = let                (* add special globals to free vars *)
981                  val PS{pos, vel, size, isDead, color, dummy} = state          fun insv (x as PSV.SV{name, ty, ...}, map) = let
982              val x' = IR.newParam("ps_" ^ name, IR.psvTyToIRTy ty)
983                  in                  in
984                    IR.mkRETURN[ pos, vel, size, isDead, color, dummy ]                    IR.setRenderVar(x', PSV.SVMap.inDomain(render_vars, x));
985                  end (* trActs *)                    PSV.SVMap.insert (map, x, x')
986              | trActs _ _ = raise Fail "Should never reach here"                   end (* ins *)
987    
988               in
989                    PSV.SVSet.foldl insv PSV.SVMap.empty state_vars
990               end (* env *)
991    
992              val env = TE(blks, v_env, sv_env)
993    
994            (* The entry block is the first block of the program, or in other words, the emitter. *)            (* The entry block is the first block of the program, or in other words, the emitter. *)
995            val entryBlock = newBlock (            val emitterBlock = newBlock (env, fn env => trEmitter(emit, env, retState))
996              env,            val physicsBlock = newBlock (env, fn env => evalActs act env retState)
             fn pstate => trEmitter(  
               emit,  
               env,  
               pstate,  
               fn state => evalActs trActs root_act state  
             )  
           )  
997    
998            (* The entry block is the emitter, and the rest of the blocks define the physics processing. *)            (* The entry block is the emitter, and the rest of the blocks define the physics processing. *)
999    
1000          fun isGlobal(IR.V{scope, ...}) = (case scope
1001            of IR.S_GLOBAL(v) => true
1002             | _ => false
1003            (* end case *))
1004    
1005            val outPgm = PSysIR.PGM {            val outPgm = PSysIR.PGM {
1006              emitter = entryBlock,              globals = PSV.Map.filter isGlobal v_env,
1007              physics = List.drop(!blks, 1),          emitter = emitterBlock,
1008                physics = physicsBlock,
1009              render = render              render = render
1010            }            }
1011    
1012            val optimized = if (Checker.checkIR(outPgm)) then Optimize.optimizeIR(outPgm) else outPgm            val optimized = if (Checker.checkIR(outPgm)) then (printErr "\nPre-optimization complete."; Optimize.optimizeIR(outPgm)) else outPgm
   
1013            in            in
1014              IR.outputPgm(TextIO.stdErr, outPgm);              (* Note: it only succeeds if we can optimize, too *)
1015              if Checker.checkIR(optimized) then          if Checker.checkIR(optimized) then printErr "Compilation succeeded." else ();
1016               printErr "Compilation succeeded." (* Note: it only succeeds if we can optimize, too *)  
             else  
              ();  
             IR.outputPgm(TextIO.stdErr, optimized);  
1017              optimized              optimized
1018            end (* compile *)            end (* compile *)
1019    

Legend:
Removed from v.873  
changed lines
  Added in v.1160

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