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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1174 - (view) (download)

1 : pavelk 746 (* translate.sml
2 : pavelk 1108
3 : pavelk 746 * COPYRIGHT (c) 2009 John Reppy (http://cs.uchicago.edu/~jhr)
4 :     * All rights reserved.
5 :     *
6 :     * Translate a particle system to the IR.
7 :     *)
8 :    
9 :     structure Translate : sig
10 :    
11 : pavelk 1174 val compile : Particles.program * PSEnv.env -> PSysIR.program
12 : pavelk 746
13 :     end = struct
14 :    
15 :     open SML3dTypeUtil
16 :    
17 :     structure P = ParticlesImp
18 :     structure PSV = P.PSV
19 :     structure IR = PSysIR
20 : pavelk 770
21 :     fun printErr s = TextIO.output(TextIO.stdErr, s ^ "\n")
22 : pavelk 746
23 :     (* special PSV global variables *)
24 :     val epsilon = PSV.constf(0.00001)
25 :    
26 :     (* constants *)
27 :     val pi = 3.14159265358979
28 : pavelk 870
29 : pavelk 746 (* translation environment *)
30 : pavelk 1147 datatype ir_env = TE of (IR.block list ref * IR.var PSV.Map.map * IR.var PSV.SVMap.map)
31 :     fun insertVar (TE(blks, v_env, sv_env), x, x') = TE(blks, PSV.Map.insert (v_env, x, x'), sv_env)
32 : pavelk 1150 fun insertSVar (TE(blks, v_env, sv_env), x, x') = (case (PSV.SVMap.find (sv_env, x))
33 :     of NONE => raise Fail("Changing mapping to state var that doesn't exist.")
34 :     | SOME var => (
35 :     IR.setRenderVar(x', IR.isRenderVar var);
36 :     TE(blks, v_env, PSV.SVMap.insert (sv_env, x, x'))
37 :     )
38 :     (* end case *))
39 : pavelk 746
40 : pavelk 1147 fun retState (TE(_, _, sv_env)) = IR.mkRETURN (PSV.SVMap.listItems sv_env)
41 :    
42 :     (* Interaction with environment and psys variables *)
43 :     fun psvToIRVar (TE(_, env, _), x as PSV.V{name, id, ...}) = (case PSV.Map.find(env, x)
44 : pavelk 746 of SOME x' => x'
45 : pavelk 770 | NONE => raise Fail (String.concat["unknown variable ", name, " with ID ", Int.toString id])
46 : pavelk 1108 (* end case *))
47 : pavelk 746
48 : pavelk 1147 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 : pavelk 1109 (* create a block that implements the given continuation *)
54 : pavelk 1147 fun newBlockWithArgs (env as TE(blks, _, sv_env), args, k : ir_env -> IR.stmt) = let
55 : pavelk 1109 fun copyVar(v as IR.V{name, varType, ...}) = IR.newParam(name, varType)
56 : pavelk 1147 val newState = List.map copyVar (PSV.SVMap.listItems sv_env)
57 :     fun inssv((oldv, newv), TE(theBlks, v_env, svenv)) = let
58 :     val theKey =
59 :     List.find
60 :     (fn v => IR.varEq(PSV.SVMap.lookup(svenv, v), oldv))
61 : pavelk 1150 (PSV.SVMap.listKeys svenv)
62 :     val sv = (case theKey
63 :     of SOME x => x
64 : pavelk 1147 | NONE => raise Fail("Trying to create new mapping for variable that doesn't already exist.")
65 :     (* end case *))
66 : pavelk 1150 in
67 :     IR.setRenderVar(newv, IR.isRenderVar oldv);
68 :     TE(theBlks, v_env, PSV.SVMap.insert(svenv, sv, newv))
69 : pavelk 1147 end
70 :    
71 :     val blk = IR.newBlock (
72 :     newState @ args,
73 :     k (List.foldl inssv env
74 :     (ListPair.zipEq
75 :     (PSV.SVMap.listItems sv_env, newState)
76 :     )
77 :     )
78 :     )
79 : pavelk 746 in
80 : pavelk 1107 blks := blk :: !blks;
81 :     blk
82 : pavelk 746 end
83 :    
84 : pavelk 1147 fun newBlock (env, k) = newBlockWithArgs(env, [], k)
85 : pavelk 746
86 :     fun letPRIM (x, ty, p, args, body) = let
87 :     val x' = IR.newLocal(x, ty, (p, args))
88 :     in
89 :     IR.mkPRIM(x', p, args, body x')
90 :     end
91 :    
92 : pavelk 1150 fun gotoWithArgs(TE(_, _, env), args, blk) = let
93 :    
94 :     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
103 :     List.app copyRenderVar (ListPair.zipEq (vars, varCopies));
104 :     ListPair.foldr mkCopy (IR.mkGOTO(blk, varCopies)) (varCopies, vars)
105 :     end
106 :    
107 :     fun goto (env, blk) = gotoWithArgs(env, [], blk)
108 :    
109 :    
110 : pavelk 746 (* 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
112 : pavelk 1147 * stores it in result. *)
113 : pavelk 746 fun mkXOR (result, var1, var2, stmt : IR.var -> IR.stmt) =
114 :     letPRIM("testOR", IR.T_BOOL, IR.OR, [var1, var2], fn testOR =>
115 :     letPRIM("testAND", IR.T_BOOL, IR.AND, [var1, var2], fn testAND =>
116 :     letPRIM("testNAND", IR.T_BOOL, IR.NOT, [testAND], fn testNAND =>
117 :     letPRIM(result, IR.T_BOOL, IR.AND, [testOR, testNAND], stmt))))
118 : pavelk 1167
119 :     fun ptToLine(pt, p1, p2, k : IR.var -> IR.stmt) =
120 :     letPRIM("p1ToPt", IR.T_VEC, IR.SUB_VEC, [pt, p1], fn p1ToPt =>
121 :     letPRIM("v", IR.T_VEC, IR.SUB_VEC, [p2, p1], fn v =>
122 :     letPRIM("vLenSq", IR.T_FLOAT, IR.DOT, [v, v], fn vLenSq =>
123 :     letPRIM("p1ToPtDotV", IR.T_FLOAT, IR.DOT, [p1ToPt, v], fn p1ToPtDotV =>
124 :     letPRIM("t", IR.T_FLOAT, IR.DIV, [p1ToPtDotV, vLenSq], fn t => k t)))))
125 :    
126 :     (* Find the closest position between two line segments. This solves the system of
127 :     * equations that's generated by having the line connecting the closest points and
128 :     * the dot products of the direction of the two lines equal to zero. We assume that p1 != p2 and
129 :     * q1 != q2. The resulting continuation passes line segment 1's closest point percent along
130 :     * p2 - p1, and then line segment 2's. *)
131 :     fun closestPtBetweenTwoSegs(env, p1, p2, q1, q2, k : IR.var -> IR.var -> ir_env -> IR.stmt) = let
132 :     val zeroConst = IR.newConst("zero", IR.C_FLOAT 0.0)
133 :     val tParam = IR.newParam("t", IR.T_FLOAT)
134 :     val sParam = IR.newParam("s", IR.T_FLOAT)
135 :     val contBlk = newBlockWithArgs(env, [tParam, sParam], k tParam sParam)
136 :     in
137 :     letPRIM("u", IR.T_VEC, IR.SUB_VEC, [q2, q1], fn u =>
138 :     letPRIM("v", IR.T_VEC, IR.SUB_VEC, [p2, p1], fn v =>
139 :     letPRIM("uCrossV", IR.T_VEC, IR.CROSS, [u, v], fn uCrossV =>
140 :     letPRIM("uCrossVLenSq", IR.T_FLOAT, IR.DOT, [uCrossV, uCrossV], fn uCrossVLenSq =>
141 :     letPRIM("pToQ", IR.T_VEC, IR.SUB_VEC, [q1, p1], fn pToQ =>
142 :     letPRIM("intersect", IR.T_BOOL, IR.GT, [psvToIRVar(env, epsilon), uCrossVLenSq], fn intersect =>
143 :     IR.mkIF(intersect,
144 :     (* then *)
145 :     letPRIM("pToQDotV", IR.T_VEC, IR.DOT, [pToQ, v], fn pToQDotV =>
146 :     letPRIM("vLenSq", IR.T_FLOAT, IR.DOT, [v, v], fn vLenSq =>
147 :     letPRIM("t", IR.T_FLOAT, IR.DIV, [pToQDotV, vLenSq], fn t =>
148 :     gotoWithArgs(env, [t, zeroConst], contBlk)
149 :     ))),
150 :     (* else *)
151 :     letPRIM("qToP", IR.T_VEC, IR.SUB_VEC, [p1, q1], fn qToP =>
152 :     letPRIM("pToQCrossU", IR.T_VEC, IR.CROSS, [pToQ, u], fn pToQCrossU =>
153 :     letPRIM("qToPCrossV", IR.T_VEC, IR.CROSS, [qToP, v], fn qToPCrossV =>
154 :     letPRIM("vCrossU", IR.T_VEC, IR.NEG_VEC, [uCrossV], fn vCrossU =>
155 :     letPRIM("tNum", IR.T_FLOAT, IR.DOT, [pToQCrossU, vCrossU], fn tNum =>
156 :     letPRIM("t", IR.T_FLOAT, IR.DIV, [tNum, uCrossVLenSq], fn t =>
157 :     letPRIM("sNum", IR.T_FLOAT, IR.DOT, [qToPCrossV, uCrossV], fn sNum =>
158 :     letPRIM("s", IR.T_FLOAT, IR.DIV, [sNum, uCrossVLenSq], fn s =>
159 :     gotoWithArgs(env, [t, s], contBlk)
160 :     )))))))))
161 :     ))))))
162 :     end
163 :    
164 : pavelk 1017 fun genFloatVar (fltVar, env, domain : Float.float P.domain, dist, stmt : IR.var -> IR.stmt) = let
165 :     fun genRandVal(var, stmt : IR.var -> IR.stmt) = (case dist
166 :     of P.DIST_UNIFORM =>
167 :     letPRIM(var, IR.T_FLOAT, IR.RAND, [], stmt)
168 :    
169 :     (* The PDF here is f(x) = 2x when 0 < x <= 1, so the CDF is going
170 :     * to be the integral of f from 0 -> y => y^2. Hence, whenever we
171 :     * generate a random number, in order to get the random value according
172 : pavelk 1147 * to this probability distribution, we just square it. *)
173 : pavelk 1017 | P.DIST_INC_LIN =>
174 :     letPRIM("randVal", IR.T_FLOAT, IR.RAND, [], fn randVal =>
175 :     letPRIM(var, IR.T_FLOAT, IR.MULT, [randVal, randVal], stmt))
176 :    
177 :     (* The PDF here is f(x) = -2x + 2 when 0 <= x < 1, so the CDF is going
178 :     * to be the integral of f from 0 -> y => -(y^2) + 2y. Hence, whenever we
179 :     * generate a random number, in order to get the random value according
180 :     * to this probability distribution, we just square it.
181 :     *)
182 :     | P.DIST_DEC_LIN =>
183 :     letPRIM("randVal", IR.T_FLOAT, IR.RAND, [], fn randVal =>
184 :     letPRIM("randSq", IR.T_FLOAT, IR.MULT, [randVal, randVal], fn randSq =>
185 :     letPRIM("termOne", IR.T_FLOAT, IR.MULT, [randSq, IR.newConst("negOne", IR.C_FLOAT ~1.0)], fn termOne =>
186 :     letPRIM("termTwo", IR.T_FLOAT, IR.MULT, [randVal, IR.newConst("negOne", IR.C_FLOAT 2.0)], fn termTwo =>
187 :     letPRIM(var, IR.T_FLOAT, IR.ADD, [termOne, termTwo], stmt)
188 :     ))))
189 :    
190 : pavelk 1132 | _ => raise Fail "Unable to create random float for specified distribution"
191 : pavelk 1017 (* end case *))
192 :     in
193 :     (case domain
194 :     of P.D_POINT(pt) =>
195 :     (* Our options here are pretty limited... *)
196 :     letPRIM (fltVar, IR.T_FLOAT, IR.COPY, [psvToIRVar(env, pt)], stmt)
197 :    
198 :     | P.D_BOX{max, min} =>
199 :     genRandVal("randf", fn rand =>
200 :     letPRIM("boxDiff", IR.T_FLOAT, IR.SUB, [psvToIRVar(env, max), psvToIRVar(env, max)], fn diff =>
201 :     letPRIM("scale", IR.T_FLOAT, IR.MULT, [diff, rand], fn scale =>
202 :     letPRIM( fltVar, IR.T_FLOAT, IR.ADD, [psvToIRVar(env, max), scale], stmt )
203 :     )))
204 : pavelk 1132 | _ => raise Fail ("Cannot generate float in specified domain: " ^ (P.dToStr domain))
205 : pavelk 1017 (* end case *))
206 :     end
207 :    
208 : pavelk 746 (* Generates a random vector within the given domain and puts it in vecVar *)
209 : pavelk 1108 fun genVecVar (
210 :     vecVar,
211 :     env,
212 :     domain : Vec3f.vec3 P.domain,
213 :     dist : Vec3f.vec3 P.distribution,
214 :     stmt : IR.var -> IR.stmt
215 :     ) = (case domain
216 : pavelk 1167 of P.D_POINT(pt) => (
217 :     (* Our options here are pretty limited... *)
218 :     printErr "Warning: Generating values from a point is identical to providing a constant value.";
219 :     letPRIM (vecVar, IR.T_VEC, IR.COPY, [psvToIRVar(env, pt)], stmt))
220 : pavelk 746
221 :     | P.D_LINE({pt1, pt2}) =>
222 : pavelk 1131
223 :     (* Lerp between the points. *)
224 :     letPRIM ("randVal", IR.T_FLOAT, IR.RAND, [], fn randVal =>
225 :     letPRIM ("randInv", IR.T_FLOAT, IR.SUB, [IR.newConst("one", IR.C_FLOAT 1.0), randVal], fn randInv =>
226 :     letPRIM ("pt1s", IR.T_VEC, IR.SCALE, [randVal, psvToIRVar(env, pt1)], fn pt1ScaleVec =>
227 :     letPRIM ("pt2s", IR.T_VEC, IR.SCALE, [randInv, psvToIRVar(env, pt2)], fn pt2ScaleVec =>
228 :     letPRIM (vecVar, IR.T_VEC, IR.ADD_VEC, [pt1ScaleVec, pt2ScaleVec], stmt)))))
229 : pavelk 746
230 : pavelk 873 | P.D_BOX{max, min} =>
231 :     (* Extract the componentwise vector variables *)
232 :     letPRIM("minX", IR.T_FLOAT, IR.EXTRACT_X, [psvToIRVar(env, min)], fn minX =>
233 :     letPRIM("maxX", IR.T_FLOAT, IR.EXTRACT_X, [psvToIRVar(env, max)], fn maxX =>
234 :     letPRIM("minY", IR.T_FLOAT, IR.EXTRACT_Y, [psvToIRVar(env, min)], fn minY =>
235 :     letPRIM("maxY", IR.T_FLOAT, IR.EXTRACT_Y, [psvToIRVar(env, max)], fn maxY =>
236 :     letPRIM("minZ", IR.T_FLOAT, IR.EXTRACT_Z, [psvToIRVar(env, min)], fn minZ =>
237 :     letPRIM("maxZ", IR.T_FLOAT, IR.EXTRACT_Z, [psvToIRVar(env, max)], fn maxZ =>
238 :    
239 :     (* Find the distance in each component *)
240 :     letPRIM("distX", IR.T_FLOAT, IR.SUB, [maxX, minX], fn distX =>
241 :     letPRIM("distY", IR.T_FLOAT, IR.SUB, [maxY, minY], fn distY =>
242 :     letPRIM("distZ", IR.T_FLOAT, IR.SUB, [maxZ, minZ], fn distZ =>
243 :    
244 :     (* Get three random numbers for each of the components *)
245 :     letPRIM("randX", IR.T_FLOAT, IR.RAND, [], fn randX =>
246 :     letPRIM("randY", IR.T_FLOAT, IR.RAND, [], fn randY =>
247 :     letPRIM("randZ", IR.T_FLOAT, IR.RAND, [], fn randZ =>
248 :    
249 :     (* Scale the distances by these random numbers *)
250 :     letPRIM("scaledX", IR.T_FLOAT, IR.MULT, [randX, distX], fn scaledX =>
251 :     letPRIM("scaledY", IR.T_FLOAT, IR.MULT, [randY, distY], fn scaledY =>
252 :     letPRIM("scaledZ", IR.T_FLOAT, IR.MULT, [randZ, distZ], fn scaledZ =>
253 :    
254 :     (* Add them to the minimum vec in order to create a new vec inside
255 :     * of the box.
256 :     *)
257 :     letPRIM("newX", IR.T_FLOAT, IR.ADD, [minX, scaledX], fn newX =>
258 :     letPRIM("newY", IR.T_FLOAT, IR.ADD, [minY, scaledY], fn newY =>
259 :     letPRIM("newZ", IR.T_FLOAT, IR.ADD, [minZ, scaledZ], fn newZ =>
260 :    
261 :     (* Gen the vector *)
262 :     letPRIM(vecVar, IR.T_VEC, IR.GEN_VEC, [newX, newY, newZ], stmt
263 :    
264 :     )))))))))))))))))))
265 :    
266 : pavelk 746
267 : pavelk 1131 | P.D_TRIANGLE{pt1, pt2, pt3} =>
268 :    
269 :     letPRIM ("pt1ToPt2", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt2), psvToIRVar(env, pt1)], fn pt1ToPt2 =>
270 :     letPRIM ("pt1ToPt3", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt3), psvToIRVar(env, pt1)], fn pt1ToPt3 =>
271 :     letPRIM ("randOne", IR.T_FLOAT, IR.RAND, [], fn rand1 =>
272 :     letPRIM ("randTwo", IR.T_FLOAT, IR.RAND, [], fn rand2 =>
273 :     letPRIM ("randTwoInv", IR.T_FLOAT, IR.SUB, [IR.newConst("one", IR.C_FLOAT 1.0), rand2], fn rand2Inv =>
274 :     letPRIM ("scaleOne", IR.T_VEC, IR.SCALE, [rand1, pt1ToPt2], fn scale1 =>
275 :     letPRIM ("nextScale1", IR.T_VEC, IR.SCALE, [rand2Inv, scale1], fn nextScale1 =>
276 :     letPRIM ("scaleTwo", IR.T_VEC, IR.SCALE, [rand2, pt1ToPt3], fn scale2 =>
277 :     letPRIM ("tempAdd", IR.T_VEC, IR.ADD_VEC, [psvToIRVar(env, pt1), nextScale1], fn tempAdd =>
278 :     letPRIM (vecVar, IR.T_VEC, IR.ADD_VEC, [tempAdd, scale2], stmt))))))))))
279 : pavelk 1160
280 :     | P.D_PLANE _ => raise Fail ("Cannot generate point in plane because domain is unbounded.")
281 :    
282 :     | P.D_RECT{pt, htvec, wdvec} =>
283 :    
284 :     letPRIM ("randOne", IR.T_FLOAT, IR.RAND, [], fn rand1 =>
285 :     letPRIM ("randTwo", IR.T_FLOAT, IR.RAND, [], fn rand2 =>
286 :     letPRIM ("htScale", IR.T_VEC, IR.SCALE, [rand1, psvToIRVar(env, htvec)], fn htScale =>
287 :     letPRIM ("wdScale", IR.T_VEC, IR.SCALE, [rand2, psvToIRVar(env, wdvec)], fn wdScale =>
288 :     letPRIM ("overTheRiver", IR.T_VEC, IR.ADD_VEC, [psvToIRVar(env, pt), htScale], fn stepOne =>
289 :     letPRIM (vecVar, IR.T_VEC, IR.ADD_VEC, [stepOne, wdScale], stmt)
290 :     )))))
291 : pavelk 746
292 :     | P.D_CYLINDER {pt1, pt2, irad, orad} => let
293 :     val normVar = PSV.new("local_ht", PSV.T_VEC3F)
294 :     in
295 :     letPRIM("rand", IR.T_FLOAT, IR.RAND, [], fn ourRand =>
296 :     letPRIM("n", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt2), psvToIRVar(env, pt1)], fn normVec =>
297 :     letPRIM("ht", IR.T_FLOAT, IR.LEN, [normVec], fn height =>
298 :     letPRIM("htInv", IR.T_FLOAT, IR.DIV, [IR.newConst("one", IR.C_FLOAT 1.0), height], fn htInv =>
299 :     letPRIM("n", IR.T_VEC, IR.SCALE, [htInv, normVec], fn norm =>
300 :     (* Generate a point in the lower disc. *)
301 : pavelk 1109 genVecVar("ptInDisc",
302 : pavelk 1147 insertVar(env, normVar, norm),
303 : pavelk 1109 P.D_DISC{pt = pt1, normal = normVar, irad = irad, orad = orad},
304 :     dist,
305 :     fn ptInDisc =>
306 : pavelk 746 (* Now add this point to a random scaling of the normVec. *)
307 :     letPRIM("s", IR.T_FLOAT, IR.MULT, [height, ourRand], fn scale =>
308 :     letPRIM("sn", IR.T_VEC, IR.SCALE, [scale, normVec], fn scaledNormVec =>
309 :     letPRIM(vecVar, IR.T_VEC, IR.ADD_VEC, [ptInDisc, scaledNormVec], stmt)))))))))
310 :     end
311 : pavelk 1131
312 : pavelk 1160 | P.D_DISC {pt, normal, irad, orad} => let
313 :     val up = IR.newConst("up", IR.C_VEC (Vec3f.pack (0.0, 1.0, 0.0)))
314 :     in
315 : pavelk 1131
316 :     (* Get a random angle... *)
317 :     letPRIM ("r", IR.T_FLOAT, IR.RAND, [], fn randForAng =>
318 :     letPRIM ("t", IR.T_FLOAT, IR.MULT, [randForAng, IR.newConst("fullCir", IR.C_FLOAT (2.0 * pi))], fn randAng =>
319 :    
320 : pavelk 1161 (* Get a random radius
321 :     *
322 :     * Take into account the spherical distribution over that interval
323 :     * with respect to the irad. The correct way to do it is as follows:
324 :     * - Suppose rand() uniformly generates a point in the interval [0, 1]
325 :     * - Let r = (irad / orad) ^ 2
326 :     * - Let p = (rand() * (1 - r))
327 :     * - The proper random point that we should return is then:
328 :     * irad + (sqrt(p) * (orad - irad))
329 :     *)
330 :    
331 :     letPRIM ("radRatio", IR.T_FLOAT, IR.DIV, [psvToIRVar(env, irad), psvToIRVar(env, orad)], fn radRatio =>
332 :     letPRIM ("r", IR.T_FLOAT, IR.MULT, [radRatio, radRatio], fn r =>
333 :     letPRIM ("radInterval", IR.T_FLOAT, IR.SUB, [IR.newConst("one", IR.C_FLOAT 1.0), r], fn radInterval =>
334 : pavelk 1131 letPRIM ("e0", IR.T_FLOAT, IR.RAND, [], fn newRand =>
335 : pavelk 1161 letPRIM ("p", IR.T_FLOAT, IR.MULT, [newRand, radInterval], fn p =>
336 :     letPRIM ("sqrtP", IR.T_FLOAT, IR.SQRT, [p], fn sqrtP =>
337 : pavelk 1131 letPRIM ("radDiff", IR.T_FLOAT, IR.SUB, [psvToIRVar(env, orad), psvToIRVar(env, irad)], fn radDiff =>
338 : pavelk 1161 letPRIM ("newRadDist", IR.T_FLOAT, IR.MULT, [sqrtP, radDiff], fn newRadDist =>
339 : pavelk 1131 letPRIM ("newRad", IR.T_FLOAT, IR.ADD, [psvToIRVar(env, irad), newRadDist], fn newRad =>
340 :    
341 : pavelk 1160 (* Build vector in unit disc *)
342 :     letPRIM("sinRandAng", IR.T_FLOAT, IR.SIN, [randAng], fn randSin =>
343 :     letPRIM("cosRandAng", IR.T_FLOAT, IR.COS, [randAng], fn randCos =>
344 :     letPRIM("unitV", IR.T_VEC, IR.GEN_VEC, [randCos, IR.newConst("zero", IR.C_FLOAT 0.0), randSin], fn unitV =>
345 :     letPRIM("genV", IR.T_VEC, IR.SCALE, [newRad, unitV], fn genV =>
346 : pavelk 1131
347 : pavelk 1160 (* Figure out angle and axis of rotation for disc. *)
348 :     letPRIM("rotVec", IR.T_VEC, IR.CROSS, [psvToIRVar(env, normal), up], fn rotVec =>
349 :     letPRIM("dotN", IR.T_FLOAT, IR.DOT, [psvToIRVar(env, normal), up], fn cosRotAng =>
350 :     letPRIM("rotAng", IR.T_FLOAT, IR.ACOS, [cosRotAng], fn rotAng =>
351 : pavelk 1131
352 : pavelk 1160 (* Rotate our unit vector that we generated so that it lies in the same plane as the
353 :     * disc using the following formula:
354 :     *
355 :     * Given a vector v to rotate about an axis r by angle a, the resulting vector is
356 :     * (v - dot(v, r) * r) cos(a) + cross(v, r) * sin(a) + dot(v, r) * r
357 :     *)
358 :     letPRIM ("vDotR", IR.T_FLOAT, IR.DOT, [genV, rotVec], fn vDotR =>
359 :     letPRIM ("vPara", IR.T_VEC, IR.SCALE, [vDotR, rotVec], fn vPara =>
360 :     letPRIM ("vPerp", IR.T_VEC, IR.SUB_VEC, [genV, vPara], fn vPerp =>
361 :     letPRIM ("vCrossR", IR.T_VEC, IR.CROSS, [genV, rotVec], fn vCrossR =>
362 :     (* cosA is cosRotAng *)
363 :     letPRIM ("sinA", IR.T_FLOAT, IR.SIN, [rotAng], fn sinRotAng =>
364 :     letPRIM ("scaleCross", IR.T_VEC, IR.SCALE, [sinRotAng, vCrossR], fn scaleCross =>
365 :     letPRIM ("scalePerp", IR.T_VEC, IR.SCALE, [cosRotAng, vPerp], fn scalePerp =>
366 :     letPRIM ("scaleAdd", IR.T_VEC, IR.ADD_VEC, [scalePerp, scaleCross], fn scaleAdd =>
367 :     letPRIM ("result", IR.T_VEC, IR.ADD_VEC, [scaleAdd, vPara], fn result =>
368 :    
369 : pavelk 1131 letPRIM (vecVar, IR.T_VEC, IR.ADD_VEC, [result, psvToIRVar(env, pt)], stmt)
370 : pavelk 1161 )))))))))))))))))))))))))))
371 : pavelk 1160 end
372 :    
373 :     (* In order to generate a normal distribution in a cone you need to choose a hight whose
374 :     * density is proportional to the area of the corresponding disc cross-section. The way
375 :     * I did this is by choosing a uniformly random area (basically the sqrt of a random
376 :     * variable) and then generating a uniformly distributed point in the corresponding
377 :     * cross section. I'm not 100% sure that this is the right way to do it, but it's definitely
378 :     * better than what I was doing before (check the SVN logs) *)
379 : pavelk 1131 | P.D_CONE{pt1, pt2, irad, orad} => let
380 :     val normVar = PSV.new("local_ht", PSV.T_VEC3F)
381 : pavelk 1160 val ptVar = PSV.new("local_pt", PSV.T_VEC3F)
382 :     val newORad = PSV.new("local_orad", PSV.T_FLOAT)
383 :     val newIRad = PSV.new("local_irad", PSV.T_FLOAT)
384 : pavelk 1131 in
385 :     letPRIM("eh", IR.T_FLOAT, IR.RAND, [], fn ourRand =>
386 : pavelk 1160 letPRIM("randVal", IR.T_FLOAT, IR.SQRT, [ourRand], fn randVal =>
387 :     letPRIM("randORad", IR.T_FLOAT, IR.MULT, [randVal, psvToIRVar(env, orad)], fn randORad =>
388 :     letPRIM("randIRad", IR.T_FLOAT, IR.MULT, [randVal, psvToIRVar(env, irad)], fn randIRad =>
389 : pavelk 1131 letPRIM("nv", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt2), psvToIRVar(env, pt1)], fn normVec =>
390 :     letPRIM("n", IR.T_VEC, IR.NORM, [normVec], fn norm =>
391 : pavelk 1160 letPRIM("vecToRandPt", IR.T_VEC, IR.SCALE, [randVal, normVec], fn vecToRandPt =>
392 :     letPRIM("discCenter", IR.T_VEC, IR.ADD, [psvToIRVar(env, pt1), vecToRandPt], fn discCenter =>
393 :     genVecVar(vecVar,
394 :     insertVar(insertVar(insertVar(insertVar(env,
395 :     ptVar, discCenter),
396 :     normVar, norm),
397 :     newORad, randORad),
398 :     newIRad, randIRad),
399 :     P.D_DISC{pt = ptVar, normal = normVar, irad = newIRad, orad = newORad},
400 :     dist, stmt)
401 : pavelk 1131 ))))))))
402 :     end
403 : pavelk 1074
404 :     | P.D_SPHERE{center, irad, orad} =>
405 :    
406 : pavelk 1131 (* Source: http://mathworld.wolfram.com/SpherePointPicking.html *)
407 :    
408 :     (* generate two random values... one will be called u and will
409 :     * represent cos(theta), and the other will be called v and will
410 :     * represent a random value in [0, 2 * pi] *)
411 :     letPRIM("randVal", IR.T_FLOAT, IR.RAND, [], fn rv =>
412 :     letPRIM("dblRandVal", IR.T_FLOAT, IR.MULT, [rv, IR.newConst("Two", IR.C_FLOAT 2.0)], fn drv =>
413 :     letPRIM("rand", IR.T_FLOAT, IR.SUB, [drv, IR.newConst("One", IR.C_FLOAT 1.0)], fn u =>
414 :    
415 :     letPRIM("rv2", IR.T_FLOAT, IR.RAND, [], fn rv2 =>
416 :     letPRIM("rand2", IR.T_FLOAT, IR.MULT, [rv2, IR.newConst("TwoPi", IR.C_FLOAT (2.0 * Float.M_PI))], fn theta =>
417 : pavelk 1074
418 : pavelk 1131 letPRIM("cosTheta", IR.T_FLOAT, IR.COS, [theta], fn cosT =>
419 :     letPRIM("sinTheta", IR.T_FLOAT, IR.SIN, [theta], fn sinT =>
420 :    
421 :     letPRIM("usq", IR.T_FLOAT, IR.MULT, [u, u], fn usq =>
422 :     letPRIM("usqInv", IR.T_FLOAT, IR.SUB, [IR.newConst("One", IR.C_FLOAT 1.0), usq], fn usqInv =>
423 :     letPRIM("sinPhi", IR.T_FLOAT, IR.SQRT, [usqInv], fn sinP =>
424 :    
425 :     letPRIM("xVal", IR.T_FLOAT, IR.MULT, [sinP, cosT], fn xVal =>
426 :     letPRIM("yVal", IR.T_FLOAT, IR.MULT, [sinP, sinT], fn yVal =>
427 :     (* zval is just u *)
428 : pavelk 1074
429 : pavelk 1131 letPRIM("vec", IR.T_VEC, IR.GEN_VEC, [xVal, yVal, u], fn vec =>
430 : pavelk 1074
431 :     (* Generate a random radius... *)
432 :     letPRIM("ratio", IR.T_FLOAT, IR.DIV, [psvToIRVar(env, irad), psvToIRVar(env, orad)], fn ratio =>
433 :     letPRIM("invRatio", IR.T_FLOAT, IR.SUB, [IR.newConst("one", IR.C_FLOAT 1.0), ratio], fn invRatio =>
434 :     letPRIM("randVar", IR.T_FLOAT, IR.RAND, [], fn rand =>
435 :     letPRIM("randScale", IR.T_FLOAT, IR.MULT, [rand, invRatio], fn randScale =>
436 :     letPRIM("randVal", IR.T_FLOAT, IR.ADD, [randScale, ratio], fn randVal =>
437 : pavelk 1151 letPRIM("randValSq", IR.T_FLOAT, IR.SQRT, [randVal], fn randValSq =>
438 : pavelk 1074 letPRIM("radDiff", IR.T_FLOAT, IR.SUB, [psvToIRVar(env, orad), psvToIRVar(env, irad)], fn radDiff =>
439 :     letPRIM("randRadVal", IR.T_FLOAT, IR.MULT, [radDiff, randValSq], fn randRadVal =>
440 :     letPRIM("rad", IR.T_FLOAT, IR.ADD, [psvToIRVar(env, irad), randRadVal], fn rad =>
441 :    
442 :     (* Normalize the vector and scale it by the radius. *)
443 :     letPRIM("scaledVec", IR.T_VEC, IR.SCALE, [rad, vec], fn sVec =>
444 :     letPRIM(vecVar, IR.T_VEC, IR.ADD_VEC, [sVec, psvToIRVar(env, center)], stmt)
445 :     ))))))))))
446 : pavelk 1131 )))))))))))))
447 : pavelk 746
448 :     (* end case *))
449 :    
450 :     (* This function takes an IR boolean, its environment, a particle state, domain,
451 :     * and continuation.
452 :     *
453 :     * We set the boolean to whether or not the current particle given by the particle
454 :     * state is within the domain, and then pass the continuation on.
455 :     *)
456 : pavelk 1120 fun mkVecWithinVar (boolVar, env, var, d : Vec3f.vec3 P.domain, stmt : IR.var -> IR.stmt) = let
457 : pavelk 1147 val pos = var
458 : pavelk 746 in
459 :     case d
460 :     of P.D_POINT(pt) =>
461 :     letPRIM("subVec", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt), pos], fn subVec =>
462 : pavelk 1160 letPRIM("vecLen", IR.T_FLOAT, IR.LEN_SQ, [subVec], fn vecLen =>
463 : pavelk 746 letPRIM(boolVar, IR.T_BOOL, IR.GT, [psvToIRVar(env, epsilon), vecLen], stmt)))
464 :    
465 :     (* Take the vectors going from our position to pt1, and pt2. Then
466 :     * after we normalize them, if their dot product is equal to -1, then
467 :     * they are pointing in opposite directions meaning that the position
468 :     * is inbetween pt1 and pt2 as desired.
469 :     *)
470 :     | P.D_LINE{pt1, pt2} =>
471 :     letPRIM("posToPt1", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt1), pos], fn posToPt1 =>
472 :     letPRIM("posToPt1Norm", IR.T_VEC, IR.NORM, [posToPt1], fn posToPt1Norm =>
473 :     letPRIM("posToPt2", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt2), pos], fn posToPt2 =>
474 :     letPRIM("posToPt2Norm", IR.T_VEC, IR.NORM, [posToPt2], fn posToPt2Norm =>
475 :     letPRIM("dot", IR.T_FLOAT, IR.DOT, [posToPt2, posToPt1], fn dotProd =>
476 :     letPRIM("testMe", IR.T_FLOAT, IR.SUB, [dotProd, IR.newConst("negOne", IR.C_FLOAT ~1.0)], fn testVal =>
477 :     letPRIM(boolVar, IR.T_BOOL, IR.GT, [psvToIRVar(env, epsilon), testVal], stmt)))))))
478 :    
479 :     (* Just see whether or not the dot product between the normal
480 :     * and the vector from a point on the plane to our position is
481 :     * greater than zero. Essentially, we're "within" a plane if we're
482 :     * behind it (with respect to the normal)
483 :     *)
484 :     | P.D_PLANE{pt, normal} =>
485 : pavelk 905 letPRIM("posToPt", IR.T_VEC, IR.SUB_VEC, [pos, psvToIRVar(env, pt)], fn posToPt =>
486 : pavelk 746 letPRIM("dot", IR.T_FLOAT, IR.DOT, [posToPt, psvToIRVar(env, normal)], fn dotProd =>
487 :     letPRIM(boolVar, IR.T_BOOL, IR.GT, [dotProd, IR.newConst("zero", IR.C_FLOAT 0.0)], stmt)))
488 :    
489 :     (* Similar to checking to see whether or not we're within a plane,
490 :     * here all we have to do is see how far we are from the center
491 :     * of the disc (pt), and then see whther or not we're perpendicular to
492 :     * the normal, and that our distance is greater than irad but less than
493 :     * orad.
494 :     *)
495 :     | P.D_DISC{pt, normal, orad, irad} =>
496 : pavelk 1133 letPRIM("posToPt", IR.T_VEC, IR.SUB_VEC, [pos, psvToIRVar(env, pt)], fn posToPt =>
497 :     letPRIM("dot", IR.T_FLOAT, IR.DOT, [posToPt, psvToIRVar(env, normal)], fn dotProd =>
498 :     letPRIM("inDisc", IR.T_BOOL, IR.GT, [IR.newConst("small", IR.C_FLOAT 0.01), dotProd], fn inDisc =>
499 :    
500 :     letPRIM("parPosToP", IR.T_VEC, IR.SCALE, [dotProd, psvToIRVar(env, normal)], fn posToPtParallelToNormal =>
501 :     letPRIM("perpPosToP", IR.T_VEC, IR.SUB_VEC, [posToPt, posToPtParallelToNormal], fn posToPtPerpToNormal =>
502 :     letPRIM("inDiscLen", IR.T_FLOAT, IR.LEN, [posToPtPerpToNormal], fn posToPtLen =>
503 :    
504 :     letPRIM("inOradGt", IR.T_BOOL, IR.GT, [psvToIRVar(env, orad), posToPtLen], fn inOradGt =>
505 :     letPRIM("inOradEq", IR.T_BOOL, IR.EQUALS, [psvToIRVar(env, orad), posToPtLen], fn inOradEq =>
506 :     letPRIM("inOrad", IR.T_BOOL, IR.OR, [inOradGt, inOradEq], fn inOrad =>
507 :    
508 :     letPRIM("inIradGt", IR.T_BOOL, IR.GT, [posToPtLen, psvToIRVar(env, irad)], fn inIradGt =>
509 :     letPRIM("inIradEq", IR.T_BOOL, IR.EQUALS, [posToPtLen, psvToIRVar(env, irad)], fn inIradEq =>
510 :     letPRIM("inIrad", IR.T_BOOL, IR.OR, [inIradGt, inIradEq], fn inIrad =>
511 :    
512 :     letPRIM("inBothRad", IR.T_BOOL, IR.AND, [inIrad, inOrad], fn inBothRad =>
513 :    
514 :     letPRIM(boolVar, IR.T_BOOL, IR.AND, [inDisc, inBothRad], stmt))))))))))))))
515 : pavelk 987
516 : pavelk 746 (* Simply see whether or not the distance from the center is within the
517 :     * specified bounds.
518 :     *)
519 :     | P.D_SPHERE{center, orad, irad} =>
520 :     letPRIM("posToPt", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, center), pos], fn posToC =>
521 :     letPRIM("posToPtLen", IR.T_VEC, IR.LEN, [posToC], fn posToCLen =>
522 :     letPRIM("inOrad", IR.T_BOOL, IR.GT, [psvToIRVar(env, orad), posToCLen], fn inOrad =>
523 :     letPRIM("inIrad", IR.T_BOOL, IR.GT, [posToCLen, psvToIRVar(env, irad)], fn inIrad =>
524 :     letPRIM(boolVar, IR.T_BOOL, IR.AND, [inIrad, inOrad], stmt)))))
525 : pavelk 1060
526 :     | P.D_CYLINDER {pt1, pt2, irad, orad} =>
527 :    
528 :     (* !FIXME! Right now, we see whether or not the point is within the two planes defined
529 :     * by the endpoints of the cylinder, and then testing to see whether or not the smallest
530 :     * distance to the line segment falls within the radii. It might be faster to find the
531 :     * closest point to the line defined by the endpoints and then see whether or not the point
532 :     * is within the segment.
533 :     *)
534 :    
535 :     (* Is it in one plane *)
536 :     letPRIM("plane1Norm", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt2), psvToIRVar(env, pt1)], fn plane1Norm =>
537 :     letPRIM("posToPt1", IR.T_VEC, IR.SUB_VEC, [pos, psvToIRVar(env, pt1)], fn posToPt1 =>
538 :     letPRIM("dot1", IR.T_FLOAT, IR.DOT, [posToPt1, plane1Norm], fn dot1Prod =>
539 :     letPRIM("inPlane1", IR.T_BOOL, IR.GT, [dot1Prod, IR.newConst("zero", IR.C_FLOAT 0.0)], fn inPlane1=>
540 :    
541 :     (* Is it in another plane *)
542 :     letPRIM("plane2Norm", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt1), psvToIRVar(env, pt2)], fn plane2Norm =>
543 :     letPRIM("posToPt2", IR.T_VEC, IR.SUB_VEC, [pos, psvToIRVar(env, pt2)], fn posToPt2 =>
544 :     letPRIM("dot2", IR.T_FLOAT, IR.DOT, [posToPt2, plane2Norm], fn dot2Prod =>
545 :     letPRIM("inPlane2", IR.T_BOOL, IR.GT, [dot2Prod, IR.newConst("zero", IR.C_FLOAT 0.0)], fn inPlane2=>
546 :    
547 :     (* Is it in both planes? *)
548 :     letPRIM("inPlanes", IR.T_BOOL, IR.AND, [inPlane1, inPlane2], fn inPlanes =>
549 :    
550 :     (* Find distance from segment *)
551 :     letPRIM("a", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt2), psvToIRVar(env, pt1)], fn a =>
552 :     letPRIM("b", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt1), pos], fn b =>
553 :     letPRIM("alen", IR.T_FLOAT, IR.LEN, [a], fn alen =>
554 :     letPRIM("axb", IR.T_VEC, IR.CROSS, [a, b], fn axb =>
555 :     letPRIM("axblen", IR.T_FLOAT, IR.LEN, [axb], fn axblen =>
556 :     letPRIM("dist", IR.T_FLOAT, IR.DIV, [axblen, alen], fn dist =>
557 :    
558 :     (* Is distance in both radii? *)
559 :     letPRIM("inOradGt", IR.T_BOOL, IR.GT, [psvToIRVar(env, orad), dist], fn inOradGt =>
560 :     letPRIM("inOradEq", IR.T_BOOL, IR.EQUALS, [psvToIRVar(env, orad), dist], fn inOradEq =>
561 :     letPRIM("inOrad", IR.T_BOOL, IR.OR, [inOradGt, inOradEq], fn inOrad =>
562 :    
563 :     letPRIM("inIradGt", IR.T_BOOL, IR.GT, [dist, psvToIRVar(env, irad)], fn inIradGt =>
564 :     letPRIM("inIradEq", IR.T_BOOL, IR.EQUALS, [dist, psvToIRVar(env, irad)], fn inIradEq =>
565 :     letPRIM("inIrad", IR.T_BOOL, IR.OR, [inIradGt, inIradEq], fn inIrad =>
566 :    
567 :     letPRIM("inBothRad", IR.T_BOOL, IR.AND, [inIrad, inOrad], fn inBothRad =>
568 :    
569 :     (* It's in the cylinder (tube) if it's within both radii and in both planes... *)
570 :     letPRIM(boolVar, IR.T_BOOL, IR.AND, [inPlanes, inBothRad], stmt)
571 :     ))))))))))))))))))))))
572 : pavelk 1159
573 : pavelk 1132 | _ => raise Fail ("Cannot determine within-ness for specified vec3 domain: " ^ (P.dToStr d))
574 : pavelk 746 (* end case *)
575 :     end (*end let *)
576 : pavelk 1120
577 :     fun mkFloatWithinVar (boolVar, env, var, d : Float.float P.domain, stmt : IR.var -> IR.stmt) = (case d
578 :     of P.D_POINT(pt) => letPRIM(boolVar, IR.T_BOOL, IR.EQUALS, [psvToIRVar(env, pt), var], stmt)
579 :     | P.D_BOX {min, max} =>
580 :     letPRIM("bigMin", IR.T_BOOL, IR.GT, [var, psvToIRVar(env, min)], fn bigMin =>
581 :     letPRIM("smallMax", IR.T_BOOL, IR.GT, [psvToIRVar(env, max), var], fn smallMax =>
582 :     letPRIM(boolVar, IR.T_BOOL, IR.AND, [bigMin, smallMax], stmt)))
583 : pavelk 1132 | _ => raise Fail ("Cannot determine within-ness for specified float domain: " ^ (P.dToStr d))
584 : pavelk 1120 (* end case *))
585 : pavelk 746
586 : pavelk 1147 fun mkIntBool(env, p1var, p2var, d : Vec3f.vec3 P.domain, k : IR.var -> ir_env -> IR.stmt) = let
587 : pavelk 1108 val _ = ()
588 :     in
589 :     (case d
590 :     of P.D_POINT(pt) =>
591 :    
592 :     (* Get vectors *)
593 :     letPRIM("p1ToPt", IR.T_VEC, IR.SUB_VEC, [psvToIRVar (env, pt), p1var], fn p1ToPt =>
594 :     letPRIM("p1ToP2", IR.T_VEC, IR.SUB_VEC, [p2var, p1var], fn p1ToP2 =>
595 :    
596 : pavelk 1167 (* Are they in the same direction and within the line segment? *)
597 :     letPRIM("cross", IR.T_VEC, IR.CROSS, [p1ToPt, p1ToP2], fn cross =>
598 :     letPRIM("crossLen", IR.T_FLOAT, IR.LEN, [cross], fn crossLen =>
599 :     letPRIM("dot", IR.T_FLOAT, IR.DOT, [p1ToPt, p1ToP2], fn dot =>
600 :     letPRIM("p1ToP2LenSq", IR.T_FLOAT, IR.DOT, [p1ToP2, p1ToP2], fn p1ToP2LenSq =>
601 : pavelk 1108
602 : pavelk 1167 (* Check everything *)
603 :     letPRIM("b1", IR.T_BOOL, IR.GT, [dot, IR.newConst("zero", IR.C_FLOAT 0.0)], fn b1 =>
604 :     letPRIM("b2", IR.T_BOOL, IR.GT, [psvToIRVar(env, epsilon), crossLen], fn b2 =>
605 :     letPRIM("b3", IR.T_BOOL, IR.GT, [p1ToP2LenSq, dot], fn b3 =>
606 :     letPRIM("b1Andb2", IR.T_BOOL, IR.AND, [b1, b2], fn b1Andb2 =>
607 : pavelk 1108
608 : pavelk 1167 letPRIM("intersect", IR.T_BOOL, IR.AND, [b1Andb2, b3], fn intVar => k intVar env)
609 :     ))))
610 :     ))))
611 :     ))
612 : pavelk 1108
613 : pavelk 1167 | P.D_LINE{pt1, pt2} => let
614 :     val boolVar = IR.newParam("intersect", IR.T_BOOL)
615 :     val nextBlk = newBlockWithArgs(env, [boolVar], k boolVar)
616 :     val falseConst = IR.newConst("false", IR.C_BOOL false)
617 :     val zeroConst = IR.newConst("zero", IR.C_FLOAT 0.0)
618 :     in
619 :     letPRIM("v", IR.T_VEC, IR.SUB_VEC, [p2var, p1var], fn v =>
620 :     letPRIM("u", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt2), psvToIRVar(env, pt1)], fn u =>
621 :     letPRIM("vCrossU", IR.T_VEC, IR.CROSS, [v, u], fn vCrossU =>
622 :     letPRIM("vCrossULenSq", IR.T_FLOAT, IR.DOT, [vCrossU, vCrossU], fn vCrossULenSq =>
623 :     letPRIM("parallel", IR.T_BOOL, IR.GT, [psvToIRVar(env, epsilon), vCrossULenSq], fn parallel =>
624 :     IR.mkIF(parallel,
625 :     (* then *)
626 :     gotoWithArgs(env, [falseConst], nextBlk),
627 :     (* else *)
628 :     letPRIM("pt1DotCross", IR.T_FLOAT, IR.DOT, [psvToIRVar(env, pt1), vCrossU], fn pt1DotCross =>
629 :     letPRIM("p1DotCross", IR.T_FLOAT, IR.DOT, [p1var, vCrossU], fn p1DotCross =>
630 :     letPRIM("dotDiff", IR.T_FLOAT, IR.SUB, [pt1DotCross, p1DotCross], fn dotDiff =>
631 :     letPRIM("notSamePlane", IR.T_FLOAT, IR.GT, [dotDiff, psvToIRVar(env, epsilon)], fn notSamePlane =>
632 :     IR.mkIF(notSamePlane,
633 :     (* then *)
634 :     gotoWithArgs(env, [falseConst], nextBlk),
635 :     (* else *)
636 :    
637 :     (* Here we use the separating axis theorem... if the projection of one line
638 :     * segment doesn't overlap either of the initial points of the line segments,
639 :     * then they do not intersect *)
640 :     letPRIM("p1Proj", IR.T_VEC, IR.CROSS, [v, vCrossU], fn p1Proj =>
641 :     letPRIM("p1ToPt1", IR.T_FLOAT, IR.SUB_VEC, [psvToIRVar(env, pt1), p1var], fn p1ToPt1 =>
642 :     letPRIM("p1ToPt2", IR.T_FLOAT, IR.SUB_VEC, [psvToIRVar(env, pt2), p1var], fn p1ToPt2 =>
643 :     letPRIM("p1ProjPt1", IR.T_FLOAT, IR.DOT, [p1Proj, p1ToPt1], fn p1ProjPt1 =>
644 :     letPRIM("p1ProjPt2", IR.T_FLOAT, IR.DOT, [p1Proj, p1ToPt2], fn p1ProjPt2 =>
645 :     letPRIM("domainIntSeg", IR.T_FLOAT, IR.MULT, [p1ProjPt1, p1ProjPt2], fn domainIntSeg =>
646 :     letPRIM("b1", IR.T_BOOL, IR.GT, [zeroConst, domainIntSeg], fn b1 =>
647 :    
648 :     letPRIM("pt1Proj", IR.T_VEC, IR.CROSS, [u, vCrossU], fn pt1Proj =>
649 :     letPRIM("pt1ToP1", IR.T_FLOAT, IR.SUB_VEC, [p1var, psvToIRVar(env, pt1)], fn pt1ToP1 =>
650 :     letPRIM("pt1ToP2", IR.T_FLOAT, IR.SUB_VEC, [p2var, psvToIRVar(env, pt1)], fn pt1ToP2 =>
651 :     letPRIM("pt1ProjP1", IR.T_FLOAT, IR.DOT, [pt1Proj, pt1ToP1], fn pt1ProjP1 =>
652 :     letPRIM("pt1ProjP2", IR.T_FLOAT, IR.DOT, [pt1Proj, pt1ToP2], fn pt1ProjP2 =>
653 :     letPRIM("segIntDomain", IR.T_FLOAT, IR.MULT, [pt1ProjP1, pt1ProjP2], fn segIntDomain =>
654 :     letPRIM("b2", IR.T_BOOL, IR.GT, [zeroConst, segIntDomain], fn b2 =>
655 :    
656 :     letPRIM("intersect", IR.T_BOOL, IR.AND, [b1, b2], fn var => gotoWithArgs(env, [var], nextBlk)
657 :     )))))))))))))))
658 :     )))))
659 :     ))))))
660 :     end
661 : pavelk 1132
662 :     | P.D_PLANE {pt, normal} =>
663 : pavelk 1167
664 : pavelk 1132 letPRIM("d", IR.T_FLOAT, IR.DOT, [psvToIRVar(env, pt), psvToIRVar(env, normal)], fn d =>
665 :     letPRIM("p1d", IR.T_FLOAT, IR.DOT, [p1var, psvToIRVar(env, normal)], fn p1d =>
666 :     letPRIM("p2d", IR.T_FLOAT, IR.DOT, [p2var, psvToIRVar(env, normal)], fn p2d =>
667 :     letPRIM("p1dist", IR.T_FLOAT, IR.SUB, [d, p1d], fn p1dist =>
668 :     letPRIM("p2dist", IR.T_FLOAT, IR.SUB, [d, p2d], fn p2dist =>
669 :     letPRIM("distProd", IR.T_FLOAT, IR.MULT, [p1dist, p2dist], fn distProd =>
670 : pavelk 1147 letPRIM("intersect", IR.T_BOOL, IR.GT, [IR.newConst("zero", IR.C_FLOAT 0.0), distProd], fn intVar => k intVar env)
671 : pavelk 1132 ))))))
672 : pavelk 1169
673 :     | P.D_BOX {min, max} => let
674 :     val zeroConst = IR.newConst("zero", IR.C_FLOAT 0.0)
675 :     fun checkAxis(axis, cont) =
676 :     letPRIM("minAxis", IR.T_FLOAT, IR.DOT, [psvToIRVar(env, min), axis], fn minAxis =>
677 :     letPRIM("maxAxis", IR.T_FLOAT, IR.DOT, [psvToIRVar(env, max), axis], fn maxAxis =>
678 :     letPRIM("p1Axis", IR.T_FLOAT, IR.DOT, [p1var, axis], fn p1Axis =>
679 :     letPRIM("p2Axis", IR.T_FLOAT, IR.DOT, [p2var, axis], fn p2Axis =>
680 :    
681 :     letPRIM("p1mMinAxis", IR.T_FLOAT, IR.SUB, [p1Axis, minAxis], fn p1mMinAxis =>
682 :     letPRIM("p2mMinAxis", IR.T_FLOAT, IR.SUB, [p2Axis, minAxis], fn p2mMinAxis =>
683 :     letPRIM("intMin", IR.T_FLOAT, IR.MULT, [p1mMinAxis, p2mMinAxis], fn intMin =>
684 :     letPRIM("intMinAxis", IR.T_BOOL, IR.GT, [zeroConst, intMin], fn intMinAxis =>
685 :    
686 :     letPRIM("p1mMaxAxis", IR.T_FLOAT, IR.SUB, [p1Axis, maxAxis], fn p1mMaxAxis =>
687 :     letPRIM("p2mMaxAxis", IR.T_FLOAT, IR.SUB, [p2Axis, maxAxis], fn p2mMaxAxis =>
688 :     letPRIM("intMax", IR.T_FLOAT, IR.MULT, [p1mMaxAxis, p2mMaxAxis], fn intMax =>
689 :     letPRIM("intMaxAxis", IR.T_BOOL, IR.GT, [zeroConst, intMax], fn intMaxAxis =>
690 :    
691 :     mkXOR("intAxis", intMinAxis, intMaxAxis, cont)
692 :     ))))
693 :     ))))
694 :     ))))
695 :     in
696 :     checkAxis(IR.newConst("x", IR.C_VEC (Vec3f.pack (1.0, 0.0, 0.0))), fn intXAxis =>
697 :     checkAxis(IR.newConst("y", IR.C_VEC (Vec3f.pack (0.0, 1.0, 0.0))), fn intYAxis =>
698 :     checkAxis(IR.newConst("z", IR.C_VEC (Vec3f.pack (0.0, 0.0, 1.0))), fn intZAxis =>
699 : pavelk 1167
700 : pavelk 1169 letPRIM("xOrY", IR.T_BOOL, IR.OR, [intXAxis, intYAxis], fn xOrY =>
701 :     letPRIM("intersect", IR.T_BOOL, IR.OR, [xOrY, intZAxis], fn var => k var env)))))
702 :     end
703 :    
704 : pavelk 1167 | P.D_RECT {pt, htvec, wdvec} => let
705 :     val boolVar = IR.newParam("intersect", IR.T_BOOL)
706 :     val newBlk = newBlockWithArgs(env, [boolVar], k boolVar)
707 :     fun checkVec(toCheck, vec, k) =
708 :     letPRIM("dot", IR.T_FLOAT, IR.DOT, [toCheck, vec], fn dot =>
709 :     letPRIM("vecLenSq", IR.T_FLOAT, IR.DOT, [vec, vec], fn vecLenSq =>
710 :     letPRIM("dotGTZero", IR.T_BOOL, IR.GT, [dot, IR.newConst("zero", IR.C_FLOAT 0.0)], fn dotGTZero =>
711 :     letPRIM("dotLTVec", IR.T_BOOL, IR.GT, [vecLenSq, dot], fn dotLTVec =>
712 :     letPRIM("within", IR.T_BOOL, IR.AND, [dotGTZero, dotLTVec], fn within => k within)))))
713 :     in
714 :     letPRIM("rectNorm", IR.T_VEC, IR.CROSS, [psvToIRVar(env, htvec), psvToIRVar(env, wdvec)], fn rectNorm =>
715 :     letPRIM("norm", IR.T_VEC, IR.NORM, [rectNorm], fn norm =>
716 :     letPRIM("d", IR.T_FLOAT, IR.DOT, [psvToIRVar(env, pt), norm], fn d =>
717 :     letPRIM("p1d", IR.T_FLOAT, IR.DOT, [p1var, norm], fn p1d =>
718 :     letPRIM("p2d", IR.T_FLOAT, IR.DOT, [p2var, norm], fn p2d =>
719 :     letPRIM("p1dist", IR.T_FLOAT, IR.SUB, [d, p1d], fn p1dist =>
720 :     letPRIM("p2dist", IR.T_FLOAT, IR.SUB, [d, p2d], fn p2dist =>
721 :     letPRIM("distProd", IR.T_FLOAT, IR.MULT, [p1dist, p2dist], fn distProd =>
722 :     letPRIM("earlyOut", IR.T_BOOL, IR.GT, [IR.newConst("zero", IR.C_FLOAT 0.0), distProd], fn earlyOut =>
723 :     IR.mkIF(earlyOut,
724 :     (* then *)
725 :     letPRIM("intersect", IR.T_BOOL, IR.NOT, [earlyOut], fn var => gotoWithArgs(env, [var], newBlk)),
726 :     (* else *)
727 :     letPRIM("v", IR.T_VEC, IR.SUB_VEC, [p2var, p1var], fn v =>
728 :     letPRIM("vDotn", IR.T_FLOAT, IR.DOT, [v, norm], fn vdn =>
729 :     letPRIM("t", IR.T_FLOAT, IR.DIV, [p1dist, vdn], fn t =>
730 :     letPRIM("vscale", IR.T_VEC, IR.SCALE, [t, v], fn vscale =>
731 :     letPRIM("ppt", IR.T_VEC, IR.ADD_VEC, [p1var, vscale], fn ppt =>
732 :     letPRIM("ptToPpt", IR.T_VEC, IR.SUB_VEC, [ppt, psvToIRVar(env, pt)], fn ptToPpt =>
733 :    
734 :     (* Check width *)
735 :     checkVec(ptToPpt, psvToIRVar(env, wdvec), fn withinWd =>
736 :    
737 :     (* Check height *)
738 :     checkVec(ptToPpt, psvToIRVar(env, htvec), fn withinHt =>
739 :    
740 :     letPRIM("intersect", IR.T_BOOL, IR.AND, [withinWd, withinHt], fn var => gotoWithArgs(env, [var], newBlk))
741 :     ))))))))
742 :     ))))))))))
743 :     end
744 :    
745 :     (* Here I'm going to use the "Fast, minimum storage ray/triangle intersection" test by
746 :     * Tomas Moller and Ben Trumbore as presented in the Journal of Graphics Tools,
747 :     * 2(1):21-28, 1997. The algorithm is adapted from "Essential Mathematics for Games
748 :     * and interactive applications", 2nd edition, pages 585-588. *)
749 :     | P.D_TRIANGLE {pt1, pt2, pt3} => let
750 :     val boolVar = IR.newParam("intersect", IR.T_BOOL)
751 :     val newBlk = newBlockWithArgs(env, [boolVar], k boolVar)
752 :     val zeroConst = IR.newConst("zero", IR.C_FLOAT 0.0)
753 :     val oneConst = IR.newConst("one", IR.C_FLOAT 1.0)
754 :     in
755 :     letPRIM("e1", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt2), psvToIRVar(env, pt1)], fn e1 =>
756 :     letPRIM("e2", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt3), psvToIRVar(env, pt1)], fn e2 =>
757 :     letPRIM("p1top2", IR.T_VEC, IR.SUB_VEC, [p2var, p1var], fn p1top2 =>
758 :     letPRIM("p", IR.T_VEC, IR.CROSS, [p1top2, e2], fn p =>
759 :     letPRIM("a", IR.T_FLOAT, IR.DOT, [e1, p], fn a =>
760 :     letPRIM("aCloseZero", IR.T_BOOL, IR.GT, [psvToIRVar(env, epsilon), a], fn aCloseZero =>
761 :     IR.mkIF(aCloseZero,
762 :     (* then *)
763 :     letPRIM("intersect", IR.T_BOOL, IR.NOT, [aCloseZero], fn var => gotoWithArgs(env, [var], newBlk)),
764 :     (* else *)
765 :     letPRIM("denom", IR.T_FLOAT, IR.DIV, [oneConst, a], fn denom =>
766 :    
767 :     letPRIM("s", IR.T_VEC, IR.SUB_VEC, [p1var, psvToIRVar(env, pt1)], fn s =>
768 :     letPRIM("sDotP", IR.T_FLOAT, IR.DOT, [s, p], fn sDotP =>
769 :     letPRIM("u", IR.T_FLOAT, IR.MULT, [sDotP, denom], fn u =>
770 :     letPRIM("uGTZero", IR.T_BOOL, IR.GT, [u, zeroConst], fn uGTZero =>
771 :     letPRIM("uLTOne", IR.T_BOOL, IR.GT, [oneConst, u], fn uLTOne =>
772 :     letPRIM("checkU", IR.T_BOOL, IR.AND, [uGTZero, uLTOne], fn checkU =>
773 :    
774 :     letPRIM("q", IR.T_VEC, IR.CROSS, [s, e1], fn q =>
775 :     letPRIM("dirDotQ", IR.T_FLOAT, IR.DOT, [p1top2, q], fn dirDotQ =>
776 :     letPRIM("v", IR.T_FLOAT, IR.MULT, [dirDotQ, denom], fn v =>
777 :     letPRIM("vPlusU", IR.T_FLOAT, IR.ADD, [v, u], fn vPlusU =>
778 :     letPRIM("vGTZero", IR.T_BOOL, IR.GT, [v, zeroConst], fn vGTZero =>
779 :     letPRIM("vpuLTOne", IR.T_BOOL, IR.GT, [oneConst, vPlusU], fn vpuLTOne =>
780 :     letPRIM("checkV", IR.T_BOOL, IR.AND, [vGTZero, vpuLTOne], fn checkV =>
781 :    
782 :     letPRIM("e2DotQ", IR.T_FLOAT, IR.DOT, [e2, q], fn e2DotQ =>
783 :     letPRIM("t", IR.T_FLOAT, IR.MULT, [e2DotQ, denom], fn t =>
784 : pavelk 1169 letPRIM("tLTOne", IR.T_BOOL, IR.GT, [oneConst, t], fn tLTOne =>
785 :     letPRIM("tGTZero", IR.T_BOOL, IR.GT, [t, zeroConst], fn tGTZero =>
786 :     letPRIM("checkT", IR.T_BOOL, IR.AND, [tLTOne, tGTZero], fn checkT =>
787 : pavelk 1167
788 :     letPRIM("checkUandV", IR.T_BOOL, IR.AND, [checkU, checkV], fn checkUandV =>
789 :     letPRIM("intersect", IR.T_BOOL, IR.AND, [checkUandV, checkT], fn var => gotoWithArgs(env, [var], newBlk)
790 : pavelk 1169 )))))))))))))))))))))
791 : pavelk 1167 )))))))
792 :    
793 :     end
794 : pavelk 1108
795 : pavelk 1132 | P.D_DISC {pt, normal, orad, irad} => let
796 : pavelk 1134 val boolVar = IR.newParam("intersect", IR.T_BOOL)
797 : pavelk 1147 val newBlk = newBlockWithArgs(env, [boolVar], k boolVar)
798 : pavelk 1132 in
799 :     letPRIM("d", IR.T_FLOAT, IR.DOT, [psvToIRVar(env, pt), psvToIRVar(env, normal)], fn d =>
800 :     letPRIM("p1d", IR.T_FLOAT, IR.DOT, [p1var, psvToIRVar(env, normal)], fn p1d =>
801 :    
802 :     (* Early out... does it intersect the plane?
803 :     *
804 :     * !SPEED! Due to the perceived slowness of branching on
805 :     * GPUs, this might not actually be faster on all runtime environments *)
806 :    
807 :     letPRIM("p2d", IR.T_FLOAT, IR.DOT, [p2var, psvToIRVar(env, normal)], fn p2d =>
808 :     letPRIM("p1dist", IR.T_FLOAT, IR.SUB, [d, p1d], fn p1dist =>
809 :     letPRIM("p2dist", IR.T_FLOAT, IR.SUB, [d, p2d], fn p2dist =>
810 :     letPRIM("distProd", IR.T_FLOAT, IR.MULT, [p1dist, p2dist], fn distProd =>
811 :     letPRIM("earlyOut", IR.T_BOOL, IR.GT, [distProd, IR.newConst("zero", IR.C_FLOAT 0.0)], fn earlyOut =>
812 :     IR.mkIF(earlyOut,
813 :     (* then *)
814 : pavelk 1147 letPRIM("intersect", IR.T_BOOL, IR.NOT, [earlyOut], fn var => gotoWithArgs(env, [var], newBlk)),
815 : pavelk 1132 (* else *)
816 :     letPRIM("v", IR.T_VEC, IR.SUB_VEC, [p2var, p1var], fn v =>
817 :     letPRIM("vDotn", IR.T_FLOAT, IR.DOT, [v, psvToIRVar(env, normal)], fn vdn =>
818 :     letPRIM("t", IR.T_FLOAT, IR.DIV, [p1dist, vdn], fn t =>
819 :     letPRIM("vscale", IR.T_VEC, IR.SCALE, [t, v], fn vscale =>
820 :     letPRIM("ppt", IR.T_VEC, IR.ADD_VEC, [p1var, vscale], fn ppt =>
821 :     letPRIM("lenVec", IR.T_VEC, IR.SUB_VEC, [ppt, psvToIRVar(env, pt)], fn cv =>
822 :     letPRIM("len", IR.T_FLOAT, IR.LEN, [cv], fn len =>
823 :    
824 :     (* Check to see whether or not it's within the radius... *)
825 :     letPRIM("gtirad", IR.T_BOOL, IR.GT, [len, psvToIRVar(env, irad)], fn gtirad =>
826 :     letPRIM("ltorad", IR.T_BOOL, IR.GT, [psvToIRVar(env, orad), len], fn ltorad =>
827 : pavelk 1147 letPRIM("intersect", IR.T_BOOL, IR.AND, [gtirad, ltorad], fn var => gotoWithArgs(env, [var], newBlk))
828 : pavelk 1132 ))))))))))
829 :     )))))))
830 :     end (* P.D_DISC *)
831 :    
832 : pavelk 1166 (* To test intersection with the sphere, we first analyze the problem. There can be only one of
833 :     * three situations: either both points are in the sphere, one point is in the sphere and
834 :     * one point is out of the sphere, or both points are out of the sphere.
835 :     *
836 :     * In the first case, the line segment is completely contained in the sphere and hence does
837 :     * not intersect.
838 :     *
839 :     * In the second case, the points necessarily intersect the sphere, by definition. We
840 :     * calculate this via an xor between the two points within the sphere.
841 :     *
842 :     * In the third case, we must find the closest point from the sphere to the line (not the
843 :     * segment). If this point is between the end-points, we must then see whether or not the
844 :     * length to the closest point is smaller than the radius of the sphere. If the closest point
845 :     * on the line is not within the line segment, and both points are outside, then the line
846 :     * segment cannot intersect the sphere.
847 :     *
848 :     * We can perform all of these tests without using a square root and simply by vector
849 :     * operations.
850 :     *
851 :     * !SPEED! Perhaps we don't need to test for irad intersection every time. I.e. it might be
852 :     * faster to make an if-statement that accepts intersection if it intersects with the orad
853 :     * since a lot of use-cases have the irad set to zero.
854 :     *)
855 :    
856 :     | P.D_SPHERE{center, orad, irad} => let
857 :     fun checkRadius(avRatioVar, dOneVar, dTwoVar, radVar, inbVar, cont : IR.var -> IR.stmt) =
858 :     letPRIM("rSq", IR.T_FLOAT, IR.MULT, [radVar, radVar], fn rSq =>
859 :     letPRIM("ptOneInRad", IR.T_BOOL, IR.GT, [rSq, dOneVar], fn bOne =>
860 :     letPRIM("ptTwoInRad", IR.T_BOOL, IR.GT, [rSq, dTwoVar], fn bTwo =>
861 :     letPRIM("segWithinRad", IR.T_BOOL, IR.GT, [rSq, avRatioVar], fn bFive =>
862 :     mkXOR("bOneXORbTwo", bOne, bTwo, fn bOneXORbTwo =>
863 :     letPRIM("bOneANDbTwo", IR.T_BOOL, IR.AND, [bOne, bTwo], fn bOneANDbTwo =>
864 :     letPRIM("inbetweenAndClose", IR.T_BOOL, IR.AND, [inbVar, bFive], fn ibac =>
865 :     letPRIM("notb1andb2", IR.T_BOOL, IR.NOT, [bOneANDbTwo], fn notb1andb2 =>
866 :     letPRIM("testALL", IR.T_BOOL, IR.AND, [notb1andb2, ibac], fn testALL =>
867 :     letPRIM("inrad", IR.T_BOOL, IR.OR, [testALL, bOneXORbTwo], fn result => cont result)
868 :     )))))))))
869 :     in
870 :     letPRIM("dOne", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, center), p1var], fn dOne =>
871 :     letPRIM("dTwo", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, center), p2var], fn dTwo =>
872 :     letPRIM("dOneLenSq", IR.T_FLOAT, IR.DOT, [dOne, dOne], fn dOneLenSq =>
873 :     letPRIM("dTwoLenSq", IR.T_FLOAT, IR.DOT, [dTwo, dTwo], fn dTwoLenSq =>
874 :     letPRIM("v", IR.T_VEC, IR.SUB_VEC, [p2var, p1var], fn v =>
875 :     letPRIM("vLenSq", IR.T_FLOAT, IR.DOT, [v, v], fn vLenSq =>
876 :     letPRIM("t", IR.T_VEC, IR.DOT, [v, dOne], fn t =>
877 :     letPRIM("tGTZero", IR.T_BOOL, IR.GT, [t, IR.newConst("Zero", IR.C_FLOAT 0.0)], fn bThree =>
878 :     letPRIM("tLTvLenSq", IR.T_BOOL, IR.GT, [vLenSq, t], fn bFour =>
879 :     letPRIM("a", IR.T_VEC, IR.CROSS, [v, dOne], fn a =>
880 :     letPRIM("aLenSq", IR.T_FLOAT, IR.DOT, [a, a], fn aLenSq =>
881 :     letPRIM("avRatio", IR.T_FLOAT, IR.DIV, [aLenSq, vLenSq], fn avRatio =>
882 :     letPRIM("inb", IR.T_BOOL, IR.AND, [bThree, bFour], fn inb =>
883 :    
884 :     (* Check the inner radius *)
885 :     checkRadius(avRatio, dOneLenSq, dTwoLenSq, psvToIRVar(env, irad), inb, fn intIrad =>
886 :    
887 :     (* Check the outer radius *)
888 :     checkRadius(avRatio, dOneLenSq, dTwoLenSq, psvToIRVar(env, orad), inb, fn intOrad =>
889 :    
890 :     (* If we intersected either, we intersected the surface *)
891 :     letPRIM("intersect", IR.T_BOOL, IR.OR, [intIrad, intOrad], fn intVar => k intVar env)
892 :     ))
893 :     )))))))))))))
894 :     end
895 :    
896 : pavelk 1132 | _ => raise Fail ("Cannot calculate intersection bool for specified domain: " ^ (P.dToStr d))
897 : pavelk 1108 (* end case *))
898 :    
899 :     end (* mkIntBool *)
900 :    
901 : pavelk 1132 (* We assume that the segment already intersects with the domain. *)
902 : pavelk 1166 fun mkIntPt(env, p1var, p2var, d : Vec3f.vec3 P.domain, k : IR.var -> ir_env -> IR.stmt) = let
903 : pavelk 1167 fun getPlaneIntPt(e, p1, p2, n, pt, cont) =
904 :     letPRIM("d", IR.T_FLOAT, IR.DOT, [pt, n], fn d =>
905 :     letPRIM("p1d", IR.T_FLOAT, IR.DOT, [p1, n], fn p1d =>
906 :     letPRIM("num", IR.T_FLOAT, IR.SUB, [d, p1d], fn num =>
907 :     letPRIM("v", IR.T_VEC, IR.SUB_VEC, [p2, p1], fn v =>
908 :     letPRIM("den", IR.T_FLOAT, IR.DOT, [v, n], fn den =>
909 :     letPRIM("t", IR.T_FLOAT, IR.DIV, [num, den], fn t =>
910 :     letPRIM("vsc", IR.T_VEC, IR.SCALE, [t, v], fn vs =>
911 :     letPRIM("intPt", IR.T_VEC, IR.ADD_VEC, [p1var, vs], fn newVar => cont newVar e)
912 :     )))))))
913 :    
914 : pavelk 1108 in
915 :     (case d
916 : pavelk 1166 of P.D_POINT(pt) => k (psvToIRVar (env, pt)) env
917 : pavelk 1132
918 :     | P.D_PLANE {pt, normal} =>
919 : pavelk 1167 getPlaneIntPt(env, p1var, p2var, psvToIRVar(env, normal), psvToIRVar(env, pt), k)
920 :    
921 :     (* Let's say that we have two segments, p = (p1, p2) and q = (q1, q2). If they are intersecting,
922 :     * then we can project p1 and p2 onto the line perpendicular to (q1, q2) to two points that
923 :     * we will call p1' and p2' respectively. The projection of q will result in a single point
924 :     * that we will call q'. Then, the ratio of p1' to q' and p2' to q' will be identical to
925 :     * the ratio of p1 and p2 to the intersection point of the two segments. *)
926 :     | P.D_LINE{pt1, pt2} =>
927 : pavelk 1132 letPRIM("v", IR.T_VEC, IR.SUB_VEC, [p2var, p1var], fn v =>
928 : pavelk 1167 letPRIM("u", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt2), psvToIRVar(env, pt1)], fn u =>
929 :     letPRIM("vCrossU", IR.T_VEC, IR.CROSS, [v, u], fn vCrossU =>
930 :     letPRIM("perpV", IR.T_VEC, IR.CROSS, [vCrossU, v], fn perpV =>
931 :     letPRIM("perp", IR.T_VEC, IR.NORM, [perpV], fn perp =>
932 :     letPRIM("pToPt1", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt1), p1var], fn pToPt1 =>
933 :     letPRIM("pToPt2", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt2), p1var], fn pToPt2 =>
934 :     letPRIM("dotV1", IR.T_FLOAT, IR.DOT, [pToPt1, perp], fn dotV1 =>
935 :     letPRIM("dotV2", IR.T_FLOAT, IR.DOT, [pToPt2, perp], fn dotV2 =>
936 :     letPRIM("total", IR.T_FLOAT, IR.SUB, [dotV1, dotV2], fn total =>
937 :     letPRIM("t", IR.T_FLOAT, IR.DIV, [dotV1, total], fn t =>
938 :     letPRIM("scaledV", IR.T_VEC, IR.SCALE, [t, v], fn scaledV =>
939 :     letPRIM("intPt", IR.T_VEC, IR.ADD_VEC, [p1var, scaledV], fn newVar => k newVar env)
940 :     ))))))))))))
941 : pavelk 1132
942 : pavelk 1167 (* For discs, rects, and triangles, since we already know they intersect, the intersection
943 :     * point must be just the point that's on the plane... *)
944 :     | P.D_DISC {pt, normal, orad, irad} =>
945 :     getPlaneIntPt(env, p1var, p2var, psvToIRVar(env, normal), psvToIRVar(env, pt), k)
946 :    
947 :     | P.D_RECT {pt, htvec, wdvec} =>
948 :     letPRIM("rectNorm", IR.T_VEC, IR.CROSS, [psvToIRVar(env, htvec), psvToIRVar(env, wdvec)], fn rectNorm =>
949 :     letPRIM("norm", IR.T_VEC, IR.NORM, [rectNorm], fn norm =>
950 :     getPlaneIntPt(env, p1var, p2var, norm, psvToIRVar(env, pt), k)))
951 :    
952 :     | P.D_TRIANGLE {pt1, pt2, pt3} =>
953 :     letPRIM("vecOne", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt2), psvToIRVar(env, pt1)], fn v1 =>
954 :     letPRIM("vecTwo", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt3), psvToIRVar(env, pt1)], fn v2 =>
955 :     letPRIM("triNorm", IR.T_VEC, IR.CROSS, [v1, v2], fn triNorm =>
956 :     letPRIM("norm", IR.T_VEC, IR.NORM, [triNorm], fn norm =>
957 :     getPlaneIntPt(env, p1var, p2var, norm, psvToIRVar(env, pt1), k)))))
958 : pavelk 1166
959 :     (* Parametrically determine the point of intersection. We don't need to worry about what's
960 :     * valid and what's not because we're assuming that the point of intersection exists. *)
961 :     | P.D_SPHERE{center, orad, irad} =>
962 :     letPRIM("dOne", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, center), p1var], fn dOne =>
963 :     letPRIM("dOneLenSq", IR.T_FLOAT, IR.DOT, [dOne, dOne], fn dOneLenSq =>
964 :     letPRIM("v", IR.T_VEC, IR.SUB_VEC, [p2var, p1var], fn v =>
965 :     letPRIM("oRadSq", IR.T_FLOAT, IR.MULT, [psvToIRVar(env, orad), psvToIRVar(env, orad)], fn oRadSq =>
966 :     letPRIM("inS", IR.T_BOOL, IR.GT, [oRadSq, dOneLenSq], fn inS =>
967 :    
968 :     (* Check if we're intersecting the irad... *)
969 :     mkIntBool(env, p1var, p2var, P.sphere{c=center, r=irad}, fn intVar => fn nextEnv => let
970 :    
971 :     fun calcPt (t, v) newEnv =
972 :     letPRIM("scaled", IR.T_VEC, IR.SCALE, [t, v], fn scaled =>
973 :     letPRIM("intPt", IR.T_VEC, IR.ADD, [p1var, scaled], fn newVar => k newVar newEnv))
974 :    
975 :     fun runNewBlk (v, d, rad) newEnv = let
976 :     val vVec = IR.newParam("v", IR.T_VEC)
977 :     val intPct = IR.newParam("intPt", IR.T_FLOAT)
978 :     val contBlk = newBlockWithArgs(newEnv, [intPct, vVec], calcPt (intPct, vVec))
979 :     val twoConst = IR.newConst("Two", IR.C_FLOAT 2.0)
980 :     val zeroConst = IR.newConst("zero", IR.C_FLOAT 0.0)
981 :     in
982 :     letPRIM("a", IR.T_FLOAT, IR.DOT, [v, v], fn a =>
983 :     letPRIM("vDotD", IR.T_FLOAT, IR.DOT, [v, d], fn vDotD =>
984 :     letPRIM("b", IR.T_FLOAT, IR.MULT, [vDotD, twoConst], fn b =>
985 :     letPRIM("dLenSq", IR.T_FLOAT, IR.DOT, [d, d], fn dLenSq =>
986 :     letPRIM("radSq", IR.T_FLOAT, IR.MULT, [rad, rad], fn radSq =>
987 :     letPRIM("c", IR.T_FLOAT, IR.SUB, [dLenSq, radSq], fn c =>
988 :     letPRIM("bSq", IR.T_FLOAT, IR.MULT, [b, b], fn bSq =>
989 :     letPRIM("fourA", IR.T_FLOAT, IR.MULT, [IR.newConst("four", IR.C_FLOAT 4.0), a], fn fourA =>
990 :     letPRIM("fourAC", IR.T_FLOAT, IR.MULT, [fourA, c], fn fourAC =>
991 :     letPRIM("bbac", IR.T_FLOAT, IR.SUB, [bSq, fourAC], fn bbac =>
992 :     letPRIM("sqrtbbac", IR.T_FLOAT, IR.SQRT, [bbac], fn sqrtbbac =>
993 :     letPRIM("negb", IR.T_FLOAT, IR.SUB, [zeroConst, b], fn negB =>
994 :     letPRIM("twoA", IR.T_FLOAT, IR.MULT, [twoConst, a], fn twoA =>
995 :     letPRIM("numOne", IR.T_FLOAT, IR.ADD, [negB, sqrtbbac], fn numOne =>
996 :     letPRIM("numTwo", IR.T_FLOAT, IR.SUB, [negB, sqrtbbac], fn numTwo =>
997 :     letPRIM("vOne", IR.T_FLOAT, IR.DIV, [numOne, twoA], fn vOne =>
998 :     letPRIM("vTwo", IR.T_FLOAT, IR.DIV, [numTwo, twoA], fn vTwo =>
999 :     letPRIM("v1xv2", IR.T_FLOAT, IR.MULT, [vOne, vTwo], fn v1xv2 =>
1000 :     letPRIM("opp", IR.T_BOOL, IR.GT, [zeroConst, v1xv2], fn opp =>
1001 :     IR.mkIF(opp,
1002 :     (* then *)
1003 :     letPRIM("t", IR.T_FLOAT, IR.MAX, [vOne, vTwo], fn t =>
1004 :     gotoWithArgs(newEnv, [t, v], contBlk)),
1005 :     (* else *)
1006 :     letPRIM("t", IR.T_FLOAT, IR.MIN, [vOne, vTwo], fn t =>
1007 :     gotoWithArgs(newEnv, [t, v], contBlk))
1008 :     ))))))))))))))))))))
1009 :     end
1010 :    
1011 :     val vParam = IR.newParam("v", IR.T_VEC)
1012 :     val dParam = IR.newParam("d", IR.T_VEC)
1013 :     val radParam = IR.newParam("rad", IR.T_FLOAT)
1014 :     val checkRadBlk = newBlockWithArgs(nextEnv, [vParam, dParam, radParam], runNewBlk(vParam, dParam, radParam))
1015 :     in
1016 :     letPRIM("checkIrad", IR.T_BOOL, IR.AND, [inS, intVar], fn checkIrad =>
1017 :     IR.mkIF(checkIrad,
1018 :     (* then *)
1019 :     gotoWithArgs(env, [v, dOne, psvToIRVar(nextEnv, irad)], checkRadBlk),
1020 :     (* else *)
1021 :     gotoWithArgs(env, [v, dOne, psvToIRVar(nextEnv, orad)], checkRadBlk)
1022 :     ))
1023 :     end
1024 :     ))))))
1025 :    
1026 : pavelk 1132 | _ => raise Fail ("Cannot calculate intersection point for specified domain: " ^ (P.dToStr d))
1027 : pavelk 1108 (* end case *))
1028 :     end (* mkIntPt *)
1029 :    
1030 : pavelk 746 (* Find the normal at the given position of the particle for the specified
1031 :     * domain. Note, that the particle doesn't necessarily need to be on the
1032 : pavelk 1132 * domain, but if it's not then the behavior is undefined. *)
1033 : pavelk 1147 fun normAtPoint(retNorm, d, env, pos, k : IR.var -> ir_env -> IR.stmt) = let
1034 : pavelk 746 val newNorm = IR.newParam("n", IR.T_VEC)
1035 : pavelk 1147 val nextBlk = newBlockWithArgs(env, [newNorm], k(newNorm))
1036 : pavelk 746 in
1037 :     (case d
1038 : pavelk 1160 of P.D_POINT(pt) =>
1039 :     letPRIM("sv", IR.T_VEC, IR.SUB_VEC, [pos, psvToIRVar(env, pt)], fn subVec =>
1040 :     letPRIM(retNorm, IR.T_VEC, IR.NORM, [subVec], fn newNormVar => k newNormVar env
1041 :     ))
1042 :    
1043 :     | P.D_PLANE{pt, normal} =>
1044 : pavelk 1147 letPRIM("inVec", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt), pos], fn inVec =>
1045 : pavelk 1146 letPRIM("dotNorm", IR.T_FLOAT, IR.DOT, [psvToIRVar(env, normal), inVec], fn dotNorm =>
1046 : pavelk 1151 letPRIM("absDot", IR.T_FLOAT, IR.ABS, [dotNorm], fn absDot =>
1047 :     letPRIM("avoidZero", IR.T_FLOAT, IR.MAX, [psvToIRVar(env, epsilon), absDot], fn dot =>
1048 :     letPRIM("dnRecip", IR.T_FLOAT, IR.DIV, [IR.newConst("One", IR.C_FLOAT 1.0), dot], fn dnRecip =>
1049 :     letPRIM("sign", IR.T_FLOAT, IR.MULT, [dnRecip, dotNorm], fn sign =>
1050 : pavelk 1158 (* sign here can still be zero... *)
1051 :     letPRIM("signOffset", IR.T_FLOAT, IR.ADD, [sign, IR.newConst("half", IR.C_FLOAT 0.5)], fn signOffset =>
1052 :     letPRIM("soRecip", IR.T_FLOAT, IR.DIV, [IR.newConst("One", IR.C_FLOAT 1.0), signOffset], fn soRecip =>
1053 :     letPRIM("absSign", IR.T_FLOAT, IR.ABS, [soRecip], fn absSign =>
1054 :     letPRIM("signFinal", IR.T_FLOAT, IR.MULT, [absSign, signOffset], fn signFinal =>
1055 :    
1056 :     letPRIM("notNorm", IR.T_VEC, IR.SCALE, [signFinal, psvToIRVar(env, normal)], fn notNorm =>
1057 : pavelk 1155 letPRIM(retNorm, IR.T_VEC, IR.NORM, [notNorm],
1058 : pavelk 1151 fn newNormVar => gotoWithArgs(env, [newNormVar], nextBlk)))))
1059 : pavelk 1158 ))))))))
1060 : pavelk 1146
1061 : pavelk 746 | P.D_DISC{pt, normal, irad, orad} =>
1062 : pavelk 1147 normAtPoint(retNorm, P.D_PLANE{pt=pt, normal=normal}, env, pos, k)
1063 : pavelk 746
1064 : pavelk 1109 | P.D_SPHERE{center, irad, orad} =>
1065 : pavelk 746 letPRIM("sv", IR.T_VEC, IR.SUB_VEC, [pos, psvToIRVar(env, center)], fn subVec =>
1066 : pavelk 1160 letPRIM("svLen", IR.T_FLOAT, IR.LEN, [subVec], fn svLen =>
1067 :     letPRIM("inIrad", IR.T_BOOL, IR.GT, [svLen, psvToIRVar(env, irad)], fn inIrad =>
1068 :     IR.mkIF(inIrad,
1069 :     (* then *)
1070 :     letPRIM("norm", IR.T_VEC, IR.NORM, [subVec], fn normVar =>
1071 :     letPRIM(retNorm, IR.T_VEC, IR.NEG_VEC, [normVar], fn newNormVar =>
1072 :     gotoWithArgs(env, [newNormVar], nextBlk)
1073 :     )),
1074 :     (* else *)
1075 :     letPRIM(retNorm, IR.T_VEC, IR.NORM, [subVec], fn newNormVar =>
1076 :     gotoWithArgs(env, [newNormVar], nextBlk)
1077 :     )))))
1078 : pavelk 746
1079 : pavelk 1132 | _ => raise Fail("Cannot find normal to point of specified domain." ^ (P.dToStr d))
1080 : pavelk 746 (* end case *))
1081 :     end
1082 : pavelk 769
1083 : pavelk 1147 fun trExpr(expr, env, k : IR.var -> ir_env -> IR.stmt) = (case expr
1084 :     of P.CONSTF f => k (IR.newConst ("c", IR.C_FLOAT f)) env
1085 : pavelk 1108
1086 : pavelk 1147 | P.CONST3F v => k (IR.newConst ("c", IR.C_VEC v)) env
1087 : pavelk 1108
1088 : pavelk 1147 | P.VAR v => k (psvToIRVar (env, v)) env
1089 : pavelk 1108
1090 : pavelk 1147 | P.STATE_VAR sv => k (pssvToIRVar (env, sv)) env
1091 : pavelk 1108
1092 : pavelk 1147 | P.GENERATE3F (dom, dist) => genVecVar("genVec", env, dom, dist, fn var => k var env)
1093 : pavelk 1108
1094 : pavelk 1147 | P.GENERATEF (dom, dist) => genFloatVar("genFlt", env, dom, dist, fn var => k var env)
1095 : pavelk 1108
1096 : pavelk 1109 | P.ADD(e1, e2) =>
1097 : pavelk 1147 trExpr(e1, env, fn e1var => fn env' =>
1098 :     trExpr(e2, env', fn e2var => fn env'' =>
1099 : pavelk 1108 let
1100 : pavelk 1109 val IR.V{varType=vt1, ...} = e1var
1101 :     val IR.V{varType=vt2, ...} = e2var
1102 : pavelk 1108 in
1103 :     (case (vt1, vt2)
1104 : pavelk 1147 of (IR.T_FLOAT, IR.T_FLOAT) => letPRIM("addVar", IR.T_FLOAT, IR.ADD, [e1var, e2var], fn var => k var env'')
1105 :     | (IR.T_VEC, IR.T_VEC) => letPRIM("addVar", IR.T_VEC, IR.ADD_VEC, [e1var, e2var], fn var => k var env'')
1106 : pavelk 1108 | _ => raise Fail ("Type mismatch to ADD expression")
1107 :     (* end case *))
1108 :     end))
1109 :    
1110 : pavelk 1109 | P.SCALE (e1, e2) =>
1111 : pavelk 1147 trExpr(e1, env, fn e1var => fn env' =>
1112 :     trExpr(e2, env', fn e2var => fn env'' =>
1113 : pavelk 1108 let
1114 : pavelk 1109 val IR.V{varType=vt1, ...} = e1var
1115 :     val IR.V{varType=vt2, ...} = e2var
1116 : pavelk 1108 in
1117 :     (case (vt1, vt2)
1118 : pavelk 1147 of (IR.T_FLOAT, IR.T_VEC) => letPRIM("scaleVar", IR.T_VEC, IR.SCALE, [e1var, e2var], fn var => k var env'')
1119 :     | (IR.T_FLOAT, IR.T_FLOAT) => letPRIM("scaleVar", IR.T_FLOAT, IR.MULT, [e1var, e2var], fn var => k var env'')
1120 : pavelk 1130 | _ => raise Fail (String.concat["Type mismatch to SCALE expression: ", IR.ty2Str vt1, ", ", IR.ty2Str vt2])
1121 : pavelk 1108 (* end case *))
1122 :     end))
1123 :    
1124 : pavelk 1109 | P.DIV (e1, e2) =>
1125 : pavelk 1147 trExpr(e1, env, fn e1var => fn env' =>
1126 :     trExpr(e2, env', fn e2var => fn env'' =>
1127 : pavelk 1108 let
1128 : pavelk 1109 val IR.V{varType=vt1, ...} = e1var
1129 :     val IR.V{varType=vt2, ...} = e2var
1130 : pavelk 1108 in
1131 :     (case (vt1, vt2)
1132 : pavelk 1147 of (IR.T_FLOAT, IR.T_FLOAT) => letPRIM("divVar", IR.T_FLOAT, IR.DIV, [e1var, e2var], fn var => k var env'')
1133 : pavelk 1133 | _ => raise Fail (String.concat["Type mismatch to DIV expression: ", IR.ty2Str vt1, ", ", IR.ty2Str vt2])
1134 : pavelk 1108 (* end case *))
1135 :     end))
1136 : pavelk 866
1137 : pavelk 1109 | P.NEG e =>
1138 : pavelk 1147 trExpr(e, env, fn evar => fn env' =>
1139 : pavelk 1108 let
1140 : pavelk 1109 val IR.V{varType, ...} = evar
1141 : pavelk 1108 in
1142 :     (case varType
1143 : pavelk 1147 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')
1144 :     | IR.T_VEC => letPRIM("negVar", IR.T_VEC, IR.NEG_VEC, [evar], fn var => k var env')
1145 : pavelk 1108 | _ => raise Fail ("Type mismatch to NEG expression")
1146 :     (* end case *))
1147 :     end)
1148 :    
1149 : pavelk 1109 | P.DOT (e1, e2) =>
1150 : pavelk 1147 trExpr(e1, env, fn e1var => fn env' =>
1151 :     trExpr(e2, env', fn e2var => fn env'' =>
1152 : pavelk 1108 let
1153 : pavelk 1109 val IR.V{varType=vt1, ...} = e1var
1154 :     val IR.V{varType=vt2, ...} = e2var
1155 : pavelk 1108 in
1156 :     (case (vt1, vt2)
1157 : pavelk 1147 of (IR.T_VEC, IR.T_VEC) => letPRIM("dotVar", IR.T_FLOAT, IR.DOT, [e1var, e2var], fn var => k var env'')
1158 : pavelk 1108 | _ => raise Fail ("Type mismatch to DOT expression")
1159 :     (* end case *))
1160 :     end))
1161 :    
1162 : pavelk 1109 | P.CROSS (e1, e2) =>
1163 : pavelk 1147 trExpr(e1, env, fn e1var => fn env' =>
1164 :     trExpr(e2, env', fn e2var => fn env'' =>
1165 : pavelk 1108 let
1166 : pavelk 1109 val IR.V{varType=vt1, ...} = e1var
1167 :     val IR.V{varType=vt2, ...} = e2var
1168 : pavelk 1108 in
1169 :     (case (vt1, vt2)
1170 : pavelk 1147 of (IR.T_VEC, IR.T_VEC) => letPRIM("crossVar", IR.T_VEC, IR.CROSS, [e1var, e2var], fn var => k var env'')
1171 : pavelk 1108 | _ => raise Fail ("Type mismatch to CROSS expression")
1172 :     (* end case *))
1173 :     end))
1174 :    
1175 : pavelk 1109 | P.NORMALIZE e =>
1176 : pavelk 1147 trExpr(e, env, fn evar => fn env' =>
1177 : pavelk 1108 let
1178 : pavelk 1109 val IR.V{varType, ...} = evar
1179 : pavelk 1108 in
1180 :     (case varType
1181 : pavelk 1147 of IR.T_VEC => letPRIM("normVar", IR.T_VEC, IR.NORM, [evar], fn var => k var env')
1182 : pavelk 1108 | _ => raise Fail ("Type mismatch to NORMALIZE expression")
1183 :     (* end case *))
1184 :     end)
1185 :    
1186 : pavelk 1109 | P.LENGTH e =>
1187 : pavelk 1147 trExpr(e, env, fn evar => fn env' =>
1188 : pavelk 1108 let
1189 : pavelk 1109 val IR.V{varType, ...} = evar
1190 : pavelk 1108 in
1191 :     (case varType
1192 : pavelk 1147 of IR.T_VEC => letPRIM("lenVar", IR.T_FLOAT, IR.LEN, [evar], fn var => k var env')
1193 : pavelk 1108 | _ => raise Fail ("Type mismatch to LENGTH expression")
1194 :     (* end case *))
1195 :     end)
1196 :    
1197 :     (* !SPEED! We're assuming that there is an intersection here... *)
1198 : pavelk 1109 | P.INTERSECT {p1, p2, d} =>
1199 : pavelk 1147 trExpr(p1, env, fn p1var => fn env' =>
1200 :     trExpr(p2, env', fn p2var => fn env'' =>
1201 : pavelk 1108 let
1202 : pavelk 1109 val IR.V{varType=vt1, ...} = p1var
1203 :     val IR.V{varType=vt2, ...} = p2var
1204 : pavelk 1108 in
1205 :     (case (vt1, vt2)
1206 : pavelk 1166 of (IR.T_VEC, IR.T_VEC) => mkIntPt(env'', p1var, p2var, d, fn var => fn nextEnv => k var nextEnv)
1207 : pavelk 1108 | _ => raise Fail("Type mismatch to INTERSECT expression")
1208 :     (* end case *))
1209 :     end))
1210 :    
1211 : pavelk 1109 | P.NORMALTO (e, d) =>
1212 : pavelk 1147 trExpr(e, env, fn evar => fn env' =>
1213 : pavelk 1108 let
1214 : pavelk 1109 val IR.V{varType, ...} = evar
1215 : pavelk 1108 fun cont s = k s
1216 :     in
1217 :     (case varType
1218 : pavelk 1147 of IR.T_VEC => normAtPoint("normVar", d, env', evar, k)
1219 : pavelk 1108 | _ => raise Fail("Type mismatch to NORMALTO expression")
1220 :     (* end case *))
1221 :     end)
1222 :    
1223 :     (* end case expr *))
1224 : pavelk 1109
1225 : pavelk 1147 (* generate code to produce a random particle state from a domain *)
1226 :     fun newParticle (sv_gens, env, k : ir_env -> IR.stmt) = let
1227 : pavelk 1109
1228 :     fun createVar(P.GEN{var, ...}) = let
1229 :     val P.PSV.SV{name, ty, ...} = var
1230 :     in
1231 :     IR.newLocal("ps_" ^ name, IR.psvTyToIRTy ty, (IR.RAND, []))
1232 :     end
1233 :    
1234 :     val newState = List.map createVar sv_gens
1235 :    
1236 :     fun genVar((sv_gen, var), cont) = let
1237 : pavelk 1147 val P.GEN{exp, var=svar} = sv_gen
1238 : pavelk 1109 val IR.V{varType, ...} = var
1239 :     in
1240 : pavelk 1147 fn env' => trExpr(exp, env', fn newVal => fn env'' => cont (insertSVar(env'', svar, newVal)))
1241 : pavelk 1109 end (* genVar *)
1242 :    
1243 :     in
1244 : pavelk 1147 (List.foldr (fn (x, y) => genVar(x, y)) k (ListPair.zipEq (sv_gens, newState))) env
1245 : pavelk 1109 end (* new particle *)
1246 : pavelk 1108
1247 : pavelk 1147 fun trEmitter(emit, env, k) = let
1248 : pavelk 1108 val P.EMIT{freq, sv_gens} = emit
1249 : pavelk 1147 val ttl = pssvToIRVar(env, P.sv_ttl)
1250 : pavelk 1108 in
1251 :     letPRIM("isDead", IR.T_BOOL, IR.GT, [IR.newConst("small", IR.C_FLOAT 0.1), ttl], fn isDead =>
1252 : pavelk 770 IR.mkIF(isDead,
1253 :     (* then *)
1254 : pavelk 1147 trExpr(freq, env, fn t1 => fn env' =>
1255 :     letPRIM("t2", IR.T_FLOAT, IR.ITOF, [psvToIRVar (env', PSV.numDead)], fn t2 =>
1256 : pavelk 770 letPRIM("prob", IR.T_FLOAT, IR.DIV, [t1, t2], fn prob =>
1257 :     letPRIM("r", IR.T_FLOAT, IR.RAND, [], fn r =>
1258 :     letPRIM("t3", IR.T_BOOL, IR.GT, [prob, r], fn t3 =>
1259 :     IR.mkIF(t3,
1260 :     (* then *)
1261 : pavelk 1147 newParticle (sv_gens, env', fn env'' => k env''),
1262 : pavelk 770 (* else *)
1263 :     IR.DISCARD)))))),
1264 :     (* else *)
1265 : pavelk 1147 k env))
1266 : pavelk 770 end
1267 : pavelk 1120
1268 :     (* trExpr(expr, env, state, k : IR.var -> IR.stmt) *)
1269 :     (* mkFloatWithinVar (boolVar, env, var, d : Float.float P.domain, stmt : IR.var -> IR.stmt) *)
1270 : pavelk 1147 fun trPred(cond, env, thenk : ir_env -> IR.stmt, elsek : ir_env -> IR.stmt) = let
1271 :     fun grabVar(cond, env, k : IR.var -> ir_env -> IR.stmt) = (case cond
1272 : pavelk 1120 of P.WITHINF(d, expr) =>
1273 : pavelk 1147 trExpr(expr, env, fn checkMe => fn env' =>
1274 :     mkFloatWithinVar("wv", env', checkMe, d, fn var => k var env'))
1275 : pavelk 1120
1276 :     | P.WITHIN3F(d, expr) =>
1277 : pavelk 1147 trExpr(expr, env, fn checkMe => fn env' =>
1278 :     mkVecWithinVar("wv", env', checkMe, d, fn var => k var env'))
1279 : pavelk 1120
1280 :     | P.DO_INTERSECT {p1, p2, d} =>
1281 : pavelk 1147 trExpr(p1, env, fn p1var => fn env' =>
1282 :     trExpr(p2, env', fn p2var => fn env'' =>
1283 :     mkIntBool(env'', p1var, p2var, d, k)))
1284 : pavelk 1120
1285 :     | P.GTHAN (e1, e2) =>
1286 : pavelk 1147 trExpr(e1, env, fn e1var => fn env' =>
1287 :     trExpr(e2, env, fn e2var => fn env'' =>
1288 :     letPRIM("gtVar", IR.T_BOOL, IR.GT, [e1var, e2var], fn var => k var env'')))
1289 : pavelk 1129
1290 : pavelk 1120 | P.AND(c1, c2) =>
1291 : pavelk 1147 grabVar(c1, env, fn c1Var => fn env' =>
1292 :     grabVar(c2, env', fn c2Var => fn env'' =>
1293 :     letPRIM("andVar", IR.T_BOOL, IR.AND, [c1Var, c2Var], fn var => k var env'')))
1294 : pavelk 1120
1295 :     | P.OR(c1, c2) =>
1296 : pavelk 1147 grabVar(c1, env, fn c1Var => fn env' =>
1297 :     grabVar(c2, env, fn c2Var => fn env'' =>
1298 :     letPRIM("andVar", IR.T_BOOL, IR.OR, [c1Var, c2Var], fn var => k var env'')))
1299 : pavelk 1120
1300 :     | P.XOR(c1, c2) =>
1301 : pavelk 1147 grabVar(c1, env, fn c1Var => fn env' =>
1302 :     grabVar(c2, env', fn c2Var => fn env'' =>
1303 :     mkXOR ("xorVar", c1Var, c2Var, fn var => k var env'')))
1304 : pavelk 1120
1305 :     | P.NOT(c) =>
1306 : pavelk 1147 grabVar(c, env, fn cvar => fn env' =>
1307 :     letPRIM("notVar", IR.T_BOOL, IR.NOT, [cvar], fn var => k var env'))
1308 : pavelk 1120
1309 :     (* end case *))
1310 :     in
1311 : pavelk 1147 grabVar(cond, env, fn result => fn env' =>
1312 :     IR.mkIF(result, thenk(env'), elsek(env')))
1313 : pavelk 1120 end
1314 :    
1315 : pavelk 868 fun compile (P.PG{
1316 : pavelk 1107 emit as P.EMIT{freq, sv_gens}, act, render,
1317 :     vars, state_vars, render_vars
1318 : pavelk 1174 }, globalEnv) = let
1319 : pavelk 1107 val blks = ref[]
1320 : pavelk 1122
1321 : pavelk 1134 fun printVar (PSV.V{name, id, ...}) =
1322 :     printErr (String.concat[name, ": ", Int.toString id])
1323 : pavelk 1150
1324 : pavelk 1147 val v_env = let
1325 : pavelk 746 (* add special globals to free vars *)
1326 : pavelk 1107 val pgm_vars = PSV.Set.union(PSV.Set.singleton epsilon, vars)
1327 :     fun insv (x as PSV.V{name, ty, binding, id, ...}, map) = let
1328 : pavelk 1147 val x' = (case (ty, !binding)
1329 : pavelk 1174 of (PSV.T_BOOL, PSV.UNDEF) => (case (PSEnv.getb(x, globalEnv))
1330 :     of SOME boolVal => IR.newConst(name, IR.C_BOOL(boolVal))
1331 :     | NONE => IR.newGlobal(x, IR.T_BOOL)
1332 :     (* end case *))
1333 :    
1334 : pavelk 1147 | (PSV.T_BOOL, PSV.BOOL boolVal) => IR.newConst(name, IR.C_BOOL(boolVal))
1335 : pavelk 1174
1336 :     | (PSV.T_INT, PSV.UNDEF) => (case (PSEnv.geti(x, globalEnv))
1337 :     of SOME intVal => IR.newConst(name, IR.C_INT(intVal))
1338 :     | NONE => IR.newGlobal(x, IR.T_INT)
1339 :     (* end case *))
1340 :    
1341 : pavelk 1147 | (PSV.T_INT, PSV.INT intVal) => IR.newConst(name, IR.C_INT(intVal))
1342 : pavelk 1174
1343 :     | (PSV.T_FLOAT, PSV.UNDEF) => (case (PSEnv.getf(x, globalEnv))
1344 :     of SOME floatVal => IR.newConst(name, IR.C_FLOAT(floatVal))
1345 :     | NONE => IR.newGlobal(x, IR.T_FLOAT)
1346 :     (* end case *))
1347 :    
1348 : pavelk 1147 | (PSV.T_FLOAT, PSV.FLOAT floatVal) => IR.newConst(name, IR.C_FLOAT(floatVal))
1349 : pavelk 1174
1350 :     | (PSV.T_VEC3F, PSV.UNDEF) => (case (PSEnv.get3f(x, globalEnv))
1351 :     of SOME vecVal => IR.newConst(name, IR.C_VEC(Vec3f.pack vecVal))
1352 :     | NONE => IR.newGlobal(x, IR.T_VEC)
1353 :     (* end case *))
1354 :    
1355 : pavelk 1147 | (PSV.T_VEC3F, PSV.VEC3F vecVal) => IR.newConst(name, IR.C_VEC(vecVal))
1356 : pavelk 1174
1357 : pavelk 1147 | _ => raise Fail("Error in setup, type mismatch between PSV vars and their binding.")
1358 :     (* end case *))
1359 :     in
1360 :     PSV.Map.insert (map, x, x')
1361 :     end (* ins *)
1362 :    
1363 :     in
1364 :     PSV.Set.foldl insv PSV.Map.empty pgm_vars
1365 :     end (* env *)
1366 : pavelk 1107
1367 : pavelk 1147 fun evalActs theAct env f = (case theAct
1368 : pavelk 867 of P.SEQ(acts) => (case acts
1369 : pavelk 1147 of [] => f env
1370 :     | oneAct :: rest => evalActs oneAct env (fn env' => (evalActs (P.SEQ(rest)) env' f))
1371 : pavelk 1120 (* end case *))
1372 :    
1373 : pavelk 1137 | P.PRED(cond, thenAct, elseAct) => let
1374 : pavelk 1147 val joinBlk = newBlock (env, fn env' => f env')
1375 :     fun joinActs env = goto(env, joinBlk)
1376 : pavelk 1137 in
1377 : pavelk 1147 trPred(cond, env,
1378 :     fn env' => evalActs thenAct env' joinActs,
1379 :     fn env' => evalActs elseAct env' joinActs
1380 : pavelk 1137 )
1381 :     end
1382 : pavelk 1120
1383 :     | P.DIE => IR.DISCARD
1384 :    
1385 :     | P.ASSIGN(sv, expr) => let
1386 : pavelk 1150 val PSV.SV{name, ty, ...} = sv
1387 : pavelk 1120 in
1388 : pavelk 1147 trExpr(expr, env, fn newVar => fn env' =>
1389 : pavelk 1150 letPRIM("ps_" ^ name, IR.psvTyToIRTy ty, IR.COPY, [newVar],
1390 : pavelk 1147 fn thisVar => f (insertSVar(env', sv, thisVar))))
1391 : pavelk 1120 end
1392 : pavelk 1137
1393 : pavelk 1120 (* end case *))
1394 : pavelk 1147
1395 :     val sv_env = let
1396 :     (* add special globals to free vars *)
1397 :     fun insv (x as PSV.SV{name, ty, ...}, map) = let
1398 :     val x' = IR.newParam("ps_" ^ name, IR.psvTyToIRTy ty)
1399 :     in
1400 : pavelk 1150 IR.setRenderVar(x', PSV.SVMap.inDomain(render_vars, x));
1401 : pavelk 1147 PSV.SVMap.insert (map, x, x')
1402 :     end (* ins *)
1403 :    
1404 :     in
1405 :     PSV.SVSet.foldl insv PSV.SVMap.empty state_vars
1406 :     end (* env *)
1407 : pavelk 1150
1408 : pavelk 1147 val env = TE(blks, v_env, sv_env)
1409 :    
1410 : pavelk 868 (* The entry block is the first block of the program, or in other words, the emitter. *)
1411 : pavelk 1147 val emitterBlock = newBlock (env, fn env => trEmitter(emit, env, retState))
1412 :     val physicsBlock = newBlock (env, fn env => evalActs act env retState)
1413 : pavelk 868
1414 : pavelk 972 (* The entry block is the emitter, and the rest of the blocks define the physics processing. *)
1415 :    
1416 :     fun isGlobal(IR.V{scope, ...}) = (case scope
1417 :     of IR.S_GLOBAL(v) => true
1418 :     | _ => false
1419 :     (* end case *))
1420 :    
1421 : pavelk 866 val outPgm = PSysIR.PGM {
1422 : pavelk 1147 globals = PSV.Map.filter isGlobal v_env,
1423 :     emitter = emitterBlock,
1424 :     physics = physicsBlock,
1425 : pavelk 866 render = render
1426 :     }
1427 : pavelk 868
1428 : pavelk 1143 val optimized = if (Checker.checkIR(outPgm)) then (printErr "\nPre-optimization complete."; Optimize.optimizeIR(outPgm)) else outPgm
1429 : pavelk 746 in
1430 : pavelk 1107 (* Note: it only succeeds if we can optimize, too *)
1431 :     if Checker.checkIR(optimized) then printErr "Compilation succeeded." else ();
1432 :    
1433 :     optimized
1434 : pavelk 746 end (* compile *)
1435 :    
1436 :     end (* Translate *)

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