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

SCM Repository

[sml3d] View of /trunk/sml3d/src/shaders/shader.sml
ViewVC logotype

View of /trunk/sml3d/src/shaders/shader.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1236 - (download) (annotate)
Thu Sep 22 19:30:01 2011 UTC (6 years, 10 months ago) by samquinan
File size: 37867 byte(s)
fixed naming issues
structure ShadeTrees: SHADER =
  	struct
  	
  		structure REP = ShaderRep
  		
  		exception BadUse of string
  		
  		(************************
  		*	 base data types	*
  		*************************)
		type float = Float.float
		
    	type vec2f = Vec2f.vec2
    	type vec3f = Vec3f.vec3
    	type vec4f = Vec4f.vec4
    	
    	type color3f = Color.color3f
    	type color4f = Color.color4f
    	
    	type mat3f = Matrix3f.mat3
    	type mat4f = Matrix4f.mat4
    	
    	type blend_mode = GL.blend_func
    	
    	datatype lightCalcTy = Lambert | Phong | Blinn
    	type shade_style = lightCalcTy
	    
	    
	  	type transform2D = REP.transform
	  	type transform3D = REP.transform
	    
	    (*************************************
	  	*			expression types		 *
	  	**************************************)
	  	type 'a ty = (REP.ty_rep * ('a -> REP.value)) 
	  	type 'a exp = (REP.ty_rep * REP.exp)
	  	
	  	type cnxn = REP.cnxn
	  	type shader = REP.shader
	  	
	  	fun shaderFromOutput (_, e) = REP.SHDR (e)
	    
	    val floatTy: float ty = (REP.T_FLOAT, REP.FLOAT)
	    val vec2Ty: vec2f ty = (REP.T_VEC2, REP.VEC2)
	    val vec3Ty: vec3f ty = (REP.T_VEC3, REP.VEC3)
	    val vec4Ty: vec4f ty = (REP.T_VEC4, REP.VEC4)
	    val rgbTy: color3f ty = (REP.T_RGB, REP.RGB)
	    val rgbaTy: color4f ty = (REP.T_RGBA, REP.RGBA)
	    val mat3Ty: mat3f ty = (REP.T_MAT3, REP.MAT3)
	    val mat4Ty: mat4f ty = (REP.T_MAT4, REP.MAT4)
	    val boolTy: bool ty = (REP.T_BOOL, REP.BOOL)
	    val intTy: int ty = (REP.T_INT, REP.INT) 
	  	
	  	type 'a uniformVariable = (REP.ty_rep * cnxn)
	    type 'a attributeVariable = (REP.ty_rep * cnxn)
	    type 'a outputVariable = (REP.ty_rep * cnxn)
	  	type 'a sampler2DVariable = (REP.ty_rep * cnxn)
	    type 'a sampler3DVariable = (REP.ty_rep * cnxn)
	  	
	  	type attr_kind = REP.attr_ty
	  	val ConstAttr = REP.T_CONST
	  	val InterpAttr = REP.T_INTERP
	  	
	    datatype bindTy = IN | OUT
	    type binding = bindTy
	    val In = IN
	    val Out = OUT
	     
	    type outputKind = REP.shader_ty
	    val Vert = REP.VERT
	    val Frag = REP.FRAG
	    
	    (*************************************
	  	*	    light / material types		 *	
	  	**************************************)
	  	
	  	datatype light_rep
		= DIR of {		ambient:color4f exp,
						diffuse:color4f exp,
						specular:color4f exp,
						position:vec3f exp		}
	    | POINT of {	ambient:color4f exp,
	    				diffuse:color4f exp,
	    				specular:color4f exp,
	    				position:vec3f exp,
	    				attenuation:vec3f exp	}
		(*note: attenuation = {quadratic_term, linear_term, const_term} where each term is a float*)
	    | SPOT of {		ambient:color4f exp,
	    				diffuse:color4f exp,
	    				specular:color4f exp,
	    				position:vec3f exp,
	    				attenuation:vec3f exp,
	    				spot_dir:vec3f exp,
	    				spot_exp:float exp,
	    				spot_cutoff:float exp	}
		    				
	    type light = light_rep
	    				
	    datatype material = M of {	ambient:color4f exp,
	    						diffuse:color4f exp,
	    						specular:color4f exp,
	    						emmisive:color4f exp,
	    						shininess:float exp		}
	    
	    local
	      	val cnt = ref 0w0
	      	fun nextId () = let val id = !cnt in cnt := id+0w1; id end
	    in
	    
		    (*************************************
		  	*		 binding constructors		 *
		  	**************************************)
    
	    	fun uniform ((ty, _), name) = let
	    		val id = nextId()
	    		val bound_exp = REP.UNDEFINED
	    		val shdr = REP.BOTH
	    		val cnxn_var = REP.UNIF{	id = id, 
	    									name = name, 
	    									dtype = ty, 
	    									binding = ref bound_exp,
	    									location = ref shdr		}
	    		in
	    			(ty, cnxn_var)
   		 		end
    		
	    	fun attribute ((ty, _), name, attr_kind) = let
	    		val id = nextId()
	    		val bound_exp = REP.UNDEFINED
	    		val shdr = REP.BOTH
	    		val cnxn_var = REP.ATTR{	id = id, 
	    									name = name, 
	    									attr_kind = attr_kind, 
	    									dtype = ty, 
	    									binding = ref bound_exp,
	    									location = ref shdr		}
	    		in
	    			(ty, cnxn_var)
	    		end
	    	
	    	fun output ((ty, _), name, out) = (case
	    		 out of REP.BOTH => raise BadUse("Output variable cannot belong to both fragment and vertex shaders")
		    	 	  | _ =>
	    		 	  		let
	    						val id = nextId()
	    						val bound_exp = REP.UNDEFINED
	    						val shdr = out
	    						val cnxn_var = REP.OUT{		id = id, 
	    													name = name,
   		 													dtype = ty, 
    														binding = ref bound_exp,
    														location = ref shdr		}
    			 			in
    							(ty, cnxn_var)
    		 				end
    			(*end case*))
  	  	
	    	(* in long run samplers will be tied to more integrated sampler structure*)
    		
	    	fun sampler2D ((ty, _), name, IN) = 
	    		 let
	    			val id = nextId()
	    			val bound_exp = REP.UNDEFINED
	    			val shdr = REP.BOTH
	    			val cnxn_var = REP.UNIF{	id = id, 
	    										name = name,
	    										dtype = ty, 
	    										binding = ref bound_exp,
	    										location = ref shdr		}
	    		 in
	    			(ty, cnxn_var)
	    		 end
	    	  | sampler2D ((ty, _), name, OUT) = 
	    	     let
	    	      	val id = nextId()
	    			val bound_exp = REP.UNDEFINED
	    			val shdr = REP.BOTH
	    			val cnxn_var = REP.OUT{		id = id, 
	    										name = name,
	    										dtype = ty, 
	    										binding = ref bound_exp,
	    										location = ref shdr		}
	    		 in
	    			(ty, cnxn_var)
	    		 end
	    	
	    	fun sampler3D ((ty, _), name, IN) = 
	    		 let
	    			val id = nextId()
	    			val bound_exp = REP.UNDEFINED
	    			val shdr = REP.BOTH
	    			val cnxn_var = REP.UNIF{	id = id, 
	    										name = name,
	    										dtype = ty, 
	    										binding = ref bound_exp,
	    										location = ref shdr		}
	    		 in
	    			(ty, cnxn_var)
	    		 end
	    	  | sampler3D ((ty, _), name, OUT) = 
	    	     let
	   		       	val id = nextId()
	    			val bound_exp = REP.UNDEFINED
	    			val shdr = REP.BOTH
	    			val cnxn_var = REP.OUT{		id = id, 
	    										name = name,
	    										dtype = ty, 
	    										binding = ref bound_exp,
	    										location = ref shdr		}
	    		 in
	    			(ty, cnxn_var)
	    		 end
	    	
	    	(*************************************
  			*	 light / material constructors	 *
  			**************************************)
  	  	
	  	  	fun dirLight r = DIR r
	    	fun pointLight r = POINT r
	    	fun spotLight r = SPOT r
	    	fun objectMaterial r = M r
	   		
	    end
	  	
  		structure EXP = struct
  			
  			val X = 0
  			val Y = 1
  			val Z = 2
  			val W = 3
  			val R = 0
  			val G = 1
  			val B = 2
  			val A = 3
  			
  			
  			(*************************************
  			*	    expression constructors		 *
  			**************************************)
    		
    		(*** constants ***)
	    	fun constant ((ty,fnc),c) = (ty, REP.CONST (fnc c))
	    	
	      	local
	      		val cnt = ref 0w0
	      		fun nextId () = let val id = !cnt in cnt := id+0w1; id end
	    	in
	    	
		    	(*** uniforms ***)
    			fun uniform (ty, cxn) = (case 
    				cxn of REP.UNIF{name, dtype, binding, ...} =>
    							let
		    						val id = nextId()
		    						val expr = REP.VAR{	id = id,
    													name = name,
    													data_type = dtype,
    													var_type = ref REP.UNIFORM	}
 			   						val b = !binding
 			   						val () = binding := (case
    									b of REP.UNDEFINED => REP.EXPRESSION (expr::nil)
	 			   						   | REP.EXPRESSION e => REP.EXPRESSION (expr::e)
    				 					(*end case*))
    							in
    								(ty, expr)
    							end
    					  | _ => raise BadUse("Cannot create a uniform exp from a non-uniform cnxn")
    				(*end case*))
    		
    			(*** attributes ***)
    			fun attribute (ty, cxn) = (case
    				cxn of REP.ATTR{name, attr_kind, dtype, binding,...} =>
    							let
		    						val id = nextId()
		    						val expr = REP.VAR{	id = id,
    													name = name,
    													data_type = dtype,
    													var_type = ref REP.ATTRIBUTE }
    								val b = !binding
		    						val () = binding := (case 
						    			  b of REP.UNDEFINED => REP.EXPRESSION (expr::nil)
    										 | REP.EXPRESSION e => REP.EXPRESSION (expr::e)
					   				 (*end case*))
		    					in
    								(ty, expr)
    							end
    					 | _ => raise BadUse("Cannot create a attribute exp from a non-attribute cnxn")
    				(*end case*))
  				
  				(*** output ***)
  				fun bindToOutput ((_, cxn), (_, expr)) = (case
  					cxn of REP.OUT{binding,...} => (binding := REP.EXPRESSION (expr::nil))
  						 | _ => raise BadUse("Cannot bind an expression to a non-output cnxn")
  					(*end case*))
  				
  				(*** samplers ***)
  				(* current implementation deals only setup to deal with textures *)
  				fun sample2D ((ty, s_cnxn), (_, v_exp)) = (case 
  					s_cnxn of REP.UNIF{name, dtype, binding, ...} =>
  																let
  																	val id = nextId()
  																	val tex = REP.TEX2D{	id = id,
  																							name = name,
																							dtype = dtype,
																							var_type = REP.UNIFORM	}
																	val t_exp = REP.SAMPLER (tex)
																	val b = !binding
																	val () = binding := (case b 
    																	of REP.UNDEFINED => REP.EXPRESSION (v_exp::nil)
    																	 | REP.EXPRESSION e => REP.EXPRESSION (v_exp::e)
    																	 (*end case*))
																	val sample = REP.PRIM(REP.SAMPLE_2D(t_exp, v_exp))
  																in
  																	(ty, sample)
  																end
  					  		 | _ => raise BadUse("Only uniforms for textures supported by sampler2DVariable at this time")
  					(*end case*))
 	 		
 		 		fun sample3D ((ty, s_cnxn), (_, v_exp)) = (case
  					s_cnxn of REP.UNIF{name, dtype, binding, ...} =>
  															let
  																val id = nextId()
  																val tex = REP.TEX3D{	id = id,
  																						name = name,
																						dtype = dtype,
																						var_type = REP.UNIFORM	}
																val t_exp = REP.SAMPLER (tex)
																val b = !binding
																val () = binding := (case b 
    																of REP.UNDEFINED => REP.EXPRESSION (v_exp::nil)
    																 | REP.EXPRESSION e => REP.EXPRESSION (v_exp::e)
    																 (*end case*))
																val sample = REP.PRIM (REP.SAMPLE_3D (t_exp, v_exp))
  															in
  																(ty, sample)
  															end
  						  	| _ => raise BadUse("Only uniforms for textures supported by sampler3DVariable at this time")
		  			(*end case*))
  		
  				(*** generataion functions ***)
  				fun vec2 ((_,x), (_,y)) = (REP.T_VEC2, REP.PRIM (REP.GEN_VEC2 (x, y)))
  				fun vec3 ((_,x), (_,y), (_,z)) = (REP.T_VEC3, REP.PRIM (REP.GEN_VEC3 (x, y, z)))
 		 		fun vec4 ((_,x), (_,y), (_,z), (_,w)) = (REP.T_VEC4, REP.PRIM (REP.GEN_VEC4 (x, y, z, w)))
  				fun color3 ((_,r), (_,g), (_,b)) = (REP.T_RGB, REP.PRIM (REP.GEN_RGB (r, g, b)))
  				fun color4 ((_,r), (_,g), (_,b), (_,a)) = (REP.T_RGBA, REP.PRIM (REP.GEN_RGBA (r, g, b, a)))
  				
  				(*** select: vec2 ***)
  				fun selectVec2 ((_,v), i) = (case
  					i of 0 => (REP.T_FLOAT, REP.PRIM (REP.EXTRACT_N (v, i)))
  					   | 1 => (REP.T_FLOAT, REP.PRIM (REP.EXTRACT_N (v, i)))
  					   | _ => raise BadUse("Invalid Index: vec2f requires index of 0 or 1")
  					(*end case*))
  					
  				fun select2Vec2 (e, i1, i2) = vec2 (selectVec2 (e, i1),
  													selectVec2 (e, i2))
  				(*** select: vec3 ***)										
  				fun selectVec3 ((_,v), i) = (case
  					i of 0 => (REP.T_FLOAT, REP.PRIM (REP.EXTRACT_N (v, i)))
		  			   | 1 => (REP.T_FLOAT, REP.PRIM (REP.EXTRACT_N (v, i)))
  					   | 2 => (REP.T_FLOAT, REP.PRIM (REP.EXTRACT_N (v, i)))
  					   | _ => raise BadUse("Invalid Index: vec3f requires index of 0, 1, or 2")
  					(*end case*))
 		 		fun select2Vec3 (e, i1, i2) = vec2 (selectVec3 (e, i1),
  													selectVec2 (e, i2))
  				fun select3Vec3 (e, i1, i2, i3) = vec3 (selectVec3 (e, i1),
  														selectVec3 (e, i2),
  														selectVec3 (e, i3))
  				(*** select: vec4 ***)
  				fun selectVec4 ((_,v), i) = (case
 		 			i of 0 => (REP.T_FLOAT, REP.PRIM (REP.EXTRACT_N (v, i)))
  					   | 1 => (REP.T_FLOAT, REP.PRIM (REP.EXTRACT_N (v, i)))
  					   | 2 => (REP.T_FLOAT, REP.PRIM (REP.EXTRACT_N (v, i)))
  					   | 3 => (REP.T_FLOAT, REP.PRIM (REP.EXTRACT_N (v, i)))
  			   		   | _ => raise BadUse("Invalid Index: vec4f requires index of 0, 1, 2, or 3")
  					(*end case*))
		  		fun select2Vec4 (e, i1, i2) = vec2 (selectVec4 (e, i1),
  													selectVec4 (e, i2))
  				fun select3Vec4 (e, i1, i2, i3) = vec3 (selectVec4 (e, i1),
		  												selectVec4 (e, i2),
  														selectVec4 (e, i3))
  				fun select4Vec4 (e, i1, i2, i3, i4) = vec4 (selectVec4 (e, i1),
  															selectVec4 (e, i2),
 		 													selectVec4 (e, i3),
  															selectVec4 (e, i4))
  				(*** select: color3 ***)
  				fun selectColor3 ((_,v), i) = (case
 		 			i of 0 => (REP.T_FLOAT, REP.PRIM (REP.EXTRACT_N (v, i)))
 		 			   | 1 => (REP.T_FLOAT, REP.PRIM (REP.EXTRACT_N (v, i)))
  					   | 2 => (REP.T_FLOAT, REP.PRIM (REP.EXTRACT_N (v, i)))
  					   | _ => raise BadUse("Invalid Index: color3f requires index of 0, 1, or 2")
  					(*end case*))
		  		fun select3Color3 (e, i1, i2, i3) = color3 (selectColor3 (e, i1),
  															selectColor3 (e, i2),
  															selectColor3 (e, i3))
 		 		(*** select: color4 ***)
  				fun selectColor4 ((_,v), i) = (case
  					i of 0 => (REP.T_FLOAT, REP.PRIM (REP.EXTRACT_N (v, i)))
  					   | 1 => (REP.T_FLOAT, REP.PRIM (REP.EXTRACT_N (v, i)))
  					   | 2 => (REP.T_FLOAT, REP.PRIM (REP.EXTRACT_N (v, i)))
  					   | 3 => (REP.T_FLOAT, REP.PRIM (REP.EXTRACT_N (v, i)))
  					   | _ => raise BadUse("Invalid Index: color4f requires index of 0, 1, 2, or 3")
 		 			(*end case*))
  				fun select3Color4 (e, i1, i2, i3) = color3 (selectColor4 (e, i1),
 		 													selectColor4 (e, i2),
  															selectColor4 (e, i3))
  				fun select4Color4 (e, i1, i2, i3, i4) = color4 (selectColor4 (e, i1),
  																selectColor4 (e, i2),
  																selectColor4 (e, i3),
  																selectColor4 (e, i4))
  				
  				(*** color vector exchange ***)
  				fun clampToColor (ty, flt) = (ty, REP.PRIM(REP.CLAMP (flt, REP.CONST (REP.FLOAT 0.0), REP.CONST (REP.FLOAT 1.0))))
  				
  				fun vec3ToColor3 (e) = color3 ( clampToColor (selectVec3(e, 0)),
		  									 	clampToColor (selectVec3(e, 1)),
  												clampToColor (selectVec3(e, 2))  )
  				
  				fun color3ToVec3 (e) = vec3 (	selectColor3 (e, 0),
  												selectColor3 (e, 1),
  												selectColor3 (e, 2)	)
  				
		  		fun vec4ToColor4 (e) = color4 ( clampToColor (selectVec3(e, 0)),
  												clampToColor (selectVec3(e, 1)),
  												clampToColor (selectVec3(e, 2)),
  												clampToColor (selectVec3(e, 3))  )
  				
  				fun color4ToVec4 (e) = vec4 ( selectColor4 (e, 0),
  											  selectColor4 (e, 1),
  											  selectColor4 (e, 2),
  											  selectColor4 (e, 3)  )
  				
  				
		  		(*** transforms ***)
		  		fun mat3Transform (ty, m) = (case
		  			ty of REP.T_TFORM2D => (REP.T_TFORM2D, REP.TFORM (REP.TFORM_2D (REP.T2_CUSTOM (m))))
		  				| _ => raise BadUse ("mat3Transform only takes expression of mat3 type")
		  			(*end case*))
		  		fun mat4Transform (ty, m) = (case
		  			ty of REP.T_TFORM2D => (REP.T_TFORM3D, REP.TFORM (REP.TFORM_3D (REP.T3_CUSTOM (m))))
		  				| _ => raise BadUse ("mat4Transform only takes expression of mat4 type")
		  			(*end case*))
  				fun concatTransform ((_,t1), (_,t2)) = (case (t1, t2)
  							of (REP.TFORM (REP.TFORM_2D t1_rep), REP.TFORM (REP.TFORM_2D t2_rep))  =>
  							 		(REP.T_TFORM2D, REP.TFORM (REP.TFORM_2D (REP.T2_CONCAT (t1_rep, t2_rep))))
	  						 | (REP.TFORM (REP.TFORM_3D t1_rep), REP.TFORM (REP.TFORM_3D t2_rep)) =>
  							 		(REP.T_TFORM3D, REP.TFORM (REP.TFORM_3D (REP.T3_CONCAT (t1_rep, t2_rep))))
  							 | (_, _) => raise BadUse ("Can only concatenate transform expressions of same class")
  						 (*end case*))
  		
		  		fun identity2D () = (REP.T_TFORM2D, REP.TFORM (REP.TFORM_2D (REP.T2_IDENTITY)))
  				fun transpose2D (ty, e) = (case
		  			(ty, e) of (REP.T_TFORM2D, REP.TFORM (REP.TFORM_2D t_rep)) => (REP.T_TFORM2D, REP.TFORM (REP.TFORM_2D (REP.T2_TRANSPOSE t_rep)))
		  					 | (_, _) => raise BadUse ("transpose2D requires expression of type transform2D")
		  			(*end case*))
		  		fun inverse2D (ty, e) = (case
		  			(ty, e) of (REP.T_TFORM2D, REP.TFORM (REP.TFORM_2D t_rep)) => (REP.T_TFORM2D, REP.TFORM (REP.TFORM_2D (REP.T2_INVERSE t_rep)))
		  			 		 | (_, _) => raise BadUse ("inverse2D requires expression of type transform2D")
		  			(*end case*))
		  		fun translate2D ((t1, e), (t2, v)) = (case
		  			(t1, t2, e) of (REP.T_TFORM2D, REP.T_VEC2, REP.TFORM (REP.TFORM_2D t_rep)) => 
  										let
  											val trans = REP.T2_TRANSLATE v
  											val output = REP.TFORM (REP.TFORM_2D (REP.T2_CONCAT (t_rep, trans))) 
  										in
  											(REP.T_TFORM2D, output)
  										end
  								 | (_, _, _) => raise BadUse ("translate2D requires expressions of type transform2D and vec2f")
  					(*end case*))
  				fun xRotate2D ((t1, e), (t2, flt)) = (case
  					(t1, t2, e) of (REP.T_TFORM2D, REP.T_FLOAT, REP.TFORM (REP.TFORM_2D t_rep)) => 
  										let
  											val rot = REP.T2_ROTATE_X flt
  											val output = REP.TFORM (REP.TFORM_2D (REP.T2_CONCAT (t_rep, rot))) 
  										in
  											(REP.T_TFORM2D, output)
  										end
  								 | (_, _, _) => raise BadUse ("xRotate2D requires expressions of type transform2D and float")
  					(*end case*))
 		 		fun yRotate2D ((t1, e), (t2, flt)) = (case
  					(t1, t2, e) of (REP.T_TFORM2D, REP.T_FLOAT, REP.TFORM (REP.TFORM_2D t_rep)) => 
  										let
  											val rot = REP.T2_ROTATE_Y flt
  											val output = REP.TFORM (REP.TFORM_2D (REP.T2_CONCAT (t_rep, rot))) 
  										in
  											(REP.T_TFORM2D, output)
  										end
  								 | (_, _, _) => raise BadUse ("yRotate2D requires expressions of type transform2D and float")
  					(*end case*))
  				fun uniformScale2D ((t1, e), (t2, flt)) = (case
  					(t1, t2, e) of (REP.T_TFORM2D, REP.T_FLOAT, REP.TFORM (REP.TFORM_2D t_rep)) => 
  										let
  											val scale = REP.T2_USCALE flt
  											val output = REP.TFORM (REP.TFORM_2D (REP.T2_CONCAT (t_rep, scale))) 
 		 								in
  											(REP.T_TFORM2D, output)
  										end
  								 | (_, _, _) => raise BadUse ("uniformScale2D requires expressions of type transform2D and float")
  					(*end case*))		
  				fun scale2D ((t1, e), (t2, v)) = (case
		  			(t1, t2, e) of (REP.T_TFORM2D, REP.T_VEC2, REP.TFORM (REP.TFORM_2D t_rep)) => 
  										let
  											val scale = REP.T2_SCALE v
  											val output = REP.TFORM (REP.TFORM_2D (REP.T2_CONCAT (t_rep, scale))) 
  										in
  											(REP.T_TFORM2D, output)
  										end
  								 | (_, _, _) => raise BadUse ("scale2D requires expressions of type transform2D and vec2f")
  					(*end case*))
  				
  				fun identity3D () = (REP.T_TFORM3D, REP.TFORM (REP.TFORM_3D (REP.T3_IDENTITY)))
  				fun transpose3D (ty, e) = (case
		  			(ty, e) of (REP.T_TFORM3D, REP.TFORM (REP.TFORM_3D t_rep)) => (REP.T_TFORM3D, REP.TFORM (REP.TFORM_3D (REP.T3_TRANSPOSE t_rep)))
		  					 | (_, _) => raise BadUse ("transpose3D requires expression of type transform3D")
		  			(*end case*))
  				fun inverse3D (ty, e) = (case
		  			(ty, e) of (REP.T_TFORM3D, REP.TFORM (REP.TFORM_3D t_rep)) => (REP.T_TFORM3D, REP.TFORM (REP.TFORM_3D (REP.T3_INVERSE t_rep)))
		  			 		 | (_, _) => raise BadUse ("inverse3D requires expression of type transform3D")
		  			(*end case*))
		  		fun translate3D ((t1, e), (t2, v)) = (case
		  			(t1, t2, e) of (REP.T_TFORM3D, REP.T_VEC3, REP.TFORM (REP.TFORM_3D t_rep)) => 
  										let
  											val trans = REP.T3_TRANSLATE v
  											val output = REP.TFORM (REP.TFORM_3D (REP.T3_CONCAT (t_rep, trans))) 
  										in
  											(REP.T_TFORM3D, output)
  										end
  								 | (_, _, _) => raise BadUse ("translate3D requires expressions of type transform3D and vec3f")
  					(*end case*))
		  		fun xRotate3D ((t1, e), (t2, flt)) = (case
  					(t1, t2, e) of (REP.T_TFORM3D, REP.T_FLOAT, REP.TFORM (REP.TFORM_3D t_rep)) => 
  										let
  											val rot = REP.T3_ROTATE_X flt
  											val output = REP.TFORM (REP.TFORM_3D (REP.T3_CONCAT (t_rep, rot))) 
  										in
  											(REP.T_TFORM3D, output)
  										end
  								 | (_, _, _) => raise BadUse ("xRotate3D requires expressions of type transform3D and float")
  					(*end case*))
 		 		fun yRotate3D ((t1, e), (t2, flt)) = (case
  					(t1, t2, e) of (REP.T_TFORM3D, REP.T_FLOAT, REP.TFORM (REP.TFORM_3D t_rep)) => 
  										let
  											val rot = REP.T3_ROTATE_Y flt
  											val output = REP.TFORM (REP.TFORM_3D (REP.T3_CONCAT (t_rep, rot))) 
  										in
  											(REP.T_TFORM3D, output)
  										end
  								 | (_, _, _) => raise BadUse ("yRotate3D requires expressions of type transform3D and float")
  					(*end case*))
  				fun zRotate3D ((t1, e), (t2, flt)) = (case
  					(t1, t2, e) of (REP.T_TFORM3D, REP.T_FLOAT, REP.TFORM (REP.TFORM_3D t_rep)) => 
  										let
  											val rot = REP.T3_ROTATE_Z flt
  											val output = REP.TFORM (REP.TFORM_3D (REP.T3_CONCAT (t_rep, rot))) 
  										in
  											(REP.T_TFORM3D, output)
  										end
  								 | (_, _, _) => raise BadUse ("zRotate3D requires expressions of type transform3D and float")
  					(*end case*))
		  		fun uniformScale3D ((t1, e), (t2, flt)) = (case
  					(t1, t2, e) of (REP.T_TFORM3D, REP.T_FLOAT, REP.TFORM (REP.TFORM_3D t_rep)) => 
  										let
  											val scale = REP.T3_USCALE flt
  											val output = REP.TFORM (REP.TFORM_3D (REP.T3_CONCAT (t_rep, scale))) 
 		 								in
  											(REP.T_TFORM3D, output)
  										end
  								 | (_, _, _) => raise BadUse ("uniformScale3D requires expressions of type transform3D and float")
  					(*end case*))
		  		fun scale3D ((t1, e), (t2, v)) = (case
		  			(t1, t2, e) of (REP.T_TFORM3D, REP.T_VEC3, REP.TFORM (REP.TFORM_3D t_rep)) => 
  										let
  											val scale = REP.T3_SCALE v
  											val output = REP.TFORM (REP.TFORM_3D (REP.T3_CONCAT (t_rep, scale))) 
  										in
  											(REP.T_TFORM3D, output)
  										end
  								 | (_, _, _) => raise BadUse ("scale3D requires expressions of type transform3D and vec3f")
  					(*end case*))
  				
  				(******	low level ******)
  				fun add ((ty, exp1), (_, exp2)) = (case
  					ty of REP.T_BOOL => raise BadUse("invalid operation: scalar addition on booleans")
  						| REP.T_TFORM2D => raise BadUse("invalid operation: scalar addition on transforms")
  						| REP.T_TFORM3D => raise BadUse("invalid operation: scalar addition on transforms")
  						| _ => (ty, REP.PRIM (REP.ADD (exp1, exp2)))
  					(* end case *))
  				fun sub ((ty, exp1), (_, exp2)) = (case
  					ty of REP.T_BOOL => raise BadUse("invalid operation: scalar subtraction on booleans")
  						| REP.T_TFORM2D => raise BadUse("invalid operation: scalar subtraction on transforms")
  						| REP.T_TFORM3D => raise BadUse("invalid operation: scalar subtraction on transforms")
  						| _ => (ty, REP.PRIM (REP.SUB (exp1, exp2)))
  					(* end case *))
  				fun mul ((ty, exp1), (_, exp2)) = (case
  					ty of REP.T_BOOL => raise BadUse("invalid operation: scalar multiplication on booleans")
  						| REP.T_TFORM2D => raise BadUse("invalid operation: scalar multiplication on transforms")
  						| REP.T_TFORM3D => raise BadUse("invalid operation: scalar multiplication on transforms")
  						| _ => (ty, REP.PRIM (REP.MUL (exp1, exp2)))
  					(* end case *))
  				fun div ((ty, exp1), (_, exp2)) = (case
  					ty of REP.T_BOOL => raise BadUse("invalid operation: scalar division on booleans")
  						| REP.T_TFORM2D => raise BadUse("invalid operation: scalar division on transforms")
  						| REP.T_TFORM3D => raise BadUse("invalid operation: scalar division on transforms")
  						| _ => (ty, REP.PRIM (REP.DIV (exp1, exp2)))
  					(* end case *))
  				fun scale ((t1, exp1), (t2, exp2)) = (case 
  					(t1, t2) of (REP.T_VEC2, REP.T_FLOAT) => (t1, REP.PRIM (REP.ISO_SCALE (exp1, exp2)))
  							  | (REP.T_VEC3, REP.T_FLOAT) => (t1, REP.PRIM (REP.ISO_SCALE (exp1, exp2)))
  							  | (REP.T_VEC4, REP.T_FLOAT) => (t1, REP.PRIM (REP.ISO_SCALE (exp1, exp2)))
  							  | (REP.T_RGB, REP.T_FLOAT) => (t1, REP.PRIM (REP.ISO_SCALE (exp1, exp2)))
  							  | (REP.T_RGBA, REP.T_FLOAT) => (t1, REP.PRIM (REP.ISO_SCALE (exp1, exp2)))
  							  | (REP.T_VEC2, REP.T_INT) => (t1, REP.PRIM (REP.ISO_SCALE (exp1, exp2)))
  							  | (REP.T_VEC3, REP.T_INT) => (t1, REP.PRIM (REP.ISO_SCALE (exp1, exp2)))
  							  | (REP.T_VEC4, REP.T_INT) => (t1, REP.PRIM (REP.ISO_SCALE (exp1, exp2)))
  							  | (REP.T_RGB, REP.T_INT) => (t1, REP.PRIM (REP.ISO_SCALE (exp1, exp2)))
  							  | (REP.T_RGBA, REP.T_INT) => (t1, REP.PRIM (REP.ISO_SCALE (exp1, exp2)))
  							  | (REP.T_VEC2, REP.T_VEC2) => (t1, REP.PRIM (REP.MUL (exp1, exp2)))
  							  | (REP.T_VEC3, REP.T_VEC3) => (t1, REP.PRIM (REP.MUL (exp1, exp2)))
  							  | (REP.T_VEC4, REP.T_VEC4) => (t1, REP.PRIM (REP.MUL (exp1, exp2)))
  							  | (REP.T_RGB, REP.T_VEC3) => (t1, REP.PRIM (REP.MUL (exp1, exp2)))
  							  | (REP.T_RGBA, REP.T_VEC4) => (t1, REP.PRIM (REP.MUL (exp1, exp2)))
  							  | _ => raise BadUse("Can only scale vectors or colors, and only by a int, float, or vector of corresponding length.")
  					(*end case*))
  				fun neg (ty, exp) = (case
  					ty of REP.T_BOOL => raise BadUse("invalid operation: negative of boolean")
  						| REP.T_TFORM2D => raise BadUse("invalid operation: negative on transform")
  						| REP.T_TFORM3D => raise BadUse("invalid operation: negative on transform")
  						| _ => (ty, REP.PRIM (REP.NEG (exp)))
  					(* end case *))
  				fun dot ((ty, exp1), (_, exp2)) = (case
  					ty of REP.T_VEC2 => (REP.T_FLOAT, REP.PRIM (REP.DOT (exp1, exp2)))
  						| REP.T_VEC3 => (REP.T_FLOAT, REP.PRIM (REP.DOT (exp1, exp2)))
  						| REP.T_VEC4 => (REP.T_FLOAT, REP.PRIM (REP.DOT (exp1, exp2)))
  						| _ => raise BadUse("invalid operation: dot product of non-vector type")
  					(*end case*))
  				fun cross ((t1, exp1), (t2, exp2)) = (case
  					(t1, t2) of (REP.T_VEC3, REP.T_VEC3) => (REP.T_VEC3, REP.PRIM (REP.CROSS (exp1, exp2)))
  							  | _ => raise BadUse("invalid operation: cross product of non-vec3f type")
  					(*end case*))
  				fun normalize (ty, exp) = (case
  					ty of REP.T_VEC2 => (REP.T_VEC2, REP.PRIM (REP.NORM (exp)))
  						| REP.T_VEC3 => (REP.T_VEC3, REP.PRIM (REP.NORM (exp)))
  						| REP.T_VEC4 => (REP.T_VEC4, REP.PRIM (REP.NORM (exp)))
  						| _ => raise BadUse("invalid operation: normalizing a non-vector type")
  					(*end case*))
  				fun len (ty, exp) = (case
  					ty of REP.T_VEC2 => (REP.T_VEC2, REP.PRIM (REP.LEN (exp)))
  						| REP.T_VEC3 => (REP.T_VEC3, REP.PRIM (REP.LEN (exp)))
  						| REP.T_VEC4 => (REP.T_VEC4, REP.PRIM (REP.LEN (exp)))
  						| _ => raise BadUse("invalid operation: taking the length of a non-vector type")
  					(*end case*))
  				
  				fun sq (ty, exp) = (case
  					ty of REP.T_FLOAT => (REP.T_FLOAT, REP.PRIM (REP.MUL (exp, exp)))
  						| REP.T_INT => (REP.T_INT, REP.PRIM (REP.MUL (exp, exp)))
  						| _ => raise BadUse("invalid operation: squaring a non-numeric type")
  					(*end case*))
 		 		fun sqrt (ty, exp) = (case
 		 			ty of REP.T_FLOAT => (REP.T_FLOAT, REP.PRIM (REP.SQRT (exp)))
 		 				| REP.T_INT => (REP.T_FLOAT, REP.PRIM (REP.SQRT (exp)))
 		 				| _ => raise BadUse("invalid operation: taking square-root of a non-numeric type")
 		 			(*end case*))
 		 		fun pow ((t1, exp1), (t2, exp2)) = (case
 		 			(t1, t2) of (REP.T_FLOAT, REP.T_FLOAT) => (REP.T_FLOAT, REP.PRIM (REP.POW (exp1, exp2)))
 		 					  | (REP.T_FLOAT, REP.T_INT) => (REP.T_FLOAT, REP.PRIM (REP.POW (exp1, exp2)))
 		 					  | (REP.T_INT, REP.T_FLOAT) => (REP.T_FLOAT, REP.PRIM (REP.POW (exp1, exp2)))
 		 					  | (REP.T_INT, REP.T_INT) => (REP.T_FLOAT, REP.PRIM (REP.POW (exp1, exp2)))
 		 					  | _ => raise BadUse("invalid operation: using powers with a non-numeric type")
 		 			(*end case*))
 		 		fun max ((ty, exp1), (_, exp2)) = (case
 		 			ty of REP.T_FLOAT => (REP.T_FLOAT, REP.PRIM (REP.MAX (exp1, exp2)))
 		 				| REP.T_INT => (REP.T_FLOAT, REP.PRIM (REP.MAX (exp1, exp2)))
 		 				| _ => raise BadUse("invalid operation: taking max of a non-numeric type")
 		 			(*end case*))
 		 		fun min ((ty, exp1), (_, exp2)) = (case
 		 			ty of REP.T_FLOAT => (REP.T_FLOAT, REP.PRIM (REP.MIN (exp1, exp2)))
 		 				| REP.T_INT => (REP.T_FLOAT, REP.PRIM (REP.MIN (exp1, exp2)))
 		 				| _ => raise BadUse("invalid operation: taking min of a non-numeric type")
 		 			(*end case*))
 		 		fun abs (ty, exp) = (case
 		 			ty of REP.T_FLOAT => (REP.T_FLOAT, REP.PRIM (REP.ABS (exp)))
 		 				| REP.T_INT => (REP.T_FLOAT, REP.PRIM (REP.ABS (exp)))
 		 				| _ => raise BadUse("invalid operation: taking abs-value of a non-numeric type")
 		 			(*end case*))
 		 		fun sin (ty, exp) = (case
 		 			ty of REP.T_FLOAT => (REP.T_FLOAT, REP.PRIM (REP.SIN (exp)))
 		 				| _ => raise BadUse("invalid operation: taking sin of a non-float type")
 		 			(*end case*))
 		 		fun cos (ty, exp) = (case
 		 			ty of REP.T_FLOAT => (REP.T_FLOAT, REP.PRIM (REP.COS (exp)))
 		 				| _ => raise BadUse("invalid operation: taking cos of a non-float type")
 		 			(*end case*))
 		 		fun tan (ty, exp) = (case
 		 			ty of REP.T_FLOAT =>
 		 								let
 		 									val s =	REP.PRIM (REP.SIN (exp))
 		 									val c = REP.PRIM (REP.COS (exp))
 		 								in 
 		 									(REP.T_FLOAT, REP.PRIM (REP.DIV (s, c)))
 		 								end
 		 				| _ => raise BadUse("invalid operation: taking tan of a non-float type")
 		 			(*end case*))
 		 		fun fract (ty, exp) = (case
 		 			ty of REP.T_FLOAT =>  (REP.T_FLOAT, REP.PRIM (REP.FRACT (exp)))
 		 				| _ => raise BadUse("invalid operation: taking fractional part of a non-float type")
 		 			(*end case*))
 		 		fun clamp (v, minval, maxval) = min (max (v, minval), maxval)
 		 		fun step ((ty, v1), (_, v2)) = (case
 		 			ty of REP.T_VEC2 => (REP.T_VEC2, REP.PRIM (REP.STEP (v1, v2)))
 		 				| REP.T_VEC3 => (REP.T_VEC3, REP.PRIM (REP.STEP (v1, v2)))
 		 				| REP.T_VEC4 => (REP.T_VEC4, REP.PRIM (REP.STEP (v1, v2)))
 		 				| _ => raise BadUse("invalid operation: 'step' not defined for non-vector types")
 		 			(*end case*))
 		 		fun lerp ((t1, v1), (_, v2), (t2, f)) = (case
 		 			t1 of REP.T_BOOL => raise BadUse("invalid operation: lerp on non-float based type")
 		 				| REP.T_INT => raise BadUse("invalid operation: lerp on non-float based type")
 		 				| REP.T_TFORM2D => raise BadUse("invalid operation: lerp on non-float based type")
 		 				| REP.T_TFORM3D => raise BadUse("invalid operation: lerp on non-float based type")
 		 				| _ => (case t2 of REP.T_FLOAT => (t1, REP.PRIM (REP.MIX (v1, v2, f)))
 		 								 | _ => raise BadUse("invalid operation: lerp using non-float value")
 		 					   (*end case*)) 
 		 				(*end case*))
 		 		fun normalReflection ((ty, i), (_, n)) = (case 
 		 			ty of REP.T_VEC2 => 
 		 					let
 		 						val n_prime = (case 
 		 							n of REP.PRIM (REP.NORM _) => n
 		 							   | _ => REP.PRIM (REP.NORM n)
 		 							   (* end case *))
 		 						val ndoti = REP.PRIM (REP.DOT (n_prime, i))
		  						val twox = REP.PRIM (REP.MUL ( REP.CONST (REP.INT (2)), ndoti))
		  						val n_scale = REP.PRIM (REP.ISO_SCALE (n_prime, twox))
		  						val r = REP.PRIM (REP.SUB (i, n_scale))  								
		  					in
		  						(ty, r)
		  					end
  						| REP.T_VEC3 => 
  							let
 		 						val n_prime = (case 
 		 							n of REP.PRIM (REP.NORM _) => n
 		 							   | _ => REP.PRIM (REP.NORM n)
 		 							   (* end case *))
 		 						val ndoti = REP.PRIM (REP.DOT (n_prime, i))
 		 						val twox = REP.PRIM (REP.MUL ( REP.CONST (REP.INT (2)), ndoti))
 		 						val n_scale = REP.PRIM (REP.ISO_SCALE (n_prime, twox))
 		 						val r = REP.PRIM (REP.SUB (i, n_scale))  								
 		 					in
 		 						(ty, r)
 		 					end
 		 				| _ => raise BadUse("invalid operation: normal_reflection on type other than vec2 or vec3")
 		 				(*end case*))
 		 		
 		 		fun cond ((_, b), (ty, e1), (_, e2)) = (ty, REP.IF (b, e1, e2))
 		 		fun isGreaterThan ((ty, exp1), (_, exp2)) = (case
 		 			ty of REP.T_FLOAT => (REP.T_BOOL, REP.PRIM (REP.GT (exp1, exp2)))
 		 				| REP.T_INT => (REP.T_BOOL, REP.PRIM (REP.GT (exp1, exp2)))
 		 				| _ => raise BadUse("invalid operation: comparasion on non-numeric types")
 		 			(*end case*))
 		 		fun isLessThan ((ty, exp1), (_, exp2)) = (case
 		 			ty of REP.T_FLOAT => (REP.T_BOOL, REP.PRIM (REP.LT (exp1, exp2)))
 		 				| REP.T_INT => (REP.T_BOOL, REP.PRIM (REP.LT (exp1, exp2)))
 		 				| _ => raise BadUse("invalid operation: comparasion on non-numeric types")
 		 			(*end case*))
 		 		fun isEqual ((ty, exp1), (_, exp2)) = (REP.T_BOOL, REP.PRIM (REP.EQUALS (exp1, exp2)))
 		 		fun booleanAnd ((ty, exp1), (_, exp2)) = (case 
 		 			ty of REP.T_BOOL => (REP.T_BOOL, REP.PRIM (REP.AND (exp1, exp2)))
 		 				| _ => raise BadUse("invalid operation: boolean operation on non-boolean types")
 		 			(*end case*))
 		 		fun booleanOr ((ty, exp1), (_, exp2)) = (case 
 		 			ty of REP.T_BOOL => (REP.T_BOOL, REP.PRIM (REP.OR (exp1, exp2)))
 		 				| _ => raise BadUse("invalid operation: boolean operation on non-boolean types")
 		 			(*end case*))
 		 		fun booleanNot (ty, exp) = (case 
 		 			ty of REP.T_BOOL => (REP.T_BOOL, REP.PRIM (REP.NOT (exp)))
 		 				| _ => raise BadUse("invalid operation: boolean operation on non-boolean types")
 		 			(*end case*))
 		 		
 		 		fun applyTransform2D ((t1, t), (t2, v)) = (case
 		 			(t1, t2) of (REP.T_TFORM2D, REP.T_VEC3) => (REP.T_VEC3, REP.PRIM (REP.APPLY_TFORM (t, v)))
 		 					  | (_, _) => raise BadUse("invalid operation: applyTransform2D requires epressions of type transform2D and vec3f")
 		 			(*end case*))
 		 		fun applyTransform3D ((t1, t), (t2, v)) = (case
 		 			(t1, t2) of (REP.T_TFORM3D, REP.T_VEC4) => (REP.T_VEC4, REP.PRIM (REP.APPLY_TFORM (t, v)))
 		 					  | _ => raise BadUse("invalid operation: applyTransform3D requires epressions of type transform3D and vec4f")
 		 			(*end case*))
 		 		
 		 		fun pointTransform2D ((ty, t), v) = (case
  					ty of REP.T_TFORM2D =>
  									let
  										val (ty, v3) = vec3 (	selectVec2 (v, 0),
  																selectVec2 (v, 1),
  																constant (floatTy, 1.0)
  												  			)
  									in
  										select2Vec3 ((REP.T_VEC3, REP.PRIM (REP.APPLY_TFORM (t, v3))), 0, 1)
  									end
  						| _ => raise BadUse("invalid operation: pointTransform2D requires expressions of type transform2D and vec2f")
  					(*end case*))
  				
  				fun vectorTransform2D ((ty, t), v) = (case
  					ty of REP.T_TFORM2D =>
  									let
  										val (ty, v3) = vec3 (	selectVec2 (v, 0),
  																selectVec2 (v, 1),
  																constant (floatTy, 0.0)
  								  							)
  									in
  										select2Vec3 ((REP.T_VEC3, REP.PRIM (REP.APPLY_TFORM (t, v3))), 0, 1)
  									end
  						| _ => raise BadUse("invalid operation: vectorTransform2D requires expressions of type transform2D and vec2f")
 		 			(*end case*))
  				fun normalTransform2D ((ty, t), v) = (case
  					ty of REP.T_TFORM2D => 
  									let
  										val (ty, v3) = vec3 (	selectVec2 (v, 0),
  																selectVec2 (v, 1),
  																constant (floatTy, 0.0)
  													  		)
  									in
  										select2Vec3 ((REP.T_VEC3, REP.PRIM (REP.TFORM_NORM (t, v3))), 0, 1)
  									end
  						| _ => raise BadUse("invalid operation: vectorTransform2D requires expressions of type transform2D and vec2f")
 		 			(*end case*))
  				fun pointTransform3D ((ty, t), v) = (case
  					ty of REP.T_TFORM3D => 
  									let
  										val (ty, v4) = vec4 (	selectVec3 (v, 0),
  																selectVec3 (v, 1),
 		 														selectVec3 (v, 2),
		  														constant (floatTy, 1.0)
		  											  		)
		  							in
		  								select3Vec4 ((REP.T_VEC4, REP.PRIM (REP.APPLY_TFORM (t, v4))), 0, 1, 2)
		  							end
		  				| _ => raise BadUse("invalid operation: pointTransform3D requires expressions of type transform3D and vec3f")
 		 			(*end case*))
		  		fun vectorTransform3D ((ty, t), v) = (case
  					ty of REP.T_TFORM3D =>  
  									let
  										val (ty, v4) = vec4 (	selectVec3 (v, 0),
  																selectVec3 (v, 1),
  																selectVec3 (v, 2),
  																constant (floatTy, 1.0)
  									  						)
  									in
  										select3Vec4 ((REP.T_VEC4, REP.PRIM (REP.APPLY_TFORM (t, v4))), 0, 1, 2)
  									end
  						| _ => raise BadUse("invalid operation: vectorTransform3D requires expressions of type transform3D and vec3f")
 		 			(*end case*))
  				fun normalTransform3D ((ty, t), v) = (case
  					ty of REP.T_TFORM3D =>   
  									let
  										val (ty, v4) = vec4 (	selectVec3 (v, 0),
  																selectVec3 (v, 1),
  																selectVec3 (v, 2),
  																constant (floatTy, 1.0)
  													  		)
  									in
  										select3Vec4 ((REP.T_VEC4, REP.PRIM (REP.TFORM_NORM (t, v4))), 0, 1, 2)
  									end
  						| _ => raise BadUse("invalid operation: vectorTransform3D requires expressions of type transform3D and vec3f")
 		 			(*end case*))
 		 		
  				(* NEED TO FINISH MID AND HIGH_LEVEL BUILT-IN MODULE IMPLEMENTATIONS *)
    		end
    	end
    end

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