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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1148 - (download) (annotate)
Fri May 6 06:46:41 2011 UTC (8 years, 5 months ago) by pavelk
File size: 46078 byte(s)
Random point in disc generation requires you to take a sqrt not a square.
(* translate.sml
 
 * COPYRIGHT (c) 2009 John Reppy (http://cs.uchicago.edu/~jhr)
 * All rights reserved.
 *
 * Translate a particle system to the IR.
 *)

structure Translate : sig

    val compile : Particles.program -> PSysIR.program

  end = struct

    open SML3dTypeUtil

    structure P = ParticlesImp
    structure PSV = P.PSV
    structure IR = PSysIR
    
    fun printErr s = TextIO.output(TextIO.stdErr, s ^ "\n")

  (* special PSV global variables *)
    val epsilon = PSV.constf(0.00001)
    
  (* constants *)  
    val pi = 3.14159265358979
    
  (* translation environment *)
    datatype ir_env = TE of (IR.block list ref * IR.var PSV.Map.map * IR.var PSV.SVMap.map)
    fun insertVar (TE(blks, v_env, sv_env), x, x') = TE(blks, PSV.Map.insert (v_env, x, x'), sv_env)
    fun insertSVar (TE(blks, v_env, sv_env), x, x') = TE(blks, v_env, PSV.SVMap.insert (sv_env, x, x'))

    fun retState (TE(_, _, sv_env)) = IR.mkRETURN (PSV.SVMap.listItems sv_env)

  (* Interaction with environment and psys variables *)
    fun psvToIRVar (TE(_, env, _), x as PSV.V{name, id, ...}) = (case PSV.Map.find(env, x)
	   of SOME x' => x'
	    | NONE => raise Fail (String.concat["unknown variable ", name, " with ID ", Int.toString id])
	    (* end case *))

    fun pssvToIRVar (TE(_, _, env), x as PSV.SV{name, id, ...}) = (case PSV.SVMap.find(env, x)
	   of SOME x' => x'
	    | NONE => raise Fail (String.concat["unknown state variable ", name, " with ID ", Int.toString id])
	    (* end case *))
	    	 
   (* create a block that implements the given continuation *)  
    fun newBlockWithArgs (env as TE(blks, _, sv_env), args, k : ir_env -> IR.stmt) = let
       fun copyVar(v as IR.V{name, varType, ...}) = IR.newParam(name, varType)
       val newState = List.map copyVar (PSV.SVMap.listItems sv_env)
       fun inssv((oldv, newv), TE(theBlks, v_env, svenv)) = let
         val theKey = 
           List.find 
            (fn v => IR.varEq(PSV.SVMap.lookup(svenv, v), oldv)) 
            (PSV.SVMap.listKeys svenv)
        in
         (case theKey
           of SOME sv => TE(theBlks, v_env, PSV.SVMap.insert(svenv, sv, newv))
            | NONE => raise Fail("Trying to create new mapping for variable that doesn't already exist.")
         (* end case *))
        end
        
	   val blk = IR.newBlock (
	       newState @ args, 
	       k (List.foldl inssv env 
	           (ListPair.zipEq 
	               (PSV.SVMap.listItems sv_env, newState)
	           )
	       )
	    )
	  in
	   blks := blk :: !blks;
	   blk
	  end
	  
	fun newBlock (env, k) = newBlockWithArgs(env, [], k)

    fun gotoWithArgs(TE(_, _, env), args, blk) = IR.mkGOTO(blk, (PSV.SVMap.listItems env) @ args)
    fun goto (env, blk) = gotoWithArgs(env, [], blk)

    fun letPRIM (x, ty, p, args, body) = let
	  val x' = IR.newLocal(x, ty, (p, args))
	  in
	    IR.mkPRIM(x', p, args, body x')
	  end

  (* Not sure if this should be made into a primitive or not, but
   * basically this creates the XOR'd value of var1 and var2 and
   * stores it in result. *)
    fun mkXOR (result, var1, var2, stmt : IR.var -> IR.stmt) =
	  letPRIM("testOR", IR.T_BOOL, IR.OR, [var1, var2], fn testOR =>
	  letPRIM("testAND", IR.T_BOOL, IR.AND, [var1, var2], fn testAND =>
	  letPRIM("testNAND", IR.T_BOOL, IR.NOT, [testAND], fn testNAND =>
	  letPRIM(result, IR.T_BOOL, IR.AND, [testOR, testNAND], stmt))))
      	  
    fun genFloatVar (fltVar, env, domain : Float.float P.domain, dist, stmt : IR.var -> IR.stmt) = let
      fun genRandVal(var, stmt : IR.var -> IR.stmt) = (case dist
        of P.DIST_UNIFORM =>
          letPRIM(var, IR.T_FLOAT, IR.RAND, [], stmt)
         
         (* The PDF here is f(x) = 2x when 0 < x <= 1, so the CDF is going
          * to be the integral of f from 0 -> y => y^2. Hence, whenever we
          * generate a random number, in order to get the random value according
          * to this probability distribution, we just square it. *)
         | P.DIST_INC_LIN =>
          letPRIM("randVal", IR.T_FLOAT, IR.RAND, [], fn randVal =>
          letPRIM(var, IR.T_FLOAT, IR.MULT, [randVal, randVal], stmt))
          
         (* The PDF here is f(x) = -2x + 2 when 0 <= x < 1, so the CDF is going
          * to be the integral of f from 0 -> y => -(y^2) + 2y. Hence, whenever we
          * generate a random number, in order to get the random value according
          * to this probability distribution, we just square it.
          *)
         | P.DIST_DEC_LIN =>
          letPRIM("randVal", IR.T_FLOAT, IR.RAND, [], fn randVal =>
          letPRIM("randSq", IR.T_FLOAT, IR.MULT, [randVal, randVal], fn randSq =>
          letPRIM("termOne", IR.T_FLOAT, IR.MULT, [randSq, IR.newConst("negOne", IR.C_FLOAT ~1.0)], fn termOne =>
          letPRIM("termTwo", IR.T_FLOAT, IR.MULT, [randVal, IR.newConst("negOne", IR.C_FLOAT 2.0)], fn termTwo =>
          letPRIM(var, IR.T_FLOAT, IR.ADD, [termOne, termTwo], stmt)
          ))))
         
         | _ => raise Fail "Unable to create random float for specified distribution"
       (* end case *))
     in
     (case domain
      of P.D_POINT(pt) =>
         (* Our options here are pretty limited... *)
         letPRIM (fltVar, IR.T_FLOAT, IR.COPY, [psvToIRVar(env, pt)], stmt)
	
       | P.D_BOX{max, min} =>
         genRandVal("randf", fn rand =>
         letPRIM("boxDiff", IR.T_FLOAT, IR.SUB, [psvToIRVar(env, max), psvToIRVar(env, max)], fn diff =>
         letPRIM("scale", IR.T_FLOAT, IR.MULT, [diff, rand], fn scale =>
         letPRIM( fltVar, IR.T_FLOAT, IR.ADD, [psvToIRVar(env, max), scale], stmt )
         )))
       | _ => raise Fail ("Cannot generate float in specified domain: " ^ (P.dToStr domain))
     (* end case *))
    end
	  
  (* Generates a random vector within the given domain and puts it in vecVar *)
    fun genVecVar (
      vecVar, 
      env, 
      domain : Vec3f.vec3 P.domain, 
      dist : Vec3f.vec3 P.distribution,
      stmt : IR.var -> IR.stmt
    ) = (case domain
	   of P.D_POINT(pt) =>
	     (* Our options here are pretty limited... *)
		letPRIM (vecVar, IR.T_VEC, IR.COPY, [psvToIRVar(env, pt)], stmt)
	  
	    | P.D_LINE({pt1, pt2}) =>
	    
	        (* Lerp between the points. *)
            letPRIM ("randVal", IR.T_FLOAT, IR.RAND, [], fn randVal =>
            letPRIM ("randInv", IR.T_FLOAT, IR.SUB, [IR.newConst("one", IR.C_FLOAT 1.0), randVal], fn randInv =>
            letPRIM ("pt1s", IR.T_VEC, IR.SCALE, [randVal, psvToIRVar(env, pt1)], fn pt1ScaleVec =>
            letPRIM ("pt2s", IR.T_VEC, IR.SCALE, [randInv, psvToIRVar(env, pt2)], fn pt2ScaleVec =>
            letPRIM (vecVar, IR.T_VEC, IR.ADD_VEC, [pt1ScaleVec, pt2ScaleVec], stmt)))))
	  
	    | P.D_BOX{max, min} => 
	    	(* Extract the componentwise vector variables *)
	    	letPRIM("minX", IR.T_FLOAT, IR.EXTRACT_X, [psvToIRVar(env, min)], fn minX =>
	    	letPRIM("maxX", IR.T_FLOAT, IR.EXTRACT_X, [psvToIRVar(env, max)], fn maxX =>
	    	letPRIM("minY", IR.T_FLOAT, IR.EXTRACT_Y, [psvToIRVar(env, min)], fn minY =>
	    	letPRIM("maxY", IR.T_FLOAT, IR.EXTRACT_Y, [psvToIRVar(env, max)], fn maxY =>
	    	letPRIM("minZ", IR.T_FLOAT, IR.EXTRACT_Z, [psvToIRVar(env, min)], fn minZ =>
	    	letPRIM("maxZ", IR.T_FLOAT, IR.EXTRACT_Z, [psvToIRVar(env, max)], fn maxZ =>
	    	
	    	(* Find the distance in each component *)
	    	letPRIM("distX", IR.T_FLOAT, IR.SUB, [maxX, minX], fn distX =>
	    	letPRIM("distY", IR.T_FLOAT, IR.SUB, [maxY, minY], fn distY =>
	    	letPRIM("distZ", IR.T_FLOAT, IR.SUB, [maxZ, minZ], fn distZ =>
	    	
	    	(* Get three random numbers for each of the components *)
	    	letPRIM("randX", IR.T_FLOAT, IR.RAND, [], fn randX =>
	    	letPRIM("randY", IR.T_FLOAT, IR.RAND, [], fn randY =>
	    	letPRIM("randZ", IR.T_FLOAT, IR.RAND, [], fn randZ =>
	    	
	    	(* Scale the distances by these random numbers *)
	    	letPRIM("scaledX", IR.T_FLOAT, IR.MULT, [randX, distX], fn scaledX =>
	    	letPRIM("scaledY", IR.T_FLOAT, IR.MULT, [randY, distY], fn scaledY =>
	    	letPRIM("scaledZ", IR.T_FLOAT, IR.MULT, [randZ, distZ], fn scaledZ =>
	    	
	    	(* Add them to the minimum vec in order to create a new vec inside
	    	 * of the box.
	    	 *)
	    	letPRIM("newX", IR.T_FLOAT, IR.ADD, [minX, scaledX], fn newX =>
	    	letPRIM("newY", IR.T_FLOAT, IR.ADD, [minY, scaledY], fn newY =>
	    	letPRIM("newZ", IR.T_FLOAT, IR.ADD, [minZ, scaledZ], fn newZ =>
	    	
	    	(* Gen the vector *)
	    	letPRIM(vecVar, IR.T_VEC, IR.GEN_VEC, [newX, newY, newZ], stmt
	    	
	    	)))))))))))))))))))
	    	
	   
        | P.D_TRIANGLE{pt1, pt2, pt3} =>

            letPRIM ("pt1ToPt2", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt2), psvToIRVar(env, pt1)], fn pt1ToPt2 =>
            letPRIM ("pt1ToPt3", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt3), psvToIRVar(env, pt1)], fn pt1ToPt3 =>
            letPRIM ("randOne", IR.T_FLOAT, IR.RAND, [], fn rand1 =>
            letPRIM ("randTwo", IR.T_FLOAT, IR.RAND, [], fn rand2 =>
            letPRIM ("randTwoInv", IR.T_FLOAT, IR.SUB, [IR.newConst("one", IR.C_FLOAT 1.0), rand2], fn rand2Inv =>
            letPRIM ("scaleOne", IR.T_VEC, IR.SCALE, [rand1, pt1ToPt2], fn scale1 =>
            letPRIM ("nextScale1", IR.T_VEC, IR.SCALE, [rand2Inv, scale1], fn nextScale1 =>
            letPRIM ("scaleTwo", IR.T_VEC, IR.SCALE, [rand2, pt1ToPt3], fn scale2 =>
            letPRIM ("tempAdd", IR.T_VEC, IR.ADD_VEC, [psvToIRVar(env, pt1), nextScale1], fn tempAdd =>
            letPRIM (vecVar, IR.T_VEC, IR.ADD_VEC, [tempAdd, scale2], stmt))))))))))
      
	    | P.D_CYLINDER {pt1, pt2, irad, orad} => let 
		  val normVar = PSV.new("local_ht", PSV.T_VEC3F)
		 in
		  letPRIM("rand", IR.T_FLOAT, IR.RAND, [], fn ourRand =>
		  letPRIM("n", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt2), psvToIRVar(env, pt1)], fn normVec =>
		  letPRIM("ht", IR.T_FLOAT, IR.LEN, [normVec], fn height =>
		  letPRIM("htInv", IR.T_FLOAT, IR.DIV, [IR.newConst("one", IR.C_FLOAT 1.0), height], fn htInv =>
		  letPRIM("n", IR.T_VEC, IR.SCALE, [htInv, normVec], fn norm =>
		  (* Generate a point in the lower disc. *)
		    genVecVar("ptInDisc", 
		      insertVar(env, normVar, norm), 
		      P.D_DISC{pt = pt1, normal = normVar, irad = irad, orad = orad},
		      dist,
		      fn ptInDisc =>
		  (* Now add this point to a random scaling of the normVec. *)
		    letPRIM("s", IR.T_FLOAT, IR.MULT, [height, ourRand], fn scale =>
		    letPRIM("sn", IR.T_VEC, IR.SCALE, [scale, normVec], fn scaledNormVec =>
		    letPRIM(vecVar, IR.T_VEC, IR.ADD_VEC, [ptInDisc, scaledNormVec], stmt)))))))))
		 end

        | P.D_DISC {pt, normal, irad, orad} =>

            (* Get a random angle... *)
            letPRIM ("r", IR.T_FLOAT, IR.RAND, [], fn randForAng =>
            letPRIM ("t", IR.T_FLOAT, IR.MULT, [randForAng, IR.newConst("fullCir", IR.C_FLOAT (2.0 * pi))], fn randAng =>
            
            (* Get a random radius *)
            letPRIM ("e0", IR.T_FLOAT, IR.RAND, [], fn newRand =>
            letPRIM ("e0sq", IR.T_FLOAT, IR.SQRT, [newRand], fn randRadSq =>
            letPRIM ("radDiff", IR.T_FLOAT, IR.SUB, [psvToIRVar(env, orad), psvToIRVar(env, irad)], fn radDiff =>
            letPRIM ("newRadDist", IR.T_FLOAT, IR.MULT, [randRadSq, radDiff], fn newRadDist =>
            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 ptInDiscNorm =>
            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)
            )))))))))))))))))))
         
        | P.D_CONE{pt1, pt2, irad, orad} => let
             val normVar = PSV.new("local_ht", PSV.T_VEC3F)
            in
             letPRIM("eh",  IR.T_FLOAT, IR.RAND, [], fn ourRand =>
             letPRIM("nv", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt2), psvToIRVar(env, pt1)], fn normVec =>
             letPRIM("n", IR.T_VEC, IR.NORM, [normVec], fn norm =>
             genVecVar("ptInDisc", 
              insertVar(env, normVar, norm), 
              P.D_DISC{pt = pt1, normal = normVar, irad = irad, orad = orad},
              dist,
              fn ptInDisc => 
             letPRIM("gptt", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt2), ptInDisc], fn genPtToTip =>
             letPRIM("gpttlen", IR.T_FLOAT, IR.LEN, [genPtToTip], fn genPtToTipLen =>
             letPRIM("s", IR.T_FLOAT, IR.MULT, [genPtToTipLen, ourRand], fn scale =>
             letPRIM("sn", IR.T_VEC, IR.SCALE, [scale, genPtToTip], fn scaledNormVec =>
             letPRIM(vecVar, IR.T_VEC, IR.ADD_VEC, [ptInDisc, scaledNormVec], stmt)
             ))))))))
            end
		
		| P.D_SPHERE{center, irad, orad} =>
		  
		  (* Source: http://mathworld.wolfram.com/SpherePointPicking.html *)
		
          (* generate two random values... one will be called u and will 
           * represent cos(theta), and the other will be called v and will
           * represent a random value in [0, 2 * pi] *)
          letPRIM("randVal", IR.T_FLOAT, IR.RAND, [], fn rv =>
          letPRIM("dblRandVal", IR.T_FLOAT, IR.MULT, [rv, IR.newConst("Two", IR.C_FLOAT 2.0)], fn drv =>
          letPRIM("rand", IR.T_FLOAT, IR.SUB, [drv, IR.newConst("One", IR.C_FLOAT 1.0)], fn u =>
          
          letPRIM("rv2", IR.T_FLOAT, IR.RAND, [], fn rv2 =>
          letPRIM("rand2", IR.T_FLOAT, IR.MULT, [rv2, IR.newConst("TwoPi", IR.C_FLOAT (2.0 * Float.M_PI))], fn theta =>          

          letPRIM("cosTheta", IR.T_FLOAT, IR.COS, [theta], fn cosT =>
          letPRIM("sinTheta", IR.T_FLOAT, IR.SIN, [theta], fn sinT =>
          
          letPRIM("usq", IR.T_FLOAT, IR.MULT, [u, u], fn usq =>
          letPRIM("usqInv", IR.T_FLOAT, IR.SUB, [IR.newConst("One", IR.C_FLOAT 1.0), usq], fn usqInv =>
          letPRIM("sinPhi", IR.T_FLOAT, IR.SQRT, [usqInv], fn sinP =>
          
          letPRIM("xVal", IR.T_FLOAT, IR.MULT, [sinP, cosT], fn xVal =>
          letPRIM("yVal", IR.T_FLOAT, IR.MULT, [sinP, sinT], fn yVal =>
          (* zval is just u *)

          letPRIM("vec", IR.T_VEC, IR.GEN_VEC, [xVal, yVal, u], fn vec =>
          
          (* Generate a random radius... *)
		  letPRIM("ratio", IR.T_FLOAT, IR.DIV, [psvToIRVar(env, irad), psvToIRVar(env, orad)], fn ratio =>
		  letPRIM("invRatio", IR.T_FLOAT, IR.SUB, [IR.newConst("one", IR.C_FLOAT 1.0), ratio], fn invRatio =>
		  letPRIM("randVar", IR.T_FLOAT, IR.RAND, [], fn rand =>
		  letPRIM("randScale", IR.T_FLOAT, IR.MULT, [rand, invRatio], fn randScale =>
		  letPRIM("randVal", IR.T_FLOAT, IR.ADD, [randScale, ratio], fn randVal =>
		  letPRIM("randValSq", IR.T_FLOAT, IR.MULT, [randVal, randVal], fn randValSq =>
		  letPRIM("radDiff", IR.T_FLOAT, IR.SUB, [psvToIRVar(env, orad), psvToIRVar(env, irad)], fn radDiff =>
		  letPRIM("randRadVal", IR.T_FLOAT, IR.MULT, [radDiff, randValSq], fn randRadVal =>
		  letPRIM("rad", IR.T_FLOAT, IR.ADD, [psvToIRVar(env, irad), randRadVal], fn rad =>
		  
		  (* Normalize the vector and scale it by the radius. *)
		  letPRIM("scaledVec", IR.T_VEC, IR.SCALE, [rad, vec], fn sVec =>
		  letPRIM(vecVar, IR.T_VEC, IR.ADD_VEC, [sVec, psvToIRVar(env, center)], stmt)
		  ))))))))))
		  )))))))))))))
     
	    | _ => raise Fail ("Cannot generate point in specified domain: "  ^ (P.dToStr domain))
	  (* end case *))
	  
  (* This function takes an IR boolean, its environment, a particle state, domain, 
   * and continuation.
   *
   * We set the boolean to whether or not the current particle given by the particle
   * state is within the domain, and then pass the continuation on.
   *)
    fun mkVecWithinVar (boolVar, env, var, d : Vec3f.vec3 P.domain, stmt : IR.var -> IR.stmt) = let
	   val pos = var
	  in
	    case d
	     of P.D_POINT(pt) => 
		  letPRIM("subVec", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt), pos], fn subVec =>
		  letPRIM("vecLen", IR.T_FLOAT, IR.LEN, [subVec], fn vecLen =>
		  letPRIM(boolVar, IR.T_BOOL, IR.GT, [psvToIRVar(env, epsilon), vecLen], stmt)))

        (* Take the vectors going from our position to pt1, and pt2. Then
         * after we normalize them, if their dot product is equal to -1, then
         * they are pointing in opposite directions meaning that the position
         * is inbetween pt1 and pt2 as desired.
         *)
	      | P.D_LINE{pt1, pt2} =>
		  letPRIM("posToPt1", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt1), pos], fn posToPt1 =>
		  letPRIM("posToPt1Norm", IR.T_VEC, IR.NORM, [posToPt1], fn posToPt1Norm =>
		  letPRIM("posToPt2", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt2), pos], fn posToPt2 =>
		  letPRIM("posToPt2Norm", IR.T_VEC, IR.NORM, [posToPt2], fn posToPt2Norm =>
		  letPRIM("dot", IR.T_FLOAT, IR.DOT, [posToPt2, posToPt1], fn dotProd =>
		  letPRIM("testMe", IR.T_FLOAT, IR.SUB, [dotProd, IR.newConst("negOne", IR.C_FLOAT ~1.0)], fn testVal =>
		  letPRIM(boolVar, IR.T_BOOL, IR.GT, [psvToIRVar(env, epsilon), testVal], stmt)))))))
	    
	    (* Just see whether or not the dot product between the normal
	     * and the vector from a point on the plane to our position is
	     * greater than zero. Essentially, we're "within" a plane if we're
	     * behind it (with respect to the normal)
	     *)
	      | P.D_PLANE{pt, normal} => 
		  letPRIM("posToPt", IR.T_VEC, IR.SUB_VEC, [pos, psvToIRVar(env, pt)], fn posToPt =>
		  letPRIM("dot", IR.T_FLOAT, IR.DOT, [posToPt, psvToIRVar(env, normal)], fn dotProd =>
		  letPRIM(boolVar, IR.T_BOOL, IR.GT, [dotProd, IR.newConst("zero", IR.C_FLOAT 0.0)], stmt)))
	    
	    (* Similar to checking to see whether or not we're within a plane,
	     * here all we have to do is see how far we are from the center
	     * of the disc (pt), and then see whther or not we're perpendicular to
	     * the normal, and that our distance is greater than irad but less than
	     * orad.
	     *)
	      | P.D_DISC{pt, normal, orad, irad} => 
            letPRIM("posToPt", IR.T_VEC, IR.SUB_VEC, [pos, psvToIRVar(env, pt)], fn posToPt =>
            letPRIM("dot", IR.T_FLOAT, IR.DOT, [posToPt, psvToIRVar(env, normal)], fn dotProd =>
            letPRIM("inDisc", IR.T_BOOL, IR.GT, [IR.newConst("small", IR.C_FLOAT 0.01), dotProd], fn inDisc =>
            
            letPRIM("parPosToP", IR.T_VEC, IR.SCALE, [dotProd, psvToIRVar(env, normal)], fn posToPtParallelToNormal =>
            letPRIM("perpPosToP", IR.T_VEC, IR.SUB_VEC, [posToPt, posToPtParallelToNormal], fn posToPtPerpToNormal =>
            letPRIM("inDiscLen", IR.T_FLOAT, IR.LEN, [posToPtPerpToNormal], fn posToPtLen =>
            
            letPRIM("inOradGt", IR.T_BOOL, IR.GT, [psvToIRVar(env, orad), posToPtLen], fn inOradGt =>
            letPRIM("inOradEq", IR.T_BOOL, IR.EQUALS, [psvToIRVar(env, orad), posToPtLen], fn inOradEq =>
            letPRIM("inOrad", IR.T_BOOL, IR.OR, [inOradGt, inOradEq], fn inOrad =>
            
            letPRIM("inIradGt", IR.T_BOOL, IR.GT, [posToPtLen, psvToIRVar(env, irad)], fn inIradGt =>
            letPRIM("inIradEq", IR.T_BOOL, IR.EQUALS, [posToPtLen, psvToIRVar(env, irad)], fn inIradEq =>
            letPRIM("inIrad", IR.T_BOOL, IR.OR, [inIradGt, inIradEq], fn inIrad =>
            
            letPRIM("inBothRad", IR.T_BOOL, IR.AND, [inIrad, inOrad], fn inBothRad =>
            
            letPRIM(boolVar, IR.T_BOOL, IR.AND, [inDisc, inBothRad], stmt))))))))))))))
		  
	    (* Simply see whether or not the distance from the center is within the 
	     * specified bounds.
	     *)
	      | P.D_SPHERE{center, orad, irad} =>
		  letPRIM("posToPt", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, center), pos], fn posToC =>
		  letPRIM("posToPtLen", IR.T_VEC, IR.LEN, [posToC], fn posToCLen =>
		  letPRIM("inOrad", IR.T_BOOL, IR.GT, [psvToIRVar(env, orad), posToCLen], fn inOrad =>
		  letPRIM("inIrad", IR.T_BOOL, IR.GT, [posToCLen, psvToIRVar(env, irad)], fn inIrad =>
		  letPRIM(boolVar, IR.T_BOOL, IR.AND, [inIrad, inOrad], stmt)))))
		  
		  | P.D_CYLINDER {pt1, pt2, irad, orad} =>
		  
		  (* !FIXME! Right now, we see whether or not the point is within the two planes defined
		   * by the endpoints of the cylinder, and then testing to see whether or not the smallest
		   * distance to the line segment falls within the radii. It might be faster to find the
		   * closest point to the line defined by the endpoints and then see whether or not the point
		   * is within the segment.
		   *)
		  
		  (* Is it in one plane *)
		  letPRIM("plane1Norm", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt2), psvToIRVar(env, pt1)], fn plane1Norm =>
		  letPRIM("posToPt1", IR.T_VEC, IR.SUB_VEC, [pos, psvToIRVar(env, pt1)], fn posToPt1 =>
		  letPRIM("dot1", IR.T_FLOAT, IR.DOT, [posToPt1, plane1Norm], fn dot1Prod =>
		  letPRIM("inPlane1", IR.T_BOOL, IR.GT, [dot1Prod, IR.newConst("zero", IR.C_FLOAT 0.0)], fn inPlane1=>
		  
		  (* Is it in another plane *)
		  letPRIM("plane2Norm", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt1), psvToIRVar(env, pt2)], fn plane2Norm =>
		  letPRIM("posToPt2", IR.T_VEC, IR.SUB_VEC, [pos, psvToIRVar(env, pt2)], fn posToPt2 =>
		  letPRIM("dot2", IR.T_FLOAT, IR.DOT, [posToPt2, plane2Norm], fn dot2Prod =>
		  letPRIM("inPlane2", IR.T_BOOL, IR.GT, [dot2Prod, IR.newConst("zero", IR.C_FLOAT 0.0)], fn inPlane2=>
		  
		  (* Is it in both planes? *)
		  letPRIM("inPlanes", IR.T_BOOL, IR.AND, [inPlane1, inPlane2], fn inPlanes =>
		  
		  (* Find distance from segment *)
		  letPRIM("a", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt2), psvToIRVar(env, pt1)], fn a =>
		  letPRIM("b", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt1), pos], fn b =>
		  letPRIM("alen", IR.T_FLOAT, IR.LEN, [a], fn alen =>
		  letPRIM("axb", IR.T_VEC, IR.CROSS, [a, b], fn axb =>
		  letPRIM("axblen", IR.T_FLOAT, IR.LEN, [axb], fn axblen =>
		  letPRIM("dist", IR.T_FLOAT, IR.DIV, [axblen, alen], fn dist =>
		  
		  (* Is distance in both radii? *)
		  letPRIM("inOradGt", IR.T_BOOL, IR.GT, [psvToIRVar(env, orad), dist], fn inOradGt =>
		  letPRIM("inOradEq", IR.T_BOOL, IR.EQUALS, [psvToIRVar(env, orad), dist], fn inOradEq =>
  		  letPRIM("inOrad", IR.T_BOOL, IR.OR, [inOradGt, inOradEq], fn inOrad =>
  		  
		  letPRIM("inIradGt", IR.T_BOOL, IR.GT, [dist, psvToIRVar(env, irad)], fn inIradGt =>
		  letPRIM("inIradEq", IR.T_BOOL, IR.EQUALS, [dist, psvToIRVar(env, irad)], fn inIradEq =>
		  letPRIM("inIrad", IR.T_BOOL, IR.OR, [inIradGt, inIradEq], fn inIrad =>
		  
		  letPRIM("inBothRad", IR.T_BOOL, IR.AND, [inIrad, inOrad], fn inBothRad =>		  
		  
		  (* It's in the cylinder (tube) if it's within both radii and in both planes... *)
		  letPRIM(boolVar, IR.T_BOOL, IR.AND, [inPlanes, inBothRad], stmt)
		  ))))))))))))))))))))))
(*	    	
	      | P.D_TRIANGLE {pt1: vec3f var, pt2: vec3f var, pt3: vec3f var}
	      | P.D_PLANE {pt: vec3f var, normal: vec3f var}
	      | P.D_RECT {pt: vec3f var, htvec: vec3f var, wdvec: vec3f var}
	      | P.D_BOX {min: vec3f var, max: vec3f var}    
	      | P.D_SPHERE {center: vec3f var, irad: vec3f var, orad: vec3f var}
	      | P.D_CONE {pt1: vec3f var, pt2: vec3f var, irad: float var, orad: float var}
	      | P.D_BLOB {center: vec3f var, stddev: float var}
	      | P.D_DISC {pt: vec3f var, normal: vec3f var, irad: float var, orad: float var}
*)
	      | _ => raise Fail ("Cannot determine within-ness for specified vec3 domain: " ^ (P.dToStr d))
	    (* end case *)
	  end (*end let *)
	  
	fun mkFloatWithinVar (boolVar, env, var, d : Float.float P.domain, stmt : IR.var -> IR.stmt) = (case d
	  of P.D_POINT(pt) => letPRIM(boolVar, IR.T_BOOL, IR.EQUALS, [psvToIRVar(env, pt), var], stmt)
	   | P.D_BOX {min, max} => 
	     letPRIM("bigMin", IR.T_BOOL, IR.GT, [var, psvToIRVar(env, min)], fn bigMin =>
	     letPRIM("smallMax", IR.T_BOOL, IR.GT, [psvToIRVar(env, max), var], fn smallMax =>
	     letPRIM(boolVar, IR.T_BOOL, IR.AND, [bigMin, smallMax], stmt)))
	   | _ => raise Fail ("Cannot determine within-ness for specified float domain: " ^ (P.dToStr d))
	 (* end case *))

	fun mkIntBool(env, p1var, p2var, d : Vec3f.vec3 P.domain, k : IR.var -> ir_env -> IR.stmt) = let
	  val _ = ()
	 in
	  (case d
	    of P.D_POINT(pt) =>
	    
	     (* Get vectors *)
	     letPRIM("p1ToPt", IR.T_VEC, IR.SUB_VEC, [psvToIRVar (env, pt), p1var], fn p1ToPt =>
	     letPRIM("p2ToPt", IR.T_VEC, IR.SUB_VEC, [psvToIRVar (env, pt), p2var], fn p2ToPt =>
	     letPRIM("p1ToP2", IR.T_VEC, IR.SUB_VEC, [p2var, p1var], fn p1ToP2 =>
	     
	     (* Get distances *)
	     letPRIM("p1ToPtLen", IR.T_FLOAT, IR.LEN, [p1ToPt], fn p1ToPtLen =>
	     letPRIM("p2ToPtLen", IR.T_FLOAT, IR.LEN, [p2ToPt], fn p2ToPtLen =>
	     letPRIM("p1ToP2Len", IR.T_FLOAT, IR.LEN, [p1ToP2], fn p1ToP2Len =>
	     
	     (* Add & subtract ... *)
	     letPRIM("distSum", IR.T_FLOAT, IR.ADD, [p1ToPtLen, p2ToPtLen], fn distSum => 
	     letPRIM("distDiff", IR.T_FLOAT, IR.SUB, [distSum, p1ToP2Len], fn distDiff =>
	     letPRIM("distDiffAbs", IR.T_FLOAT, IR.ABS, [distDiff], fn distDiffAbs =>
	     
	     (* Do the boolean stuff... *)
	     letPRIM("intersect", IR.T_BOOL, IR.GT, [psvToIRVar(env, epsilon), distDiffAbs], fn intVar => k intVar env)
	     
	     )))
	     )))
	     )))
	     
	    | P.D_PLANE {pt, normal} => 
	      letPRIM("d", IR.T_FLOAT, IR.DOT, [psvToIRVar(env, pt), psvToIRVar(env, normal)], fn d =>
	      letPRIM("p1d", IR.T_FLOAT, IR.DOT, [p1var, psvToIRVar(env, normal)], fn p1d =>
	      letPRIM("p2d", IR.T_FLOAT, IR.DOT, [p2var, psvToIRVar(env, normal)], fn p2d =>
	      letPRIM("p1dist", IR.T_FLOAT, IR.SUB, [d, p1d], fn p1dist =>
	      letPRIM("p2dist", IR.T_FLOAT, IR.SUB, [d, p2d], fn p2dist =>
	      letPRIM("distProd", IR.T_FLOAT, IR.MULT, [p1dist, p2dist], fn distProd =>
	      letPRIM("intersect", IR.T_BOOL, IR.GT, [IR.newConst("zero", IR.C_FLOAT 0.0), distProd], fn intVar => k intVar env)
	      ))))))
	    
	    | P.D_DISC {pt, normal, orad, irad} => let
	      val boolVar = IR.newParam("intersect", IR.T_BOOL)
	      val newBlk = newBlockWithArgs(env, [boolVar], k boolVar)
	     in
	      letPRIM("d", IR.T_FLOAT, IR.DOT, [psvToIRVar(env, pt), psvToIRVar(env, normal)], fn d =>
	      letPRIM("p1d", IR.T_FLOAT, IR.DOT, [p1var, psvToIRVar(env, normal)], fn p1d =>
	      
	      (* Early out... does it intersect the plane?
	       * 
	       * !SPEED! Due to the perceived slowness of branching on
	       * GPUs, this might not actually be faster on all runtime environments *)

	      letPRIM("p2d", IR.T_FLOAT, IR.DOT, [p2var, psvToIRVar(env, normal)], fn p2d =>
	      letPRIM("p1dist", IR.T_FLOAT, IR.SUB, [d, p1d], fn p1dist =>
	      letPRIM("p2dist", IR.T_FLOAT, IR.SUB, [d, p2d], fn p2dist =>
	      letPRIM("distProd", IR.T_FLOAT, IR.MULT, [p1dist, p2dist], fn distProd =>
	      letPRIM("earlyOut", IR.T_BOOL, IR.GT, [distProd, IR.newConst("zero", IR.C_FLOAT 0.0)], fn earlyOut =>
	      IR.mkIF(earlyOut,
	        (* then *)
	        letPRIM("intersect", IR.T_BOOL, IR.NOT, [earlyOut], fn var => gotoWithArgs(env, [var], newBlk)),
	        (* else *)
	        letPRIM("v", IR.T_VEC, IR.SUB_VEC, [p2var, p1var], fn v =>
	        letPRIM("vDotn", IR.T_FLOAT, IR.DOT, [v, psvToIRVar(env, normal)], fn vdn =>
	        letPRIM("t", IR.T_FLOAT, IR.DIV, [p1dist, vdn], fn t =>
	        
	        (* !TODO! Add some sort of assert mechanism to make sure that t is
	         * in the interval [0, 1]... *)
	        letPRIM("vscale", IR.T_VEC, IR.SCALE, [t, v], fn vscale =>
	        letPRIM("ppt", IR.T_VEC, IR.ADD_VEC, [p1var, vscale], fn ppt =>
	        letPRIM("lenVec", IR.T_VEC, IR.SUB_VEC, [ppt, psvToIRVar(env, pt)], fn cv =>
	        letPRIM("len", IR.T_FLOAT, IR.LEN, [cv], fn len =>
	        
	        (* Check to see whether or not it's within the radius... *)
	        letPRIM("gtirad", IR.T_BOOL, IR.GT, [len, psvToIRVar(env, irad)], fn gtirad =>
	        letPRIM("ltorad", IR.T_BOOL, IR.GT, [psvToIRVar(env, orad), len], fn ltorad =>
	        letPRIM("intersect", IR.T_BOOL, IR.AND, [gtirad, ltorad], fn var => gotoWithArgs(env, [var], newBlk))
	       ))))))))))
	     )))))))
	    end (* P.D_DISC *)
	    
	    | _ => raise Fail ("Cannot calculate intersection bool for specified domain: " ^ (P.dToStr d))
	  (* end case *))

	 end (* mkIntBool *)
	    
	(* We assume that the segment already intersects with the domain. *)
	fun mkIntPt(env, p1var, p2var, d : Vec3f.vec3 P.domain, k : IR.var -> IR.stmt) = let
	  val _ = ()
	 in
	  (case d 
	    of P.D_POINT(pt) => k (psvToIRVar (env, pt))
	    
	     | P.D_PLANE {pt, normal} => 
	       letPRIM("d", IR.T_FLOAT, IR.DOT, [psvToIRVar(env, pt), psvToIRVar(env, normal)], fn d =>
	       letPRIM("p1d", IR.T_FLOAT, IR.DOT, [p1var, psvToIRVar(env, normal)], fn p1d =>
	       letPRIM("num", IR.T_FLOAT, IR.SUB, [d, p1d], fn num =>
	       letPRIM("v", IR.T_VEC, IR.SUB_VEC, [p2var, p1var], fn v =>
	       letPRIM("den", IR.T_FLOAT, IR.DOT, [v, psvToIRVar(env, normal)], fn den =>
	       letPRIM("t", IR.T_FLOAT, IR.DIV, [num, den], fn t =>
	       letPRIM("vsc", IR.T_VEC, IR.SCALE, [t, v], fn vs =>
	       letPRIM("intPt", IR.T_VEC, IR.ADD_VEC, [p1var, vs], k)
	       )))))))
	     
	     (* Since we already know they intersect, the intersection point must be 
	      * just the point that's on the plane... *)
	     | P.D_DISC {pt, normal, orad, irad} => mkIntPt(env, p1var, p2var, P.D_PLANE{pt = pt, normal = normal}, k)
	     | _ => raise Fail ("Cannot calculate intersection point for specified domain: "  ^ (P.dToStr d))
	  (* end case *))	     
	 end (* mkIntPt *)
	    
    (* Find the normal at the given position of the particle for the specified 
     * domain. Note, that the particle doesn't necessarily need to be on the
     * domain, but if it's not then the behavior is undefined. *)
    fun normAtPoint(retNorm, d, env, pos, k : IR.var -> ir_env -> IR.stmt) = let
      val newNorm = IR.newParam("n", IR.T_VEC)
      val nextBlk = newBlockWithArgs(env, [newNorm], k(newNorm))
     in
      (case d
	  of P.D_PLANE{pt, normal} =>
	     letPRIM("inVec", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, pt), pos], fn inVec =>
	     letPRIM("dotNorm", IR.T_FLOAT, IR.DOT, [psvToIRVar(env, normal), inVec], fn dotNorm =>
	     letPRIM("eqZero", IR.T_BOOL, IR.EQUALS, [dotNorm, IR.newConst("One", IR.C_FLOAT 0.0)], fn eqZero =>
	     IR.mkIF(eqZero,
	         (*thenStmt*)
	         gotoWithArgs(env, [psvToIRVar(env, normal)], nextBlk),
             (*elseStmt*)	         
    	     letPRIM("dnRecip", IR.T_FLOAT, IR.DIV, [IR.newConst("One", IR.C_FLOAT 1.0), dotNorm], fn dnRecip =>
    	     letPRIM("absR", IR.T_FLOAT, IR.ABS, [dnRecip], fn absR =>
    	     letPRIM("sign", IR.T_FLOAT, IR.MULT, [absR, dotNorm], fn sign =>
    	     letPRIM(retNorm, IR.T_VEC, IR.SCALE, [sign, psvToIRVar(env, normal)], 
    	     fn newNormVar => gotoWithArgs(env, [newNormVar], nextBlk)))))
    	 ))))
	      
	   | P.D_DISC{pt, normal, irad, orad} => 
	      normAtPoint(retNorm, P.D_PLANE{pt=pt, normal=normal}, env, pos, k)
         
	   | P.D_SPHERE{center, irad, orad} => 
		    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 env
		  ))
           
	   | _ => raise Fail("Cannot find normal to point of specified domain." ^ (P.dToStr d))
	 (* end case *))
	end
	
	fun trExpr(expr, env, k : IR.var -> ir_env -> IR.stmt) = (case expr
	  of P.CONSTF f => k (IR.newConst ("c", IR.C_FLOAT f)) env
	  
       | P.CONST3F v => k (IR.newConst ("c", IR.C_VEC v)) env
       
       | P.VAR v => k (psvToIRVar (env, v)) env
       
       | P.STATE_VAR sv => k (pssvToIRVar (env, sv)) env
       
       | P.GENERATE3F (dom, dist) => genVecVar("genVec", env, dom, dist, fn var => k var env)
       
       | P.GENERATEF (dom, dist) => genFloatVar("genFlt", env, dom, dist, fn var => k var env)
       
       | P.ADD(e1, e2) =>
         trExpr(e1, env, fn e1var => fn env' =>
         trExpr(e2, env', fn e2var => fn env'' =>
         let
          val IR.V{varType=vt1, ...} = e1var
          val IR.V{varType=vt2, ...} = e2var
         in
          (case (vt1, vt2)
            of (IR.T_FLOAT, IR.T_FLOAT) => letPRIM("addVar", IR.T_FLOAT, IR.ADD, [e1var, e2var], fn var => k var env'')
             | (IR.T_VEC, IR.T_VEC) => letPRIM("addVar", IR.T_VEC, IR.ADD_VEC, [e1var, e2var], fn var => k var env'')
             | _ => raise Fail ("Type mismatch to ADD expression")
          (* end case *))
         end))
         
       | P.SCALE (e1, e2) =>
         trExpr(e1, env, fn e1var => fn env' =>
         trExpr(e2, env', fn e2var => fn env'' =>
         let
          val IR.V{varType=vt1, ...} = e1var
          val IR.V{varType=vt2, ...} = e2var
         in
          (case (vt1, vt2)
            of (IR.T_FLOAT, IR.T_VEC) => letPRIM("scaleVar", IR.T_VEC, IR.SCALE, [e1var, e2var], fn var => k var env'')
             | (IR.T_FLOAT, IR.T_FLOAT) => letPRIM("scaleVar", IR.T_FLOAT, IR.MULT, [e1var, e2var], fn var => k var env'')
             | _ => raise Fail (String.concat["Type mismatch to SCALE expression: ", IR.ty2Str vt1, ", ", IR.ty2Str vt2])
          (* end case *))
         end))
         
       | P.DIV (e1, e2) =>
         trExpr(e1, env, fn e1var => fn env' =>
         trExpr(e2, env', fn e2var => fn env'' =>
         let
          val IR.V{varType=vt1, ...} = e1var
          val IR.V{varType=vt2, ...} = e2var
         in
          (case (vt1, vt2)
            of (IR.T_FLOAT, IR.T_FLOAT) => letPRIM("divVar", IR.T_FLOAT, IR.DIV, [e1var, e2var], fn var => k var env'')
             | _ => raise Fail (String.concat["Type mismatch to DIV expression: ", IR.ty2Str vt1, ", ", IR.ty2Str vt2])
          (* end case *))
         end))

       | P.NEG e =>
         trExpr(e, env, fn evar => fn env' =>
         let
          val IR.V{varType, ...} = evar
         in
          (case varType
            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') 
             | IR.T_VEC => letPRIM("negVar", IR.T_VEC, IR.NEG_VEC, [evar], fn var => k var env')
             | _ => raise Fail ("Type mismatch to NEG expression")
          (* end case *))
         end)
         
       | P.DOT (e1, e2) =>
         trExpr(e1, env, fn e1var => fn env' =>
         trExpr(e2, env', fn e2var => fn env'' =>
         let
          val IR.V{varType=vt1, ...} = e1var
          val IR.V{varType=vt2, ...} = e2var
         in
          (case (vt1, vt2)
            of (IR.T_VEC, IR.T_VEC) => letPRIM("dotVar", IR.T_FLOAT, IR.DOT, [e1var, e2var], fn var => k var env'')
             | _ => raise Fail ("Type mismatch to DOT expression")
          (* end case *))
         end))
         
       | P.CROSS (e1, e2) =>
         trExpr(e1, env, fn e1var => fn env' =>
         trExpr(e2, env', fn e2var => fn env'' =>
         let
          val IR.V{varType=vt1, ...} = e1var
          val IR.V{varType=vt2, ...} = e2var
         in
          (case (vt1, vt2)
            of (IR.T_VEC, IR.T_VEC) => letPRIM("crossVar", IR.T_VEC, IR.CROSS, [e1var, e2var], fn var => k var env'')
             | _ => raise Fail ("Type mismatch to CROSS expression")
          (* end case *))
         end))
         
       | P.NORMALIZE e =>
         trExpr(e, env, fn evar => fn env' =>
         let
          val IR.V{varType, ...} = evar
         in
          (case varType
            of IR.T_VEC => letPRIM("normVar", IR.T_VEC, IR.NORM, [evar], fn var => k var env')
             | _ => raise Fail ("Type mismatch to NORMALIZE expression")
          (* end case *))
         end)
      
       | P.LENGTH e =>
         trExpr(e, env, fn evar => fn env' =>
         let
          val IR.V{varType, ...} = evar
         in
          (case varType
            of IR.T_VEC => letPRIM("lenVar", IR.T_FLOAT, IR.LEN, [evar], fn var => k var env')
             | _ => raise Fail ("Type mismatch to LENGTH expression")
          (* end case *))
         end)
      
       (* !SPEED! We're assuming that there is an intersection here... *)
       | P.INTERSECT {p1, p2, d} =>
         trExpr(p1, env, fn p1var => fn env' =>
         trExpr(p2, env', fn p2var => fn env'' =>
         let
          val IR.V{varType=vt1, ...} = p1var
          val IR.V{varType=vt2, ...} = p2var
         in
          (case (vt1, vt2) 
            of (IR.T_VEC, IR.T_VEC) => mkIntPt(env, p1var, p2var, d, fn var => k var env'')
             | _ => raise Fail("Type mismatch to INTERSECT expression")
          (* end case *))
         end))
         
       | P.NORMALTO (e, d) =>
         trExpr(e, env, fn evar => fn env' =>
         let
          val IR.V{varType, ...} = evar
          fun cont s = k s
         in
          (case varType
            of IR.T_VEC => normAtPoint("normVar", d, env', evar, k)
             | _ => raise Fail("Type mismatch to NORMALTO expression")
          (* end case *))
         end)
         
	  (* end case expr *))
	  
	(* generate code to produce a random particle state from a domain *)
    fun newParticle (sv_gens, env, k : ir_env -> IR.stmt) = let
    
      fun createVar(P.GEN{var, ...}) = let
        val P.PSV.SV{name, ty, ...} = var
       in
        IR.newLocal("ps_" ^ name, IR.psvTyToIRTy ty, (IR.RAND, []))
       end
       
      val newState = List.map createVar sv_gens
       
      fun genVar((sv_gen, var), cont) = let
        val P.GEN{exp, var=svar} = sv_gen
        val IR.V{varType, ...} = var
       in
        fn env' => trExpr(exp, env', fn newVal => fn env'' => cont (insertSVar(env'', svar, newVal)))
       end (* genVar *)
       
     in
      (List.foldr (fn (x, y) => genVar(x, y)) k (ListPair.zipEq (sv_gens, newState))) env 
     end (* new particle *)

    fun trEmitter(emit, env, k) = let
      val P.EMIT{freq, sv_gens} = emit
      val ttl = pssvToIRVar(env, P.sv_ttl)
     in
      letPRIM("isDead", IR.T_BOOL, IR.GT, [IR.newConst("small", IR.C_FLOAT 0.1), ttl], fn isDead =>
      IR.mkIF(isDead,
       (* then *)
       trExpr(freq, env, fn t1 => fn env' =>
       letPRIM("t2", IR.T_FLOAT, IR.ITOF, [psvToIRVar (env', PSV.numDead)], fn t2 =>
       letPRIM("prob", IR.T_FLOAT, IR.DIV, [t1, t2], fn prob =>
       letPRIM("r", IR.T_FLOAT, IR.RAND, [], fn r => 
       letPRIM("t3", IR.T_BOOL, IR.GT, [prob, r], fn t3 =>
       IR.mkIF(t3,
        (* then *)
        newParticle (sv_gens, env', fn env'' => k env''),
        (* else *)
        IR.DISCARD)))))),
       (* else *)
       k env))
     end

    (* trExpr(expr, env, state, k : IR.var -> IR.stmt) *)
    (* mkFloatWithinVar (boolVar, env, var, d : Float.float P.domain, stmt : IR.var -> IR.stmt) *)
    fun trPred(cond, env, thenk : ir_env -> IR.stmt, elsek : ir_env -> IR.stmt) = let
      fun grabVar(cond, env, k : IR.var -> ir_env -> IR.stmt) = (case cond
        of P.WITHINF(d, expr) => 
            trExpr(expr, env, fn checkMe => fn env' =>
            mkFloatWithinVar("wv", env', checkMe, d, fn var => k var env'))            
          
         | P.WITHIN3F(d, expr) => 
            trExpr(expr, env, fn checkMe => fn env' =>
            mkVecWithinVar("wv", env', checkMe, d, fn var => k var env'))
          
         | P.DO_INTERSECT {p1, p2, d} =>
           trExpr(p1, env, fn p1var => fn env' =>
           trExpr(p2, env', fn p2var => fn env'' =>
           mkIntBool(env'', p1var, p2var, d, k)))
         
         | P.GTHAN (e1, e2) =>
           trExpr(e1, env, fn e1var => fn env' =>
           trExpr(e2, env, fn e2var => fn env'' =>
           letPRIM("gtVar", IR.T_BOOL, IR.GT, [e1var, e2var], fn var => k var env'')))
                    
         | P.AND(c1, c2) =>
           grabVar(c1, env, fn c1Var => fn env' =>
           grabVar(c2, env', fn c2Var => fn env'' =>
           letPRIM("andVar", IR.T_BOOL, IR.AND, [c1Var, c2Var], fn var => k var env'')))
         
         | P.OR(c1, c2) =>
           grabVar(c1, env, fn c1Var => fn env' =>
           grabVar(c2, env, fn c2Var => fn env'' =>
           letPRIM("andVar", IR.T_BOOL, IR.OR, [c1Var, c2Var], fn var => k var env'')))
           
         | P.XOR(c1, c2) =>
           grabVar(c1, env, fn c1Var => fn env' =>
           grabVar(c2, env', fn c2Var => fn env'' =>
           mkXOR ("xorVar", c1Var, c2Var, fn var => k var env'')))
           
         | P.NOT(c) =>
           grabVar(c, env, fn cvar => fn env' =>
           letPRIM("notVar", IR.T_BOOL, IR.NOT, [cvar], fn var => k var env'))
           
        (* end case *))
     in
      grabVar(cond, env, fn result => fn env' =>
      IR.mkIF(result, thenk(env'), elsek(env')))
     end

    fun compile (P.PG{
       emit as P.EMIT{freq, sv_gens}, act, render,
       vars, state_vars, render_vars
    }) = let
      val blks = ref[]
      
      fun printVar (PSV.V{name, id, ...}) = 
        printErr (String.concat[name, ": ", Int.toString id])
      
      val demand = IR.getDemand(render)
      fun getIRNameForSV (v as PSV.SV{name, ...}) = 
       (case (PSV.SVMap.find (render_vars, v))
         of SOME na => let
           fun inDemand n = List.exists (fn x => #1 x = "ps_" ^ n) demand
          in
           (* Sanity check *)
           if not (inDemand na) then
             raise Fail (String.concat["Variable with name ", name," marked for rendering but not in demand."])
           else
             "ps_" ^ na
          end
          | NONE => "ps_" ^ name
       (* end case *))
      
      fun convertToIR (v as PSV.SV{ty, ...}) = IR.newParam(getIRNameForSV v, IR.psvTyToIRTy ty)
      val v_env = let
	      (* add special globals to free vars *)
        val pgm_vars = PSV.Set.union(PSV.Set.singleton epsilon, vars)
        fun insv (x as PSV.V{name, ty, binding, id, ...}, map) = let
          val x' = (case (ty, !binding)
              of (PSV.T_BOOL,  PSV.UNDEF) => IR.newGlobal(x, IR.T_BOOL)
               | (PSV.T_BOOL,  PSV.BOOL boolVal) => IR.newConst(name, IR.C_BOOL(boolVal))
               | (PSV.T_INT,   PSV.UNDEF) => IR.newGlobal(x, IR.T_INT)
               | (PSV.T_INT,   PSV.INT intVal) => IR.newConst(name, IR.C_INT(intVal))
               | (PSV.T_FLOAT, PSV.UNDEF) => IR.newGlobal(x, IR.T_FLOAT)
               | (PSV.T_FLOAT, PSV.FLOAT floatVal) => IR.newConst(name, IR.C_FLOAT(floatVal))
               | (PSV.T_VEC3F, PSV.UNDEF) => IR.newGlobal(x, IR.T_VEC)
               | (PSV.T_VEC3F, PSV.VEC3F vecVal) => IR.newConst(name, IR.C_VEC(vecVal))
               | _ => raise Fail("Error in setup, type mismatch between PSV vars and their binding.")
			  (* end case *))
		 in
		  PSV.Map.insert (map, x, x')
		 end (* ins *)
		   
	   in
		PSV.Set.foldl insv PSV.Map.empty pgm_vars
	   end (* env *)
		
      fun evalActs theAct env f = (case theAct 
	      of P.SEQ(acts) => (case acts
	        of [] => f env
	         | oneAct :: rest => evalActs oneAct env (fn env' => (evalActs (P.SEQ(rest)) env' f))
	        (* end case *))
	      
	       | P.PRED(cond, thenAct, elseAct) => let
	           val joinBlk = newBlock (env, fn env' => f env')
	           fun joinActs env = goto(env, joinBlk)
	          in
	           trPred(cond, env, 
	             fn env' => evalActs thenAct env' joinActs, 
	             fn env' => evalActs elseAct env' joinActs
	           )
	          end
	         
	       | P.DIE => IR.DISCARD
	       
	       | P.ASSIGN(sv, expr) => let
	         val PSV.SV{ty, ...} = sv
	        in
	         trExpr(expr, env, fn newVar => fn env' =>
	         letPRIM(getIRNameForSV sv, IR.psvTyToIRTy ty, IR.COPY, [newVar],
	           fn thisVar => f (insertSVar(env', sv, thisVar))))
	        end
	        
	      (* end case *))
	      
	  val sv_env = let
	      (* add special globals to free vars *)
        fun insv (x as PSV.SV{name, ty, ...}, map) = let
          val x' = IR.newParam("ps_" ^ name, IR.psvTyToIRTy ty)
		 in
		  PSV.SVMap.insert (map, x, x')
		 end (* ins *)
		   
	   in
		PSV.SVSet.foldl insv PSV.SVMap.empty state_vars
	   end (* env *)
	  
	  val env = TE(blks, v_env, sv_env)
	  
	  (* The entry block is the first block of the program, or in other words, the emitter. *)
	  val emitterBlock = newBlock (env, fn env => trEmitter(emit, env, retState))
	  val physicsBlock = newBlock (env, fn env => evalActs act env retState)

      (* The entry block is the emitter, and the rest of the blocks define the physics processing. *)
      
      fun isGlobal(IR.V{scope, ...}) = (case scope
        of IR.S_GLOBAL(v) => true 
         | _ => false
        (* end case *))
      
	  val outPgm = PSysIR.PGM {
	    globals = PSV.Map.filter isGlobal v_env,
	    persistents = demand,
	    uveOptimized = false,
        emitter = emitterBlock,
	    physics = physicsBlock,
	    render = render
	  }

	  val _ = IR.outputPgm(TextIO.stdErr, outPgm)
	  val optimized = if (Checker.checkIR(outPgm)) then (printErr "\nPre-optimization complete."; Optimize.optimizeIR(outPgm)) else outPgm
	  in
	    IR.outputPgm(TextIO.stdErr, optimized);
	    (* Note: it only succeeds if we can optimize, too *)
        if Checker.checkIR(optimized) then printErr "Compilation succeeded." else ();
        
        optimized
	  end (* compile *)

    end (* Translate *)

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