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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1107 - (download) (annotate)
Wed Apr 6 22:46:51 2011 UTC (8 years, 5 months ago) by pavelk
File size: 26757 byte(s)
Work on particle system stuff. Still a WIP, just checking it in so that I can work on it some more from home.
(* particles.sml
 *
 * COPYRIGHT (c) 2011 John Reppy (http://www.cs.uchicago.edu/~jhr)
 * All rights reserved.
 *)
 
structure ParticlesImp =
  struct

    structure OP = OldParticles
    structure PSV = PSVar
    structure IR = PSysIR
    structure VSet = PSV.Set
    structure SVSet = PSV.SVSet
    structure DB = DataBuffer
    
    type float = GL.float
    type vec3f = Vec3f.vec3
    type color4f = SML3dTypes.color4f
    type color3f = SML3dTypes.color3f
    
    fun printErr s = TextIO.output(TextIO.stdErr, s ^ "\n")

    (***** DOMAINS *****)
	
    type 'a var = 'a PSV.var
    type 'a state_var = 'a PSV.state_var
(*
    datatype variable = V of word
*)
    
    val sv_pos = PSV.newSV("sv_pos", PSV.vec3fTy)
    val sv_vel = PSV.newSV("sv_vel", PSV.vec3fTy)
    val sv_ttl = PSV.newSV("sv_ttl", PSV.floatTy)
    
    datatype domain_rep
      = D_POINT of PSV.var_rep
      | D_LINE of {pt1: PSV.var_rep, pt2: PSV.var_rep}
      | D_TRIANGLE of {pt1: PSV.var_rep, pt2: PSV.var_rep, pt3: PSV.var_rep}
      | D_PLANE of {pt: PSV.var_rep, normal: PSV.var_rep}
      | D_RECT of {pt: PSV.var_rep, htvec: PSV.var_rep, wdvec: PSV.var_rep}
      | D_BOX of {min: PSV.var_rep, max: PSV.var_rep}    
      | D_SPHERE of {center: PSV.var_rep, irad: PSV.var_rep, orad: PSV.var_rep}
      | D_CYLINDER of {pt1: PSV.var_rep, pt2: PSV.var_rep, irad: PSV.var_rep, orad: PSV.var_rep}
      | D_CONE of {pt1: PSV.var_rep, pt2: PSV.var_rep, irad: PSV.var_rep, orad: PSV.var_rep}
      | D_BLOB of {center: PSV.var_rep, stddev: PSV.var_rep}
      | D_DISC of {pt: PSV.var_rep, normal: PSV.var_rep, irad: PSV.var_rep, orad: PSV.var_rep}
    type 'a domain = domain_rep
        
    datatype distribution_rep
      = DIST_NORMAL of {mu : float var, sigma : float var}
      | DIST_DEC_LIN
      | DIST_INC_LIN
      | DIST_UNIFORM
      | DIST_TEXTURED of Texture.texture_id
    type 'a distribution = distribution_rep
      
    (* This is polymorphic only to enforce type safety to the user, but otherwise,
     * underneath the hood we have to make it ambiguous to avoid bloating
     * the code *)
    datatype expression
      = CONSTF of float
      | CONST3F of vec3f
      | VAR of PSV.var_rep
      | STATE_VAR of PSV.state_var_rep
      | GENERATE3F of vec3f domain * vec3f distribution
      | GENERATEF of float domain * float distribution
      | ADD of expression * expression
      | SCALE of expression * expression
      | DIV of expression * expression
      | NEG of expression
      | DOT of expression * expression
      | CROSS of expression * expression
      | NORMALIZE of expression
      
      | LENGTH of expression
      
      | INTERSECT of intersection_query 
      | NORMALTO of expression * domain_rep
            
    and condition
      = WITHINF of float domain * expression
      | WITHIN3F of vec3f domain * expression
      | DO_INTERSECT of intersection_query
      | GTHAN of expression * expression (* Is the first greater than the second *)
      | BOOLVAR of PSV.var_rep
      
      (* General boolean expressions *)
      | AND of condition * condition
      | OR of condition * condition
      | XOR of condition * condition
      | NOT of condition      
    withtype 'a ty = 'a -> expression     
    and intersection_query = {p1 : expression, p2 : expression, d : domain_rep}
    
    type 'a expr = expression
    
    val varToExp = VAR
    val stateVarToExp = STATE_VAR
    
    val floatTy : float ty = CONSTF
    val vec3fTy : vec3f ty = CONST3F

    fun const (theTy, theVal) = theTy theVal
        
    fun generate(floatTy, d) = GENERATEF(d, DIST_UNIFORM)
    fun generate(vec3fTy, d) = GENERATE3F(d, DIST_UNIFORM)
    fun generateWithDist(floatTy, dom, dist) = GENERATEF(dom, dist)
    fun generateWithDist(vec3fTy, dom, dist) = GENERATE3F(dom, dist)
	
    fun add(e1, e2) = ADD(e1, e2)
    fun scale(fex, vex) = SCALE(fex, vex)
    fun neg(e) = NEG(e)
    fun dot(e1, e2) = DOT(e1, e2)
    fun cross(e1, e2) = CROSS(e1, e2)
    fun mult(e1, e2) = SCALE(e1, e2)
    fun divide(e1, e2) = DIV(e1, e2)
    fun length(v) = LENGTH(v)
    fun normalize(v) = NORMALIZE(v) 
    
    fun adds(v1, v2, f) = ADD(v1, SCALE(v2, f)) 
    fun sub(v1, v2) = ADD(v1, NEG(v2))
    
    fun getNormal(v, d) = NORMALTO(v, d)
       
  (* A blank action, this does nothing. *)
    val nop = CONSTF(0.0)
    
  (* Conditions... *)
    fun testWithin(floatTy, {arg, d}) = WITHINF(d, arg)
    fun testWithin(vec3fTy, {arg, d}) = WITHIN3F(d, arg)
    fun testGreater({arg, test}) = GTHAN(arg, test) 
    
    fun testBool v = BOOLVAR v
    
    (* Common boolean expressions *)
    fun testAnd(c1, c2) = AND(c1, c2)
    fun testOr(c1, c2) = OR(c1, c2)
    fun testXOr(c1, c2) = XOR(c1, c2)
    fun testNot(c) = NOT(c)
    
    fun intersect q = { c = DO_INTERSECT q, pt = INTERSECT q }
    
  (* get the free variables of a domain *)
    fun fvsOfDomain (D_POINT x) = VSet.singleton x
      | fvsOfDomain (D_LINE{pt1, pt2}) = VSet.fromList([pt1, pt2])
      | fvsOfDomain (D_TRIANGLE{pt1, pt2, pt3}) = VSet.fromList([pt1, pt2, pt3])
      | fvsOfDomain (D_PLANE{pt, normal}) = VSet.fromList([pt, normal])
      | fvsOfDomain (D_RECT{pt, htvec, wdvec}) = VSet.fromList([pt, htvec, wdvec])
      | fvsOfDomain (D_BOX{min, max}) = VSet.fromList([min, max])
      | fvsOfDomain (D_SPHERE{center, irad, orad}) = VSet.fromList([center, irad, orad])
      | fvsOfDomain (D_CYLINDER{pt1, pt2, irad, orad}) = VSet.fromList([pt1, pt2, irad, orad])
      | fvsOfDomain (D_CONE{pt1, pt2, irad, orad}) = VSet.fromList([pt1, pt2, irad, orad])
      | fvsOfDomain (D_BLOB{center, stddev}) = VSet.fromList([center, stddev])
      | fvsOfDomain (D_DISC{pt, normal, irad, orad}) = VSet.fromList([pt, normal, irad, orad])
      
    fun fvsOfDistribution(DIST_NORMAL {mu, sigma}) = VSet.fromList [mu, sigma]
      | fvsOfDistribution(DIST_DEC_LIN) = VSet.empty
      | fvsOfDistribution(DIST_INC_LIN) = VSet.empty
      | fvsOfDistribution(DIST_UNIFORM) = VSet.empty
      | fvsOfDistribution(DIST_TEXTURED _) = VSet.empty

  (***** ACTIONS *****)

    datatype action 
      = SEQ of action list
      | PRED of condition * action * action
      | ASSIGN of PSV.state_var_rep * expression
(*
      | LET of variable * expression * action
*)
      | DIE
      
    fun branch {c, thenAct, elseAct } = PRED(c, thenAct, elseAct)
      
    val nop = SEQ []
      
    (* Particles are tested to see whether they will pass from being outside the specified domain to
     * being inside it within look_ahead time units from now if the next Move() action were to occur 
     * now. The specific direction and amount of turn is dependent on the kind of domain being 
     * avoided.
     *
     * !FIXME! Implement me!
     *)
    fun avoid {
	  magnitude : float PSV.var, epsilon : float PSV.var,
	  lookAhead : float PSV.var, d : domain_rep
	} = nop;
	
    (* Particles are tested to see whether they will pass from being outside the specified vec3f domain to
     * being inside it if the next Move() action were to occur now. If they would pass through the 
     * surface of the vec3f domain, they are instead bounced off it. That is, their velocity vector is
     * decomposed into components normal to the surface and tangent to the surface. The direction of
     * the normal component is reversed, and friction, resilience and cutoff are applied to the 
     * components. They are then recomposed into a new velocity heading away from the surface.
     *)
     
    fun bounceVar ({
	  friction : float PSV.var, resilience : float PSV.var,
	  cutoff : float PSV.var, d : domain_rep
	}, {v, dv}) = let
	  val startPt = stateVarToExp v
	  val endPt = adds(startPt, stateVarToExp dv, varToExp PSV.timeStep)
	  val {c = intQuery, pt = intPt} = intersect { p1 = startPt, p2 = endPt, d = d }
	  val refLen = length (sub (intPt, endPt))
	  val toReflect = stateVarToExp dv
	  val norm = getNormal(intPt, d)
	  val refPerp = scale(dot(toReflect, norm), norm)
	  val refPara = sub(toReflect, refPerp)
	  val refVec = add(scale(varToExp resilience, refPerp), scale(varToExp friction, neg(refPara)))
	  
	 in
	  branch {
	    c = intQuery,
	    thenAct = SEQ[
	      branch {
	        c = testGreater {arg = length(refVec), test = varToExp cutoff},
	        thenAct = ASSIGN(dv, scale(varToExp cutoff, normalize(refVec))),
	        elseAct = ASSIGN(dv, refVec)
	      },
	      ASSIGN(v, adds(intPt, stateVarToExp dv, divide(refLen, varToExp PSV.timeStep))) 
	    ],
	    elseAct = nop
	  }
	end
	
	fun bounce(x) = bounceVar (x, {v = sv_pos, dv = sv_vel})
	
    (* If a particle's velocity magnitude is within vlow and vhigh, then multiply each component of
     * the velocity by the respective damping constant. *)
    fun dampingVar ({coeff, vlow, vhi}, v) = let
      val mag = length (stateVarToExp v)
      val tooBig = testGreater {arg = mag, test = varToExp vhi}
      val tooSmall = testGreater {arg = varToExp vlow, test = mag }
      val within = testAnd(tooBig, tooSmall)
     in
      branch {
        c = within,
        thenAct = ASSIGN(v, scale(varToExp coeff, stateVarToExp v)),
        elseAct = nop
      }
     end
     
    fun damping x = dampingVar (x, sv_vel)
	  
    (* Causes an explosion by accelerating all particles away from the center. Particles are 
     * accelerated away from the center by an amount proportional to magnitude. The shock wave of 
     * the explosion has a gaussian magnitude. The peak of the wave front travels spherically 
     * outward from the center at the specified velocity. So at a given time step, particles at a 
     * distance (velocity * age) from center will receive the most acceleration, and particles not
     * at the peak of the shock wave will receive a lesser outward acceleration.
     *)
    fun explosion {
	    center : vec3f PSV.var, velocity : float PSV.var, magnitude : float PSV.var,
	    stdev : float PSV.var, epsilon : float PSV.var, age : float PSV.var
	  } = nop

	(* This allows snaky effects where the particles follow each other. Each particle is accelerated 
     * toward the next particle in the group. The follow action does not affect the last particle in
     * the group. This allows controlled effects where the last particle in the group is killed
     * after each time step and replaced by a new particle at a slightly different position. See 
     * KillOld to learn how to kill the last particle in the group after each step.
     *)
    fun follow {
      magnitude : float PSV.var, epsilon : float PSV.var, maxRadius : float PSV.var
    } = nop
    
    (* Each particle is accelerated toward each other particle. *)
    fun gravitate {mag : float PSV.var, epsilon : float PSV.var, maxRad : float PSV.var} 
      = nop
      
    (* The scaled acceleration vector is simply added to the velocity vector of each particle at 
     * each time step.
     *)
    fun accelerate a = ASSIGN(sv_vel, adds(stateVarToExp sv_vel, varToExp a, varToExp PSV.timeStep))
    fun gravity mag = ASSIGN(sv_vel, adds(stateVarToExp sv_vel, scale(varToExp mag, CONST3F {x=0.0, y= ~1.0, z=0.0}), varToExp PSV.timeStep))
    
    (*  Removes all particles older than age_limit. But if kill_less_than is true, it instead 
     * removes all particles newer than age_limit. age_limit is not clamped, so negative values are
     * ok. This can be used in conjunction with StartingAge(-n) to create and then kill a particular 
     * set of particles.
     *)	 
    fun killOld {age : float PSV.var, kill_less_than : bool PSV.var} = let
      val master = testBool kill_less_than
      val older = testGreater {arg = stateVarToExp sv_ttl, test = varToExp age}
      val younger = testGreater {arg = varToExp age, test = stateVarToExp sv_ttl} 
     in
      branch {
        c = master,
        thenAct = branch {
          c = younger,
          thenAct = DIE,
          elseAct = nop
        },
        elseAct = branch {
          c = older,
          thenAct = DIE,
          elseAct = nop
        }
      }
    end
    	
    (* Each particle is accelerated toward the weighted mean of the velocities of the other 
     * particles in the group.
     *)	          	
    fun matchVelocity {mag : float PSV.var, epsilon : float PSV.var, maxRad : float PSV.var} 
        = nop
 
    (* This action actually updates the particle positions by adding the current velocity to the 
     * current position and the current rotational velocity to the current up vector. This is 
     * typically the last particle action performed in an iteration of a particle simulation, and 
     * typically only occurs once per iteration.
     *)     
    val move = 
      ASSIGN(sv_pos, 
        adds(
          stateVarToExp sv_pos, 
          stateVarToExp sv_vel, 
          varToExp PSV.timeStep
        )
      )
    
    (* For each particle, this action computes the vector to the closest point on the line, and 
     * accelerates the particle in that direction.
     *)  
    fun orbitLineSegment {endp1, endp2, mag, maxRad} = nop
      
    (* For each particle, this action computes the vector to the center point, and accelerates the 
     * particle in the vector direction.
     *)
	fun orbitPoint (opAct as {center : vec3f PSV.var, mag : float PSV.var, maxRad : float PSV.var})
	  = nop

    (* For each particle, chooses an acceleration vector from the specified vec3f domain and adds it to 
     * the particle's velocity. Reducing the time step, dt, will make a higher probability of being 
     * near the original velocity after unit time. Smaller dt approach a normal distribution of 
     * velocity vectors instead of a square wave distribution.
     *)  
	fun randomAccel d = nop

    (* Chooses a displacement vector from the specified vec3f domain and adds it to the particle's 
     * position. Reducing the time step, dt, will make a higher probability of being near the 
     * original position after unit time. Smaller dt approach a normal distribution of particle
     * positions instead of a square wave distribution.
     *)
    fun randomDisplace d = nop

    (* For each particle, sets the particle's velocity vector to a random vector in the specified
     * vec3f domain. This function is not affected by dt.
     *)
    fun randomVelocity d = nop


  (* Computes each particle’s speed (the magnitude of its velocity vector) and if it is less than 
   * min_speed or greater than max_speed the velocity is scaled to within those bounds, while 
   * preserving the velocity vector’s direction.
   *)     
    fun limit ({min : float PSV.var, max : float PSV.var}, v) = let
      val mag = length (stateVarToExp v)
      val bigger = testGreater {arg = mag, test = varToExp max}
      val smaller = testGreater {arg = varToExp min, test = mag}
     in
      branch {
        c = bigger,
        thenAct = ASSIGN(v, varToExp max),
        elseAct = branch {
          c = smaller,
          thenAct = ASSIGN(v, varToExp min),
          elseAct = nop
        }
      }
     end
      
    fun speedLimit r = limit (r, sv_vel)

  (* Modifies the color and alpha of each particle to be scale percent of the way closer to the 
   * specified color and alpha. scale is multiplied by dt before scaling the sizes. Thus, using 
   * smaller dt causes a slightly faster approach to the target color.
   *)     
    fun targetColor {color : vec3f PSV.var, alpha: float PSV.var, scale : float PSV.var}
      = nop

  (* Modifies the size of each particle to be scale percent of the way closer to the specified 
   * size triple. This makes sizes grow asymptotically closer to the given size. scale is 
   * multiplied by dt before scaling the sizes. Thus, using smaller dt causes a slightly faster
   * approach to the target size. The separate scales for each component allow only selected 
   * components to be scaled.
   *)
    fun targetSize {size : vec3f PSV.var, scale : vec3f PSV.var}
      = nop

  (* Modifies the velocity of each particle to be scale percent of the way closer to the specified 
   * velocity. This makes velocities grow asymptotically closer to the given velocity. scale is 
   * multiplied by dt before scaling the velocities. Thus, using smaller dt causes a slightly 
   * faster approach to the target velocity.
   *)
    fun targetVelocity (targetVel, scale)
      = nop

  (* The vortex is a complicated action to use, but when done correctly it makes particles fly 
   * around like in a tornado.
   *)     
    fun vortex {
	    center : vec3f PSV.var, axis : vec3f PSV.var, mag : float PSV.var,
	    epsilon : float PSV.var, maxRad : float PSV.var
	  } = nop

  (* The particle just dies (is considered invalid) *)
    val die = DIE

    val sequence = SEQ
    
(*
//  (* This is a generic "add an action to a current particle group" function. Currently action lists
//   * need to be recreated before each update call, but eventually this will only be done in setup.
//   *)
//    
//  fun sequence [] = nop
//     | sequence acts = let
//	  fun actBuilder [] = raise Fail "Should never reach here."
//	    | actBuilder [a] = a
//	    | actBuilder (a :: acs) = catAction(a, actBuilder(acs))
//	  fun condense [] = []
//	    | condense (a :: acs) = let 
//		fun condensePred (PR{ifstmt, thenstmt, elsestmt}) = PR{
//			ifstmt = ifstmt,
//			thenstmt = condense thenstmt,
//			elsestmt = condense elsestmt}
//		in
//		  case a
//		   of PRED p => PRED(condensePred p) :: condense(acs)
//		    | SEQ(actions) => let
//			val condensed = condense(acs)
//			val identity = a :: condensed
//			in
//			  case condensed
//			   of [] => identity
//			    | a1 :: rest => (case a1
//				 of PRED(p) => identity
//				  | SEQ(actions2) => SEQ(actions @ actions2) :: rest
//				(* end case *))
//			  (* end case *)
//			end
//		  (* end case *)
//		end
//	  val PSAE{action, vars} = actBuilder(acts)
//	  in
//	    PSAE{action = condense(action), vars = vars}
//	  end
*)
    
    fun normal_dist settings = DIST_NORMAL(settings)
    val dec_lin_dist = DIST_DEC_LIN
    val inc_lin_dist = DIST_INC_LIN
    val uniform_dist = DIST_UNIFORM
    val uniform_vec_dist = DIST_UNIFORM
    fun textured_float_dist tex = DIST_TEXTURED tex
    fun textured_vec_dist tex = DIST_TEXTURED tex
    
    val point = D_POINT
    fun line (endPt1, endPt2) = D_LINE{pt1 = endPt1, pt2 = endPt2}
    fun triangle (p1, p2, p3) = D_TRIANGLE{pt1 = p1, pt2 = p2, pt3 = p3}
    fun plane {pt, n} = D_PLANE{pt=pt, normal=n}
    fun rectangle {corner, wid, ht} = D_RECT{pt=corner, htvec=ht, wdvec=wid}
    fun box {min, max} = D_BOX{min=min, max=max}
    fun sphere {c, r} = D_SPHERE{center = c, irad = PSV.constf 0.0, orad = r}
    fun ball {c, ir, or} = D_SPHERE{center=c, irad=ir, orad=or}
    fun tube {point1, point2, irad, orad} = 
	  D_CYLINDER{pt1=point1, pt2=point2, irad=irad, orad=orad}
    fun cylinder {point1, point2, rad} = 
	  D_CYLINDER{pt1=point1, pt2=point2, irad= PSV.constf 0.0, orad = rad}
    fun cone {apex, cbase, irad, orad} = 
	  D_CONE{pt1=apex, pt2=cbase, irad=irad, orad=orad}
    fun blob {center, stddev} = D_BLOB{center=center, stddev=stddev}
    fun disc {center, normal, irad, orad} = 
	  D_DISC{pt=center, normal=normal, irad=irad, orad=orad}
    fun range r = box r
    val value = point

      
    datatype generator = GEN of {
      var : PSV.state_var_rep,
      exp : expression
    }
    
    datatype emitter = EMIT of {
      freq : expression,
      sv_gens : generator list
    }
    
    fun newEmitter({range, positions, velocities, lifetimes}) = EMIT {
      freq = range,
      sv_gens = [
        GEN { var = sv_pos, exp = positions },
        GEN { var = sv_vel, exp = velocities },
        GEN { var = sv_ttl, exp = lifetimes }
      ]
    }
    
    datatype renderer = REND of {
      prim : PSysIR.renderer,
      sv_gens : generator list,
      names : string PSV.SVMap.map
    }
    
    fun points {colors as (sv, exp_color)} = REND { 
      prim = PSysIR.POINTS, 
      sv_gens = [ GEN { var = sv, exp = exp_color } ],
      names = PSV.SVMap.singleton (sv, "color")
    }
    
    fun texQuads {textureList, sizes, rotations} = let
      val sing = PSV.SVMap.singleton
      val union = PSV.SVMap.unionWith (fn x => raise Fail("Adding the same variable."))
      val (sv_sz, exp_sz) = sizes
      val (sv_rot, exp_rot) = rotations
     in
      REND {
        prim = PSysIR.TEXTURED_QUADS(textureList),
        sv_gens = [
          GEN { var = sv_sz, exp = exp_sz },
          GEN { var = sv_rot, exp = exp_rot }
        ],
        names = union (sing (sv_sz, "size"), sing (sv_rot, "rotation"))
      }
     end
      
    datatype program = PG of {
	  emit: emitter, 
	  act : action,
	  render : PSysIR.renderer,
	  vars : VSet.set,
	  state_vars : SVSet.set,
	  render_vars : string PSV.SVMap.map
    }
       
    fun create {emit, act, render} = let
      fun extractVars(expr) = let
        fun evh(CONSTF f) = VSet.empty 
          | evh(CONST3F vec) = VSet.empty 
          | evh(VAR v) =  VSet.singleton v
          | evh(STATE_VAR v) = VSet.empty 
          | evh(GENERATEF (dom, dist)) = VSet.union(fvsOfDomain dom, fvsOfDistribution dist)
          | evh(GENERATE3F (dom, dist)) = VSet.union(fvsOfDomain dom, fvsOfDistribution dist)
          | evh(ADD (e1, e2)) = VSet.union(evh(e1), evh(e2)) 
          | evh(NEG ex) = evh(ex)
          | evh(SCALE (e1, e2)) = VSet.union(evh(e1), evh(e2))
          | evh(DOT (e1, e2)) = VSet.union(evh(e1), evh(e2))
          | evh(CROSS (e1, e2)) = VSet.union(evh(e1), evh(e2))
       in
        evh(expr)
       end (* extractVars *)
       
      fun extractStateVars(expr) = let
        fun evh(CONSTF f) = SVSet.empty 
          | evh(CONST3F vec) = SVSet.empty 
          | evh(VAR v) = SVSet.empty
          | evh(STATE_VAR v) = SVSet.singleton v
          
          (* We don't support domains based on state variables because they
           * are not uniform across the particle system. ... That being said,
           * there might be an interesting application to particle-specific 
           * domains, like small spheres defined around the particle. I'm not
           * sure what though. *)
          | evh(GENERATEF (dom, dist)) = SVSet.empty
          | evh(GENERATE3F (dom, dist)) = SVSet.empty
          
          | evh(ADD (e1, e2)) = SVSet.union(evh(e1), evh(e2)) 
          | evh(NEG ex) = evh(ex)
          | evh(SCALE (e1, e2)) = SVSet.union(evh(e1), evh(e2))
          | evh(DOT (e1, e2)) = SVSet.union(evh(e1), evh(e2))
          | evh(CROSS (e1, e2)) = SVSet.union(evh(e1), evh(e2))
       in
        evh(expr)
       end (* extractStateVars *)

(*
      fun extractVarsFromCond(WITHINF (d, exp)) 
         = VSet.union(fvsOfDomain d, extractVars exp)
        | extractVarsFromCond(WITHIN3F (d, exp))
         = VSet.union(fvsOfDomain d, extractVars (exp))
        | extractVarsFromCond(GTHAN (f, t))
         = VSet.union(extractVars (f), extractVars (t))
        | extractVarsFromCond(AND (c1, c2))
         = VSet.union(extractVarsFromCond c1, extractVarsFromCond c2)
        | extractVarsFromCond(OR (c1, c2))
         = VSet.union(extractVarsFromCond c1, extractVarsFromCond c2)
        | extractVarsFromCond(XOR (c1, c2))
         = VSet.union(extractVarsFromCond c1, extractVarsFromCond c2)
        | extractVarsFromCond(NOT c) = extractVarsFromCond c
        
      fun extractStateVarsFromCond(WITHINF (d, exp)) = extractVars exp
        | extractStateVarsFromCond(WITHIN3F (d, exp)) = extractVars exp
        | extractStateVarsFromCond(GTHAN (f, t))
         = SVSet.union(extractVars (f), extractVars (t))
        | extractStateVarsFromCond(AND (c1, c2))
         = SVSet.union(extractStateVarsFromCond c1, extractStateVarsFromCond c2)
        | extractStateVarsFromCond(OR (c1, c2))
         = SVSet.union(extractStateVarsFromCond c1, extractStateVarsFromCond c2)
        | extractStateVarsFromCond(XOR (c1, c2))
         = SVSet.union(extractStateVarsFromCond c1, extractStateVarsFromCond c2)
        | extractStateVarsFromCond(NOT c) = extractStateVarsFromCond c
        *)
      
      fun extractFromCond(WITHINF (d, exp), fd, evh, union) 
         = union(fd d, evh (exp))
        | extractFromCond(WITHIN3F (d, exp), fd, evh, union) 
         = union(fd d, evh (exp))
        | extractFromCond(GTHAN (f, t), fd, evh, union)
         = union(evh (f), evh (t))
        | extractFromCond(AND (c1, c2), fd, evh, union)
         = union(extractFromCond (c1, fd, evh, union), extractFromCond (c2, fd, evh, union))
        | extractFromCond(OR (c1, c2), fd, evh, union)
         = union(extractFromCond (c1, fd, evh, union), extractFromCond (c2, fd, evh, union))
        | extractFromCond(XOR (c1, c2), fd, evh, union)
         = union(extractFromCond (c1, fd, evh, union), extractFromCond (c2, fd, evh, union))
        | extractFromCond(NOT c, fd, evh, union) = extractFromCond (c, fd, evh, union) 
        
      fun getSVs(SEQ al) = List.foldl SVSet.union SVSet.empty (List.map getSVs al)
        | getSVs(PRED (cond, act1, act2)) = let 
           fun getCondVars(x) = extractFromCond(x, fn x => SVSet.empty, extractStateVars, SVSet.union)
          in
           SVSet.union (
             getCondVars(cond),
             SVSet.union (getSVs act1, getSVs act2)
           )
          end
        | getSVs(ASSIGN (sv, exp)) 
          = SVSet.union( SVSet.singleton sv, extractStateVars(exp) )
        | getSVs(DIE) = SVSet.empty
        
      fun getVs(SEQ al) = List.foldl VSet.union VSet.empty (List.map getVs al)
        | getVs(PRED (cond, act1, act2)) = let 
           fun getCondVars(x) = extractFromCond(x, fvsOfDomain, extractVars, VSet.union)
          in
           VSet.union (
             getCondVars(cond),
             VSet.union (getVs act1, getVs act2)
           )
          end
        | getVs(ASSIGN (sv, exp)) = extractVars(exp)
        | getVs(DIE) = VSet.empty
        
      val REND{prim, sv_gens=rend_sv_gens, names} = render
      val EMIT{freq, sv_gens} = emit
      
      val gens = sv_gens @ rend_sv_gens
      
      fun getVsFromGen(GEN{var, exp}) = extractVars(exp)
      fun getSVsFromGen(GEN{var, exp}) 
        = SVSet.union( SVSet.singleton var, extractStateVars(exp) )
        
      val union = PSV.SVMap.unionWith (fn x => raise Fail("Adding the same variable."))
      val preDefVars = [PSV.numDead, PSV.timeStep]
     in
      PG{
        emit = EMIT{ freq = freq, sv_gens = gens },
        act = act,
        render = prim,
        vars = List.foldl VSet.union VSet.empty ([getVs act, VSet.fromList preDefVars] @ (List.map getVsFromGen gens)),
        state_vars = List.foldl  SVSet.union SVSet.empty (getSVs act :: (List.map getSVsFromGen gens)),
        render_vars = union (PSV.SVMap.singleton (sv_pos, "position"), names)
      }
     end (* create *)

  end

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