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 866 - (download) (annotate)
Thu Apr 29 20:16:27 2010 UTC (9 years, 5 months ago) by pavelk
File size: 26636 byte(s)
IR translation now returns a program datatype, which has the emitter block separated from the physics block, and also keeps track of the rendering operation requested. Also, added property fields for variables and blocks in order to track for UVE.
(* 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.particle_group -> 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")

    datatype particle_state = PS of {
	pos : IR.var,		(* vec3 *)
	vel : IR.var,		(* vec3 *)
	size : IR.var,		(* float *)
	isDead : IR.var,	(* bool *)
	color : IR.var,		(* vec3 (NOTE: should be vector4) *)
	dummy : IR.var
      }

  (* special PSV global variables *)
    val timeStep = PSV.new("g_timeStep", PSV.T_FLOAT)	(* physics timestep *)
    val numDead = PSV.new("g_numDead", PSV.T_INT)	(* # of dead particles *)
    val epsilon = PSV.constf(0.00001)
    
  (* constants *)  
    val pi = 3.14159265358979

  (* dummy placeholder *)
    fun dummy (state, k) =
	  IR.mkPRIM(
	    IR.newLocal(
	      "temp", 
	      IR.T_BOOL, 
	      (IR.COPY, [IR.newConst("c", IR.C_BOOL false)])
	    ), 
	    IR.COPY,
	    [IR.newConst("c", IR.C_BOOL false)],
	    k state
	  )

  (* translation environment *)
    datatype env = TE of (IR.block list ref * IR.var PSV.Map.map)

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

    fun insert (TE(blks, env), x, x') = TE(blks, PSV.Map.insert (env, x, x'))

  (* create a block that implements the given continuation *)
    fun newBlock (TE(blks, _), k : particle_state -> IR.stmt) = let
	  val pos = IR.newParam ("ps_pos", IR.T_VEC)
	  val vel = IR.newParam ("ps_vel", IR.T_VEC)
	  val size = IR.newParam ("ps_size", IR.T_FLOAT)
	  val isDead = IR.newParam ("ps_isDead", IR.T_BOOL)
	  val color = IR.newParam ("ps_color", IR.T_VEC)
	  val dummy = IR.newParam ("ps_dummy", IR.T_FLOAT)
	  val state = PS{pos=pos, vel=vel, size=size, isDead=isDead, color=color, dummy=dummy}
	  val blk = IR.newBlock ([pos, vel, size, isDead, color, dummy], k state)
	  in
	    blks := blk :: !blks;
	    blk
	  end
	  
	fun newBlockWithArgs (TE(blks, _), args, k : particle_state -> IR.stmt) = let
	  val pos = IR.newParam ("ps_pos", IR.T_VEC)
	  val vel = IR.newParam ("ps_vel", IR.T_VEC)
	  val size = IR.newParam ("ps_size", IR.T_FLOAT)
	  val isDead = IR.newParam ("ps_isDead", IR.T_BOOL)
	  val color = IR.newParam ("ps_color", IR.T_VEC)
	  val dummy = IR.newParam ("ps_dummy", IR.T_FLOAT)
	  val state = PS{pos=pos, vel=vel, size=size, isDead=isDead, color=color, dummy = dummy}
	  val blk = IR.newBlock ([pos, vel, size, isDead, color, dummy] @ args, k state)
	  in
	    blks := blk :: !blks;
	    blk
	  end

    fun goto (PS{pos, vel, size, isDead, color, dummy}, blk) =
	  IR.mkGOTO(blk, [pos, vel, size, isDead, color, dummy])
	
	fun gotoWithArgs(PS{pos, vel, size, isDead, color, dummy}, args, blk) =
	  IR.mkGOTO(blk, [pos, vel, size, isDead, color, dummy] @ args)

    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

  (* prim bound to state variable (S_LOCAL for now) *)
    fun letSPRIM(x, ty, p, args, body) = let
	  val x' = IR.new(x, IR.S_LOCAL(ref (p, args)), ty)
	  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))))
      	  
  (* Generates a random vector within the given domain and puts it in vecVar *)
    fun genVecVar (vecVar, env, domain, 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)))))
	  
	  (* This is a bit more complicated if we're trying to avoid accessing
	   * the vector variables themselves. Basically the way we can do it is to
	   * decompose the vector connecting min and max into the basis vectors,
	   * scale them independently, and then add them back together.
	   *
	   * !FIXME! Actually do that. Don't have time right now...
	   *)
	    | P.D_BOX{max, min} => raise Fail "Cannot generate point in D_BOX."
	   
	    | 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", insert(env, normVar, norm), P.D_DISC{pt = pt1, normal = normVar, irad = irad, orad = orad}, 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.MULT, [newRand, 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 ptInDisc =>
		letPRIM ("pidn", IR.T_VEC, IR.NORM, [ptInDisc], fn ptInDiscNorm =>		
	      (* Figure out x and y values for our new radius and angle *)
		letPRIM ("rx", IR.T_FLOAT, IR.COS, [randAng], fn radX =>
		letPRIM ("ar1", IR.T_FLOAT, IR.MULT, [newRad, radX], fn amtVecOne =>
		letPRIM ("rv1", IR.T_VEC, IR.SCALE, [amtVecOne, vecInDiscNorm], fn resVecOne =>
		letPRIM ("ry", IR.T_FLOAT, IR.SIN, [randAng], fn radY =>
		letPRIM ("ar2", IR.T_FLOAT, IR.MULT, [newRad, radY], fn amtVecTwo =>
		letPRIM ("rv2", IR.T_VEC, IR.SCALE, [amtVecTwo, ptInDiscNorm], fn resVecTwo =>
		letPRIM ("res", IR.T_VEC, IR.ADD_VEC, [resVecOne, resVecTwo], fn result =>
		letPRIM (vecVar, IR.T_VEC, IR.ADD_VEC, [result, psvToIRVar(env, pt)], stmt))))))))))))))))))))
         
	    | 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", insert(env, normVar, norm), P.D_DISC{pt = pt1, normal = normVar, irad = irad, orad = orad}, 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
     
	    | _ => raise Fail "Cannot generate point in specified domain."
	  (* end case *))
	  (* 
	  | generate (Dplane{pt, n}) = Vec3f.unpack pt
      | generate (Drectangle{pt, u, v}) = Vec3f.unpack pt
      | generate (Dsphere{c, orad, irad}) = Vec3f.unpack c       
      | generate (Dblob{c, stddev}) = Vec3f.unpack c
	  *)
	  
	  
  (* 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 mkWithinVar (boolVar, env, var, d, 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, [psvToIRVar(env, pt), pos], 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, [psvToIRVar(env, pt), pos], fn posToPt =>
		  letPRIM("posToPtLen", IR.T_FLOAT, IR.LEN, [posToPt], fn posToPtLen =>
		  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("inOrad", IR.T_BOOL, IR.GT, [psvToIRVar(env, orad), posToPtLen], fn inOrad =>
		  letPRIM("inIrad", IR.T_BOOL, IR.GT, [posToPtLen, psvToIRVar(env, irad)], 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_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_CYLINDER {pt1: vec3f var, pt2: vec3f var, irad: float var, orad: float 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 domain."
	    (* end case *)
	  end (*end let *)
	  

  (* generate code to produce a random particle state from a domain *)
    fun newParticle (posDomain, velDomain, colDomain, env, k : particle_state -> IR.stmt) = 
	    (* genVecVar (vecVar, env, domain, stmt) *)
	    genVecVar("ps_pos", env, posDomain, fn newPos =>
	    genVecVar("ps_vel", env, velDomain, fn newVel =>
	    genVecVar("ps_col", env, colDomain, fn newCol =>
	    letSPRIM ("ps_size", IR.T_FLOAT, IR.RAND, [], fn newSize =>
	    letSPRIM ("ps_isDead", IR.T_BOOL, IR.COPY, [IR.newConst("fbool", IR.C_BOOL false)], fn newIsDead =>
	      k(PS{pos = newPos, vel = newVel, size = newSize, isDead = newIsDead, color = newCol, dummy = IR.newConst("dmy", IR.C_FLOAT 0.01)}))))))

    (* 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, state, k : IR.var -> particle_state -> IR.stmt) = let
      val newNorm = IR.newParam("n", IR.T_VEC)
      val nextBlk = newBlockWithArgs(env, [newNorm], k(newNorm))
      val PS{pos, ...} = state
     in
      (case d
	  of P.D_PLANE{pt, normal} => letPRIM(retNorm, IR.T_VEC, IR.COPY, [psvToIRVar(env, normal)], 
	      fn newNormVar => gotoWithArgs(state, [newNormVar], nextBlk))
	   | P.D_DISC{pt, normal, irad, orad} => 
	      mkWithinVar("inP", env, pos, d, fn inPlane =>
		  IR.mkIF(inPlane, 
		    (* then *)
		    letPRIM(retNorm, IR.T_VEC, IR.COPY, [psvToIRVar(env, normal)],
		      fn newNormVar => gotoWithArgs(state, [newNormVar], nextBlk)),
		    (* else *)
		    letPRIM(retNorm,
		      IR.T_VEC,
			  IR.SCALE, 
			  [IR.newConst("negOne", IR.C_FLOAT ~1.0), psvToIRVar(env, normal)], 
			  fn newNormVar => gotoWithArgs(state, [newNormVar], nextBlk))
		   )
		 )
         
	   | P.D_SPHERE{center, irad, orad} => let
	      val PS{pos, vel, size, isDead, color, ...} = state
	      in
		    letPRIM("sv", IR.T_VEC, IR.SUB_VEC, [pos, psvToIRVar(env, center)], fn subVec =>
	        letPRIM(retNorm, IR.T_VEC, IR.NORM, [subVec], fn newNormVar => k newNormVar state
		    ))
	      end
           
	   | _ => raise Fail("Cannot find normal to point of specified domain.")
	 (* end case *))
	end
	
	fun trEmitter(emit, env, state, k : particle_state -> IR.stmt) = let
	  fun retState s = let
	    val PS{pos, vel, size, isDead, color, dummy} = s
	   in
	    IR.mkRETURN [pos, vel, size, isDead, color, dummy]
	   end

	  val PS{pos, vel, size, isDead, color, dummy} = state
	  val P.EMIT{maxNum, posDomain, velDomain, colDomain, ...} = emit
	  val blk = newBlock (env, k)
	 in
      IR.mkIF(isDead,
       (* then *)
       letPRIM("t1", IR.T_FLOAT, IR.ITOF, [psvToIRVar (env, maxNum)], fn t1 =>
       letPRIM("t2", IR.T_FLOAT, IR.ITOF, [psvToIRVar (env, 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 (posDomain, velDomain, colDomain, env,
         fn state' => retState state'),
        (* else *)
        IR.DISCARD)))))),
       (* else *)
       IR.DISCARD)
     end
	
	fun trPred(pred, env, state, thenk : particle_state -> IR.stmt, elsek : particle_state -> IR.stmt) = let
	  val PS{pos, vel, size, isDead, color, ...} = state
	  val P.PR{ifstmt, ...} = pred
	  val thenBlk = newBlock(env, thenk)
	  val elseBlk = newBlock(env, elsek)
	 in
	  case ifstmt
	   of P.WITHIN(d) => mkWithinVar("wv", env, pos, d, fn withinVar =>
	    IR.mkIF(withinVar, goto(state, thenBlk), goto(state, elseBlk)))
	    | P.WITHINVEL(d) => mkWithinVar("wv", env, vel, d, fn withinVar =>
	    IR.mkIF(withinVar, goto(state, thenBlk), goto(state, elseBlk)))
	 end	      
	
    fun trAct (action, env, state, k : particle_state -> IR.stmt) = let
	  val PS{pos, vel, size, isDead, color, dummy} = state
	  in
	    case action
	     of P.BOUNCE{friction, resilience, cutoff, d} => let		  
		  val blk = newBlock (env, k)		  
		  val negOne = IR.newConst("negOne", IR.C_FLOAT ~1.0)
		  in
		    letPRIM("vs", IR.T_VEC, IR.SCALE, [psvToIRVar(env, timeStep), vel], fn velScale =>
		    letPRIM("np", IR.T_VEC, IR.ADD_VEC, [pos, velScale], fn nextPos =>
		    mkWithinVar("wnp", env, pos, d, fn withinNextPos =>
		    IR.mkIF(withinNextPos,
		      (*then*)
			normAtPoint("n", d, env, state, fn normAtD => fn state' => let
               val PS{pos=nextPos, vel=nextVel, size=nextSize, isDead=nextIsDead, color=nextColor, dummy=nextDummy} = state'
			  in
			   letPRIM("negVel", IR.T_VEC, IR.SCALE, [negOne, nextVel], fn negVel =>
			   letPRIM("dnv", IR.T_FLOAT, IR.DOT, [negVel, normAtD], fn dotNegVel =>
			   letPRIM("sn", IR.T_VEC, IR.SCALE, [dotNegVel, normAtD], fn scaledN =>
			   letPRIM("t", IR.T_VEC, IR.SUB_VEC, [negVel, scaledN], fn tang =>
			
			   letPRIM("tlsq", IR.T_FLOAT, IR.LEN_SQ, [tang], fn tangLenSq =>
			   letPRIM("cosq", IR.T_FLOAT, IR.MULT, [psvToIRVar(env, cutoff), psvToIRVar(env, cutoff)], fn cutoffSq =>
			   letPRIM("inco", IR.T_BOOL, IR.GT, [tangLenSq, cutoffSq], fn inCutoff =>
			
			   letPRIM("resNorm", IR.T_VEC, IR.SCALE, [psvToIRVar(env, resilience), scaledN], fn resNorm =>
			
			   IR.mkIF(inCutoff,
			     (*then*)
			     letPRIM("fInv", IR.T_FLOAT, IR.SUB, [IR.newConst("one", IR.C_FLOAT 1.0), psvToIRVar(env, friction)], fn frictInv =>
			     letPRIM("f", IR.T_FLOAT, IR.MULT, [negOne, frictInv], fn modFrict =>
			     letPRIM("fTang", IR.T_VEC, IR.SCALE, [modFrict, tang], fn frictTang =>
			     letPRIM("newVel", IR.T_VEC, IR.ADD_VEC, [frictTang, resNorm], fn newVel =>
			      goto(PS{pos=nextPos, vel=newVel, size=nextSize, isDead=nextIsDead, color=nextColor, dummy=nextDummy}, blk)
			    )))),
			     (*else*)
			     letPRIM("fTang", IR.T_VEC, IR.SCALE, [negOne, tang], fn frictTang =>
			     letPRIM("newVel", IR.T_VEC, IR.ADD_VEC, [frictTang, resNorm], fn newVel =>
			      goto(PS{pos=nextPos, vel=newVel, size=nextSize, isDead=nextIsDead, color=nextColor, dummy=nextDummy}, blk)
			     ))
			 )))))))))
			 end
		      ),
		      (*else*)
		      goto(state, blk)))))
		  end
		  
	      | P.GRAVITY(dir) =>
		    letPRIM("scaledVec", IR.T_VEC, IR.SCALE, [psvToIRVar(env, timeStep), psvToIRVar(env, dir)], fn theScale =>
		    letPRIM("nextVel", IR.T_VEC, IR.ADD_VEC, [theScale, vel], fn newVel =>
		      k(PS{pos = pos, vel = newVel, size = size, isDead = isDead, color = color, dummy=dummy})))
		  
	      | P.MOVE =>
	      	letPRIM("scaledVec", IR.T_VEC, IR.SCALE, [psvToIRVar(env, timeStep), vel], fn theScale =>
		    letPRIM("nextPos", IR.T_VEC, IR.ADD_VEC, [theScale, pos], fn newPos =>
		      k(PS{pos = newPos, vel = vel, size = size, isDead = isDead, color = color, dummy=dummy})))
	      (*
	      | P.SINK({d, kill_inside}) => 
		    mkWithinVar("isWithin", env, state, d, fn withinVal =>
		    mkXOR ("shouldNotKill", withinVal, psvToIRVar(env, kill_inside),
		      fn shouldNotKill => 
		    letPRIM("shouldKill", IR.T_BOOL, IR.NOT, [shouldNotKill], fn shouldKill =>
		    letPRIM("isReallyDead", IR.T_BOOL, IR.OR, [shouldKill, isDead], fn isReallyDead =>
		    k(PS{pos = pos, vel = vel, size = size, isDead = isReallyDead, color = color})
			))))
	      *)
	      
	      | P.ORBITLINESEG {endp1, endp2, maxRad, mag} => let
	          val blk = newBlock (env, k)
	        in
	        letPRIM("subVec", IR.T_VEC, IR.SUB_VEC, [psvToIRVar(env, endp2), psvToIRVar(env, endp1)], fn subVec =>
	        letPRIM("vecToEndP", IR.T_VEC, IR.SUB_VEC, [pos, psvToIRVar(env, endp1)], fn vecToEndP =>
	        letPRIM("basis", IR.T_VEC, IR.NORM, [subVec], fn basis =>
	        letPRIM("parDot", IR.T_FLOAT, IR.DOT, [basis, vecToEndP], fn parDot =>
	        letPRIM("parVec", IR.T_VEC, IR.SCALE, [parDot, basis], fn parVec =>
	        letPRIM("closestP", IR.T_VEC, IR.ADD_VEC, [psvToIRVar(env, endp1), parVec], fn closestP =>
	        letPRIM("vecToP", IR.T_VEC, IR.SUB_VEC, [closestP, pos], fn vecToP =>
	        letPRIM("distToP", IR.T_FLOAT, IR.LEN, [vecToP], fn distToP =>
	        letPRIM("effRad", IR.T_FLOAT, IR.SUB, [psvToIRVar(env, maxRad), distToP], fn effRad =>
	        letPRIM("radInDist", IR.T_BOOL, IR.GT, [psvToIRVar(env, epsilon), effRad], fn radInDist =>
	        IR.mkIF(radInDist,
	          (*then*)
	          goto(state, blk),
	          (*else*)
	          letPRIM("magRatio", IR.T_FLOAT, IR.DIV, [distToP, psvToIRVar(env, maxRad)], fn magRatio =>
	          letPRIM("oneMinMR", IR.T_FLOAT, IR.SUB, [IR.newConst("one", IR.C_FLOAT 1.0), magRatio], fn oneMinMR =>
	          letPRIM("gravityMag", IR.T_FLOAT, IR.MULT, [oneMinMR, psvToIRVar(env, mag)], fn gravityMag =>
	          letPRIM("totalMag", IR.T_FLOAT, IR.MULT, [gravityMag, psvToIRVar(env, timeStep)], fn totMag =>
	          letPRIM("accVec", IR.T_VEC, IR.SUB_VEC, [closestP, pos], fn accVec =>
	          letPRIM("acc", IR.T_VEC, IR.SCALE, [totMag, accVec], fn acc =>
	          letPRIM("newVel", IR.T_VEC, IR.ADD_VEC, [vel, acc], fn newVel =>
	          goto(PS{pos = pos, vel = newVel, size = size, isDead = isDead, color = color, dummy=dummy}, blk)
	          )))))))
	        )))))))))))
	        end
	        
	      (* just kill it. *)
	      | P.DIE => k(PS{pos = pos, vel = vel, size = size, isDead = IR.newConst("falseVar", IR.C_BOOL true), color = color, dummy=dummy})
	      | _ => raise Fail("Action not implemented...")
	    (* end case *)
	  end

    fun compile (P.PG{emit as P.EMIT{maxNum, vars=emitVars, ...}, act as P.PSAE{action=root_act, vars=actionVars}, render}) = let
	  val blks = ref[]
	  val env = let
	      (* add special globals to free vars *)
		val vars = PSV.Set.union(emitVars, PSV.Set.addList(actionVars, [maxNum, numDead, timeStep, epsilon]))
		fun ins (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 IR and PSV vars.")
			    (* end case *))
		      in
			PSV.Map.insert (map, x, x')
		      end
		in
		  TE(blks, PSV.Set.foldl ins PSV.Map.empty vars)
		end
	  fun trActs [] state = let 
		val PS{pos, vel, size, isDead, color, dummy} = state
		in
		  IR.mkRETURN[ pos, vel, size, isDead, color, dummy ]
		end (* trActs *)
	    | trActs (psa :: psal) state = (case psa 
	      of P.SEQ(acts) => (case acts
	         of [] => raise Fail "Should never reach here."
	          | [act] => trAct(act, env, state, trActs psal)
	          | act :: rest => trAct(act, env, state, trActs (P.SEQ(rest) :: psal))
	        (* end case *))
	       | P.PRED(pred as P.PR{thenstmt=t, elsestmt=e, ...}) => 
	          trPred(pred, env, state, trActs (t @ psal), trActs (e @ psal))
	      (* end case *))
	    
	  val entryBlock = newBlock (env, fn pstate => trEmitter(emit, env, pstate, fn state => trActs root_act state))
	  val outPgm = PSysIR.PGM {
            emitter = entryBlock,
	    physics = List.drop(!blks, 1),
	    render = render
	  }
	  in
	    printErr "Emitter: ";
	    IR.output(TextIO.stdErr, [entryBlock]);
	    printErr "\nPhysics: ";
	    IR.output(TextIO.stdErr, List.drop(!blks, 1));
	    if Checker.checkIR(outPgm) then
	     printErr "Compilation succeeded."
	    else
	     ();
	    outPgm
	  end (* compile *)

    end (* Translate *)

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