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

SCM Repository

[sml3d] View of /src/opengl/gl.sml
ViewVC logotype

View of /src/opengl/gl.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 43 - (download) (annotate)
Thu Mar 13 22:10:07 2008 UTC (11 years, 6 months ago) by jhr
File size: 18540 byte(s)
  Adding raster operations
(* gl.sml
 *
 * COPYRIGHT (c) 2006 John Reppy (http://www.cs.uchicago.edu/~jhr)
 * All rights reserved.
 *)

structure GL :> GL =
  struct

  (* include common types *)
    open SML3dTypes SML3dTypeUtil
    open GLConsts

  (* functions for getting singleton state values *)
    val glGetBool1 = _import "glGetBooleanv" stdcall : (glenum * bool ref) -> unit;
    val glGetDouble1 = _import "glGetDoublev" stdcall : (glenum * double ref) -> unit;
    val glGetFloat1 = _import "glGetFloatv" stdcall : (glenum * float ref) -> unit;
    val glGetInteger1 = _import "glGetIntegerv" stdcall : (glenum * int ref) -> unit;

  (* convert records to vectors *)
    fun vectorf3 {x, y, z} : float vector = Vector.fromList [x, y, z]
    fun vectorf4 {x, y, z, w} : float vector = Vector.fromList [x, y, z, w]
    fun vectorc4 {r, g, b, a} : float vector = Vector.fromList [r, g, b, a]

  (* the GL API uses 0, 1 for booleans *)
    fun enum2Bool i = (i <> 0)
    fun bool2Enum false = GL_FALSE
      | bool2Enum true = GL_TRUE

  (* faces *)
    type face = glenum
    val FRONT_FACE = GL_FRONT
    val BACK_FACE = GL_BACK
    val BOTH_FACES = GL_FRONT_AND_BACK

  (* MaterialParameter *)
    type material_param = glenum
    val AMBIENT = GL_AMBIENT
    val DIFFUSE = GL_DIFFUSE
    val SPECULAR = GL_SPECULAR
    val EMISSION = GL_EMISSION
    val SHININESS = GL_SHININESS		(* not exported *)
    val AMBIENT_AND_DIFFUSE = GL_AMBIENT_AND_DIFFUSE

  (* enable/disable capabilities *)
(* NOTE: this is just a small subset of the capabilities supported by
 * OpenGL.  Do a "man glEnable" for the full list.
 *)
    type capability = glenum
    val ALPHA_TEST = GL_ALPHA_TEST
    val AUTO_NORMAL = GL_AUTO_NORMAL
    val BLEND = GL_BLEND
    val COLOR_MATERIAL = GL_COLOR_MATERIAL
    val CULL_FACE = GL_CULL_FACE
    val DEPTH_TEST = GL_DEPTH_TEST
    val FOG = GL_FOG
    val LIGHTING = GL_LIGHTING
    val LINE_SMOOTH = GL_LINE_SMOOTH
    val POINT_SMOOTH = GL_POINT_SMOOTH
    val RESCALE_NORMAL = GL_RESCALE_NORMAL
    val STENCIL_TEST = GL_STENCIL_TEST
    val SCISSOR_TEST = GL_SCISSOR_TEST
    val enable = _import "glEnable" stdcall : capability -> unit;
    val disable = _import "glDisable" stdcall : capability -> unit;

  (* matrix-mode operations *)
    type matrix_mode = glenum
    val MODELVIEW_MATRIX : matrix_mode = GL_MODELVIEW
    val PROJECTION_MATRIX : matrix_mode = GL_PROJECTION
    val TEXTURE_MATRIX : matrix_mode = GL_TEXTURE
    val COLOR_MATRIX : matrix_mode = GL_COLOR	(* requires GL_ARB_imaging *)
    val matrixMode = _import "glMatrixMode" stdcall : matrix_mode -> unit;
    fun getMatrixMode () = let
	  val mode = ref 0
	  in
	    glGetInteger1 (GL_MATRIX_MODE, mode);
	    Word.fromInt(!mode)
	  end
    val loadIdentity = _import "glLoadIdentity" : unit -> unit;
    val pushMatrix = _import "glPushMatrix" : unit -> unit;
    val popMatrix = _import " glPopMatrix" : unit -> unit;
    fun ortho {left, right, bottom, top, zNear, zFar} = let
	  val glOrtho = _import "glOrtho" stdcall
		: (double * double * double * double * double * double) -> unit;
	  in
	    glOrtho (left, right, bottom, top, zNear, zFar)
	  end
    fun frustum {left, right, bottom, top, zNear, zFar} = let
	  val glFrustum = _import "glFrustum" stdcall
		: (double * double * double * double * double * double) -> unit;
	  in
	    glFrustum (left, right, bottom, top, zNear, zFar)
	  end
    fun viewport {x, y, wid, ht} = let
	  val glViewport = _import "glViewport" stdcall
		: (int * int * int * int) -> unit;
	  in
	    glViewport (x, y, wid, ht)
	  end
    fun depthRange {zNear, zFar} = let
	  val glDepthRange = _import "glDepthRange" stdcall : (double * double) -> unit;
	  in
	    glDepthRange (zNear, zFar)
	  end

  (* transformations *)
    local
      val glRotated = _import "glRotated" stdcall : (double * double * double * double) -> unit;
      val glRotatef = _import "glRotatef" stdcall : (float * float * float * float) -> unit;
      val glScaled = _import "glScaled" stdcall : (double * double * double) -> unit;
      val glScalef = _import "glScalef" stdcall : (float * float * float) -> unit;
      val glTranslated = _import "glTranslated" stdcall : (double * double * double) -> unit;
      val glTranslatef = _import "glTranslatef" stdcall : (float * float * float) -> unit;
    in
    val rotated = glRotated
    val rotatef = glRotatef
    fun rotatedv (angle, {x, y, z}) = glRotated(angle, x, y, z)
    fun rotatefv (angle, {x, y, z}) = glRotatef(angle, x, y, z)
    val scaled = glScaled
    val scalef = glScalef
    val scaledv = glScaled o unpackv3
    val scalefv = glScalef o unpackv3
    fun uScaled s = glScaled(s, s, s)
    fun uScalef s = glScalef(s, s, s)
    val translated = glTranslated
    val translatef = glTranslatef
    val translatedv = glTranslated o unpackv3
    val translatefv = glTranslatef o unpackv3
    end

  (* buffer operations operation *)
    datatype buffer_bit
      = COLOR_BUFFER_BIT
      | DEPTH_BUFFER_BIT
      | ACCUM_BUFFER_BIT
      | STENCIL_BUFFER_BIT
    fun clear l = let
	  fun toGL COLOR_BUFFER_BIT = GL_COLOR_BUFFER_BIT
	    | toGL DEPTH_BUFFER_BIT = GL_DEPTH_BUFFER_BIT
	    | toGL ACCUM_BUFFER_BIT = GL_ACCUM_BUFFER_BIT
	    | toGL STENCIL_BUFFER_BIT = GL_STENCIL_BUFFER_BIT
	  val glClear = _import "glClear" stdcall : glenum -> unit;
	  in
	    glClear (List.foldl (fn (b, m) => Word.orb(m, toGL b)) 0w0 l)
	  end
    fun clearColor {r, g, b, a} = let
	  val glClearColor = _import "glClearColor" stdcall
		: (float * float * float * float) -> unit;
	  in
	    glClearColor (r, g, b, a)
	  end
    val clearDepth = _import "glClearDepth" stdcall : double -> unit;
    fun clearAccum {r, g, b, a} = let
	  val glClearAccum = _import "glClearAccum" stdcall
		: (float * float * float * float) -> unit;
	  in
	    glClearAccum (r, g, b, a)
	  end
    val clearStencil = _import "glClearStencil" stdcall : int -> unit;
(*
    datatype draw_buffer
      = NO_BUFFER
      | FRONT | FRONT_LEFT | FRONT_RIGHT
      | BACK | BACK_LEFT | BACK_RIGHT
      | FRONT_AND_BACK | LEFT | RIGHT
      | AUX of int
    val drawBuffer : draw_buffer -> unit
    val getDrawBuffer : unit -> draw_buffer
*)
    fun depthMask on = let
	  val glDepthMask = _import "glDepthMask" : glenum -> unit;
	  in
	    glDepthMask (if on then GLConsts.GL_TRUE else GLConsts.GL_FALSE)
	  end

  (* lighting controls *)
    fun smoothShading smooth = let
          val GL_FLAT = 0wx1D00
          val GL_SMOOTH = 0wx1D01
	  val glShadeModel = _import "glShadeModel" stdcall : glenum -> unit;
	  in
	    glShadeModel (if smooth then GL_SMOOTH else GL_FLAT)
	  end
    fun ambientLight {r, g, b, a} = let
	  val GL_LIGHT_MODEL_AMBIENT = 0wx0B53
	  val glLightModelfv = _import "glLightModelfv" stdcall
		: (glenum * float vector) -> unit;
	  val c = Vector.fromList[r, g, b, a]
	  in
	    glLightModelfv (GL_LIGHT_MODEL_AMBIENT, c)
	  end
    fun shininess (face, param) = let
	  val glMaterialf = _import "glMaterialf" stdcall
		: (glenum * glenum * float) -> unit;
	  in
	    glMaterialf (face, GL_SHININESS, param)
	  end
    fun material (face, param, c) = let
	  val glMaterialfv = _import "glMaterialf" stdcall
		: (glenum * glenum * float vector) -> unit;
	  in
	    glMaterialfv (face, param, vectorc4 c)
	  end
   (* lights *)
    local
      val glLighti = _import "glLighti" stdcall : (glenum * glenum * int) -> unit;
      val glLightf = _import "glLightf" stdcall : (glenum * glenum * float) -> unit;
      val glLightfv = _import "glLightfv" stdcall : (glenum * glenum * float vector) -> unit;
    in
    type light = glenum
    val light0 = GL_LIGHT0 + 0w0
    val light1 = GL_LIGHT0 + 0w1
    val light2 = GL_LIGHT0 + 0w2
    val light3 = GL_LIGHT0 + 0w3
    val light4 = GL_LIGHT0 + 0w4
    val light5 = GL_LIGHT0 + 0w5
    val light6 = GL_LIGHT0 + 0w6
    val light7 = GL_LIGHT0 + 0w7
(* FIXME: should check against GL_MAX_NUM_LIGHTS *)
    fun light i = if (i < 0)
	  then raise Fail "bogus light"
	  else (GL_LIGHT0 + Word.fromInt i)
  (* turn a light on/off *)
    val enableLight = enable
    val disableLight = disable
  (* configure a light *)
    fun lightPosition (l, pos) = glLightfv (l, GL_POSITION, vectorf4 pos)
    fun lightSpotDirection (l, dir) = glLightfv (l, GL_SPOT_DIRECTION, vectorf3 dir)
    fun lightSpotCutoff (l, cutoff) = glLightf (l, GL_SPOT_CUTOFF, cutoff)
    fun lightSpotExponent (l, exp) = glLightf (l, GL_SPOT_EXPONENT, exp)
    fun lightConstantAttenuation (l, aten) = glLightf (l, GL_CONSTANT_ATTENUATION, aten)
    fun lightLinearAttenuation (l, aten) = glLightf (l, GL_LINEAR_ATTENUATION, aten)
    fun lightQuadraticAttenuation (l, aten) = glLightf (l, GL_QUADRATIC_ATTENUATION, aten)
  (* higher-level light configuration *)
    fun directionLight (l, dir) = (
	  glLightfv (l, GL_POSITION, vectorf4(Vec3f.vector dir));
	  glLighti (l, GL_SPOT_CUTOFF, 180))
    fun pointLight (l, pos) = (
	  glLightfv (l, GL_POSITION, vectorf4(Vec3f.point pos));
	  glLighti (l, GL_SPOT_CUTOFF, 180))
    fun spotLight (l, {pos, dir, cutoff, exp}) = (
	  glLightfv (l, GL_POSITION, vectorf4(Vec3f.point pos));
	  glLightfv (l, GL_SPOT_DIRECTION, vectorf3 dir);
	  glLightf (l, GL_SPOT_CUTOFF, cutoff);
	  glLightf (l, GL_SPOT_EXPONENT, exp))
  (* light radiance *)
    fun lightAmbient (l, c) = glLightfv (l, GL_AMBIENT, vectorc4 c)
    fun lightDiffuse (l, c) = glLightfv (l, GL_DIFFUSE, vectorc4 c)
    fun lightSpecular (l, c) = glLightfv (l, GL_SPECULAR, vectorc4 c)
    end (* local *)

    local
      val glLightModeli = _import "glLightModeli" stdcall : (glenum * glenum) -> unit;
      val glLightModelfv = _import "glLightModelfv" stdcall : (glenum * float vector) -> unit;
    in
  (* lighting model *)
    fun lightModelAmbient c = glLightModelfv (GL_LIGHT_MODEL_AMBIENT, vectorc4 c)
    datatype color_control = SINGLE_COLOR | SEPARATE_SPECULAR_COLOR
    fun lightModelColorControl SINGLE_COLOR =
	  glLightModeli (GL_LIGHT_MODEL_COLOR_CONTROL, GL_SINGLE_COLOR)
      | lightModelColorControl SEPARATE_SPECULAR_COLOR =
	  glLightModeli (GL_LIGHT_MODEL_COLOR_CONTROL, GL_SEPARATE_SPECULAR_COLOR)
    fun lightModelLocalViewer b =  glLightModeli (GL_LIGHT_MODEL_LOCAL_VIEWER, bool2Enum b)
    fun lightModelTwoSide b = glLightModeli (GL_LIGHT_MODEL_TWO_SIDE, bool2Enum b)
    end

   (***** blending *****)
    type blend_func = glenum
    val ZERO = GL_ZERO
    val ONE = GL_ONE
    val SRC_COLOR = GL_SRC_COLOR			(* dst only *)
    val ONE_MINUS_SRC_COLOR = GL_ONE_MINUS_SRC_COLOR	(* dst only *)
    val SRC_ALPHA = GL_SRC_ALPHA
    val ONE_MINUS_SRC_ALPHA = GL_ONE_MINUS_SRC_ALPHA
    val DST_ALPHA = GL_DST_ALPHA
    val ONE_MINUS_DST_ALPHA = GL_ONE_MINUS_DST_ALPHA
    val DST_COLOR = GL_DST_COLOR			(* src only *)
    val ONE_MINUS_DST_COLOR = GL_ONE_MINUS_DST_COLOR	(* src only *)
    val SRC_ALPHA_SATURATE = GL_SRC_ALPHA_SATURATE	(* src only *)

    type blend_equation = glenum
    val MIN = GL_MIN
    val MAX = GL_MAX
    val FUNC_ADD = GL_FUNC_ADD
    val FUNC_SUBTRACT = GL_FUNC_SUBTRACT
    val FUNC_REVERSE_SUBTRACT = GL_FUNC_REVERSE_SUBTRACT

    fun blendColor c = let
	  val glBlendColor = _import "glBlendColor" stdcall
		: (float * float * float * float) -> unit;
	  in
	    glBlendColor (unpackc4 c)
	  end
(* FIXME: should combine blendEquation and blendFunc into a single operation *)
    val blendEquation = _import "glBlendEquation" stdcall : blend_equation -> unit;
    fun blendFunc {src, dst} = let
	  val glBlendFunc = _import "glBlendFunc" stdcall
		: (blend_func * blend_func) -> unit;
	  in
	    glBlendFunc (src, dst)
	  end

   (* misc. state changes *)
    val cullFace = _import "glCullFace" stdcall : face -> unit;

  (* Polygon render modes *)
    type polygon_mode = glenum
    val POINT	= GL_POINT
    val LINE	= GL_LINE
    val FILL	= GL_FILL
    val polygonMode = _import "glPolygonMode" stdcall : (glenum * glenum) -> unit;

  (* begin/end rendering *)
    type primitive = glenum
    val POINTS = GL_POINTS
    val LINES = GL_LINES
    val LINE_LOOP = GL_LINE_LOOP
    val LINE_STRIP = GL_LINE_STRIP
    val TRIANGLES = GL_TRIANGLES
    val TRIANGLE_STRIP = GL_TRIANGLE_STRIP
    val TRIANGLE_FAN = GL_TRIANGLE_FAN
    val QUADS = GL_QUADS
    val QUAD_STRIP = GL_QUAD_STRIP
    val POLYGON = GL_POLYGON

    val beginPrim  = _import "glBegin" stdcall : glenum -> unit;
    val endPrim = _import "glEnd" stdcall : unit -> unit;
    fun renderPrim (mode, f : unit -> unit) = (
	  beginPrim mode;
	  f () handle ex => (endPrim(); raise ex);
	  endPrim ())
    val finish = _import "glFinish" : unit -> unit;
    val flush = _import "glFlush" : unit -> unit;

  (* rendering commands *)
    val vertex2f = _import "glVertex2f" stdcall : (float * float) -> unit;
    fun vertex2fv v = vertex2f(unpackv2 v)
    val vertex2d = _import "glVertex2d" stdcall : (double * double) -> unit;
    fun vertex2dv v = vertex2d(unpackv2 v)
    val vertex3f = _import "glVertex3f" stdcall : (float * float * float) -> unit;
    fun vertex3fv v = vertex3f(unpackv3 v)
    val vertex3d = _import "glVertex3d" stdcall : (double * double * double) -> unit;
    fun vertex3dv v = vertex3d(unpackv3 v)
    val vertex4f = _import "glVertex4f" stdcall : (float * float * float * float) -> unit;
    fun vertex4fv v = vertex4f(unpackv4 v)
    val vertex4d = _import "glVertex4d" stdcall : (double * double * double * double) -> unit;
    fun vertex4dv v = vertex4d(unpackv4 v)

    val color3ub = _import "glColor3ub" stdcall : (ubyte * ubyte * ubyte) -> unit;
    fun color3ubv c = color3ub(unpackc3 c)
    val color3f = _import "glColor3f" stdcall : (float * float * float) -> unit;
    fun color3fv c = color3f(unpackc3 c) 
    val color4ub = _import "glColor4ub" stdcall : (ubyte * ubyte * ubyte * ubyte) -> unit;
    fun color4ubv c = color4ub(unpackc4 c)
    val color4f = _import "glColor4f" stdcall : (float * float * float * float) -> unit;
    fun color4fv c = color4f(unpackc4 c) 

    val normal3f = _import "glNormal3f" stdcall : (float * float * float) -> unit;
    fun normal3fv v = normal3f(unpackv3 v)
    val normal3d = _import "glNormal3d" stdcall : (double * double * double) -> unit;
    fun normal3dv v = normal3d(unpackv3 v)

    val texCoord1f = _import "glTexCoord1f" stdcall : float -> unit;
    val texCoord1d = _import "glTexCoord1d" stdcall : double -> unit;
    val texCoord2f = _import "glTexCoord2f" stdcall : (float * float) -> unit;
    fun texCoord2fv t = texCoord2f(unpackt2 t)
    val texCoord2d = _import "glTexCoord2d" stdcall : (double * double) -> unit;
    fun texCoord2dv t = texCoord2d(unpackt2 t)
    val texCoord3f = _import "glTexCoord3f" stdcall : (float * float * float) -> unit;
    fun texCoord3fv t = texCoord3f(unpackt3 t)
    val texCoord3d = _import "glTexCoord3d" stdcall : (double * double * double) -> unit;
    fun texCoord3dv t = texCoord3d(unpackt3 t)
    val texCoord4f = _import "glTexCoord4f" stdcall : (float * float * float * float) -> unit;
    fun texCoord4fv t = texCoord4f(unpackt4 t)
    val texCoord4d = _import "glTexCoord4d" stdcall : (double * double * double * double) -> unit;
    fun texCoord4dv t = texCoord4d(unpackt4 t)

  (* display lists *)
(* FIXME: display lists should be finalized *)
    type display_list = Word32.word
    val glNewList = _import "glNewList" stdcall : (Word32.word * glenum) -> unit;
    fun newList {list, exec=true} = glNewList (list, GL_COMPILE_AND_EXECUTE)
      | newList {list, ...} = glNewList (list, GL_COMPILE)
    val endList = _import "glEndList" stdcall : unit -> unit;
    val glGenLists = _import "glGenLists" stdcall : int -> Word32.word;
    fun genList () = let
	  val l = glGenLists 1
	  in
	    if l <> 0w0 then l else raise Fail "genList error"
	  end
    fun genLists n = if (n <= 0) then raise Size
	  else let
	    val l = glGenLists n
	    in
	      if l <> 0w0 then List.tabulate(n, fn i => l + Word32.fromInt i) else []
	    end
    val callList = _import "glCallList" stdcall : Word32.word -> unit;


  (***** raster operations *****)
    val rasterPos2s = _import "glRasterPos2s" stdcall : (short * short) -> unit;
    fun rasterPos2sv pos = rasterPos2s (unpackv2 pos)
    val rasterPos2i = _import "glRasterPos2i" stdcall : (int * int) -> unit;
    fun rasterPos2iv pos = rasterPos2i (unpackv2 pos)
    val rasterPos2f = _import "glRasterPos2f" stdcall : (float * float) -> unit;
    fun rasterPos2fv pos = rasterPos2f (unpackv2 pos)
    val rasterPos2d = _import "glRasterPos2d" stdcall : (double * double) -> unit;
    fun rasterPos2dv pos = rasterPos2d (unpackv2 pos)
    val rasterPos3s = _import "glRasterPos3s" stdcall : (short * short * short) -> unit;
    fun rasterPos3sv pos = rasterPos3s (unpackv3 pos)
    val rasterPos3i = _import "glRasterPos3i" stdcall : (int * int * int) -> unit;
    fun rasterPos3iv pos = rasterPos3i (unpackv3 pos)
    val rasterPos3f = _import "glRasterPos3f" stdcall : (float * float * float) -> unit;
    fun rasterPos3fv pos = rasterPos3f (unpackv3 pos)
    val rasterPos3d = _import "glRasterPos3d" stdcall : (double * double * double) -> unit;
    fun rasterPos3dv pos = rasterPos3d (unpackv3 pos)
    val rasterPos4s = _import "glRasterPos4s" stdcall : (short * short * short * short) -> unit;
    fun rasterPos4sv pos = rasterPos4s (unpackv4 pos)
    val rasterPos4i = _import "glRasterPos4i" stdcall : (int * int * int * int) -> unit;
    fun rasterPos4iv pos = rasterPos4i (unpackv4 pos)
    val rasterPos4f = _import "glRasterPos4f" stdcall : (float * float * float * float) -> unit;
    fun rasterPos4fv pos = rasterPos4f (unpackv4 pos)
    val rasterPos4d = _import "glRasterPos4d" stdcall : (double * double * double * double) -> unit;
    fun rasterPos4dv pos = rasterPos4d (unpackv4 pos)

(* FIXME *)
    val getCurrentRasterColorf : unit -> color4f
    val getCurrentRasterDistance : unit -> float
    val getCurrentRasterPosition : unit -> vec4f
    val isCurrentRasterPositionValid : unit -> bool
    val getCurrentRasterTextureCoords : unit -> tex4f


  (***** Information about the renderer etc. *****)
    local
      val glGetString = _import "glGetString" stdcall : glenum -> MLton.Pointer.t;
      fun get name = (case CString.toML(glGetString name)
	     of NONE => GLError.raiseError "glGetString: "
	      | SOME s => s
	    (* end case *))
    in
    fun getVendorString () = get GL_VENDOR
    fun getRendererString () = get GL_RENDERER
    fun getVersionString () = get GL_VERSION
    fun getExtensionsString () = get GL_EXTENSIONS
    fun getExtensions () = String.tokens Char.isSpace (getExtensionsString())
    end

  end

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