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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 801 - (download) (annotate)
Tue Mar 23 21:39:16 2010 UTC (9 years, 6 months ago) by jhr
File size: 30568 byte(s)
  Patches to work with the raw-data library
(* glut.sml
 *
 * COPYRIGHT (c) 2005 John Reppy (http://www.cs.uchicago.edu/~jhr)
 * All rights reserved.
 *
 * SML interface to the GLUT library.
 *
 * TODO:
 *	finish call-back API
 *	state get functions: glutLayerGet, glutGetColor, 
 *	call backs should be per-window, so we need to build a multiplexing layer.
 *)

structure GLUT :> GLUT =
  struct

    structure Ptr = MLton.Pointer

    type double = Real64.real

  (* the GLUT API uses 0, 1 for booleans and 0 for NONE *)
    fun int2ID 0 = NONE
      | int2ID id = SOME id
    fun int2Bool i = (i <> 0)
    fun id2Int (SOME id) = id
      | id2Int NONE = 0
    fun bool2Int false = 0
      | bool2Int true = 1

  (* display initialization values *)
    local
      val GLUT_RGB = 0w0
      val GLUT_RGBA = GLUT_RGB
      val GLUT_INDEX = 0w1
      val GLUT_SINGLE = 0w0
      val GLUT_DOUBLE = 0w2
      val GLUT_ACCUM = 0w4
      val GLUT_ALPHA = 0w8
      val GLUT_DEPTH = 0w16
      val GLUT_STENCIL = 0w32
    (* the following require GLUT_API_VERSION >= 2 *)
      val GLUT_MULTISAMPLE = 0w128
      val GLUT_STEREO = 0w256
    (* the following require GLUT_API_VERSION >= 3 *)
      val GLUT_LUMINANCE = 0w512
    in
    datatype display_mode
      = RGB | RGBA | INDEX
      | SINGLE | DOUBLE | ACCUM | ALPHA | DEPTH | STENCIL
      | MULTISAMPLE | STEREO | LUMINANCE
    fun dmToGlut RGB = GLUT_RGB
      | dmToGlut RGBA = GLUT_RGBA
      | dmToGlut INDEX = GLUT_INDEX
      | dmToGlut SINGLE = GLUT_SINGLE
      | dmToGlut DOUBLE = GLUT_DOUBLE
      | dmToGlut ACCUM = GLUT_ACCUM
      | dmToGlut ALPHA = GLUT_ALPHA
      | dmToGlut DEPTH = GLUT_DEPTH
      | dmToGlut STENCIL = GLUT_STENCIL
      | dmToGlut MULTISAMPLE = GLUT_MULTISAMPLE
      | dmToGlut STEREO = GLUT_STEREO
      | dmToGlut LUMINANCE = GLUT_LUMINANCE
    end

  (* Mouse buttons *)
    local
      val GLUT_LEFT_BUTTON = 0
      val GLUT_MIDDLE_BUTTON = 1
      val GLUT_RIGHT_BUTTON = 2
    in
    datatype mouse_button = LEFT_BUTTON | MIDDLE_BUTTON | RIGHT_BUTTON
    fun mbToGlut LEFT_BUTTON = GLUT_LEFT_BUTTON
      | mbToGlut RIGHT_BUTTON = GLUT_RIGHT_BUTTON
      | mbToGlut MIDDLE_BUTTON = GLUT_MIDDLE_BUTTON
    fun mbFromGlut b = if (b = GLUT_LEFT_BUTTON) then LEFT_BUTTON
	  else if (b = GLUT_MIDDLE_BUTTON) then MIDDLE_BUTTON
	  else if (b = GLUT_RIGHT_BUTTON) then RIGHT_BUTTON
	  else raise Fail "unknown mouse button"
    end (* local *)

  (* Button states (use bool; true = down, false = up) *)
    local
      val GLUT_DOWN = 0
      val GLUT_UP = 1
    in
    fun bsToGlut false = GLUT_UP
      | bsToGlut true = GLUT_DOWN
    fun bsFromGlut s = (s = GLUT_DOWN)
    end

  (* Special keys *)
    local
      val GLUT_KEY_F1 = 1
      val GLUT_KEY_F2 = 2
      val GLUT_KEY_F3 = 3
      val GLUT_KEY_F4 = 4
      val GLUT_KEY_F5 = 5
      val GLUT_KEY_F6 = 6
      val GLUT_KEY_F7 = 7
      val GLUT_KEY_F8 = 8
      val GLUT_KEY_F9 = 9
      val GLUT_KEY_F10 = 10
      val GLUT_KEY_F11 = 11
      val GLUT_KEY_F12 = 12
      val GLUT_KEY_LEFT = 100
      val GLUT_KEY_UP = 101
      val GLUT_KEY_RIGHT = 102
      val GLUT_KEY_DOWN = 103
      val GLUT_KEY_PAGE_UP = 104
      val GLUT_KEY_PAGE_DOWN = 105
      val GLUT_KEY_HOME = 106
      val GLUT_KEY_END = 107
      val GLUT_KEY_INSERT = 108
    in
    datatype special_key
    (* function keys *)
      = KEY_F1 | KEY_F2 | KEY_F3 | KEY_F4 | KEY_F5 | KEY_F6
      | KEY_F7 | KEY_F8 | KEY_F9 | KEY_F10 | KEY_F11 | KEY_F12
    (* directional keys *)
      | KEY_LEFT | KEY_UP | KEY_RIGHT | KEY_DOWN | KEY_PAGE_UP | KEY_PAGE_DOWN
      | KEY_HOME | KEY_END | KEY_INSERT
    fun skToGlut KEY_F1 = GLUT_KEY_F1
      | skToGlut KEY_F2 = GLUT_KEY_F2
      | skToGlut KEY_F3 = GLUT_KEY_F3
      | skToGlut KEY_F4 = GLUT_KEY_F4
      | skToGlut KEY_F5 = GLUT_KEY_F5
      | skToGlut KEY_F6 = GLUT_KEY_F6
      | skToGlut KEY_F7 = GLUT_KEY_F7
      | skToGlut KEY_F8 = GLUT_KEY_F8
      | skToGlut KEY_F9 = GLUT_KEY_F9
      | skToGlut KEY_F10 = GLUT_KEY_F10
      | skToGlut KEY_F11 = GLUT_KEY_F11
      | skToGlut KEY_F12 = GLUT_KEY_F12
      | skToGlut KEY_LEFT = GLUT_KEY_LEFT
      | skToGlut KEY_UP = GLUT_KEY_UP
      | skToGlut KEY_RIGHT = GLUT_KEY_RIGHT
      | skToGlut KEY_DOWN = GLUT_KEY_DOWN
      | skToGlut KEY_PAGE_UP = GLUT_KEY_PAGE_UP
      | skToGlut KEY_PAGE_DOWN = GLUT_KEY_PAGE_DOWN
      | skToGlut KEY_HOME = GLUT_KEY_HOME
      | skToGlut KEY_END = GLUT_KEY_END
      | skToGlut KEY_INSERT = GLUT_KEY_INSERT
    fun skFromGlut k =
	  if (k = GLUT_KEY_F1) then KEY_F1
	  else if (k = GLUT_KEY_F2) then KEY_F2
	  else if (k = GLUT_KEY_F3) then KEY_F3
	  else if (k = GLUT_KEY_F4) then KEY_F4
	  else if (k = GLUT_KEY_F5) then KEY_F5
	  else if (k = GLUT_KEY_F6) then KEY_F6
	  else if (k = GLUT_KEY_F7) then KEY_F7
	  else if (k = GLUT_KEY_F8) then KEY_F8
	  else if (k = GLUT_KEY_F9) then KEY_F9
	  else if (k = GLUT_KEY_F10) then KEY_F10
	  else if (k = GLUT_KEY_F11) then KEY_F11
	  else if (k = GLUT_KEY_F12) then KEY_F12
	  else if (k = GLUT_KEY_LEFT) then KEY_LEFT
	  else if (k = GLUT_KEY_UP) then KEY_UP
	  else if (k = GLUT_KEY_RIGHT) then KEY_RIGHT
	  else if (k = GLUT_KEY_DOWN) then KEY_DOWN
	  else if (k = GLUT_KEY_PAGE_UP) then KEY_PAGE_UP
	  else if (k = GLUT_KEY_PAGE_DOWN) then KEY_PAGE_DOWN
	  else if (k = GLUT_KEY_HOME) then KEY_HOME
	  else if (k = GLUT_KEY_END) then KEY_END
	  else if (k = GLUT_KEY_INSERT) then KEY_INSERT
	  else raise Fail "unknown mouse button"
    end

    local
    (* glutGetModifiers return mask. *)
      val GLUT_ACTIVE_SHIFT : word =	0w1
      val GLUT_ACTIVE_CTRL : word =	0w2
      val GLUT_ACTIVE_ALT : word =	0w4
      val glutGetModifiers = _import "glutGetModifiers" stdcall : unit -> word;
    in
    fun getModifiers () = let
	  val w = glutGetModifiers ()
	  in {
	    shift = (Word.andb(w, GLUT_ACTIVE_SHIFT) <> 0w0),
    	    ctrl = (Word.andb(w, GLUT_ACTIVE_CTRL) <> 0w0),
	    alt = (Word.andb(w, GLUT_ACTIVE_ALT) <> 0w0)
	  } end
    end


  (* cursors *)
    local
    (* glutSetCursor parameters. *)
    (* Basic arrows. *)
      val GLUT_CURSOR_RIGHT_ARROW = 0
      val GLUT_CURSOR_LEFT_ARROW = 1
    (* Symbolic cursor shapes. *)
      val GLUT_CURSOR_INFO = 2
      val GLUT_CURSOR_DESTROY = 3
      val GLUT_CURSOR_HELP = 4
      val GLUT_CURSOR_CYCLE = 5
      val GLUT_CURSOR_SPRAY = 6
      val GLUT_CURSOR_WAIT = 7
      val GLUT_CURSOR_TEXT = 8
      val GLUT_CURSOR_CROSSHAIR = 9
    (* Directional cursors. *)
      val GLUT_CURSOR_UP_DOWN = 10
      val GLUT_CURSOR_LEFT_RIGHT = 11
    (* Sizing cursors. *)
      val GLUT_CURSOR_TOP_SIDE = 12
      val GLUT_CURSOR_BOTTOM_SIDE = 13
      val GLUT_CURSOR_LEFT_SIDE = 14
      val GLUT_CURSOR_RIGHT_SIDE = 15
      val GLUT_CURSOR_TOP_LEFT_CORNER = 16
      val GLUT_CURSOR_TOP_RIGHT_CORNER = 17
      val GLUT_CURSOR_BOTTOM_RIGHT_CORNER = 18
      val GLUT_CURSOR_BOTTOM_LEFT_CORNER = 19
    (* Inherit from parent window. *)
      val GLUT_CURSOR_INHERIT = 100
    (* Blank cursor. *)
      val GLUT_CURSOR_NONE = 101
      (* Fullscreen crosshair (if available). *)
      val GLUT_CURSOR_FULL_CROSSHAIR = 102
    in
    datatype cursor
    (* Basic arrows. *)
      = CURSOR_RIGHT_ARROW
      | CURSOR_LEFT_ARROW
    (* Symbolic cursor shapes. *)
      | CURSOR_INFO
      | CURSOR_DESTROY
      | CURSOR_HELP
      | CURSOR_CYCLE
      | CURSOR_SPRAY
      | CURSOR_WAIT
      | CURSOR_TEXT
      | CURSOR_CROSSHAIR
    (* Directional cursors. *)
      | CURSOR_UP_DOWN
      | CURSOR_LEFT_RIGHT
        (* Sizing cursors. *)
      | CURSOR_TOP_SIDE
      | CURSOR_BOTTOM_SIDE
      | CURSOR_LEFT_SIDE
      | CURSOR_RIGHT_SIDE
      | CURSOR_TOP_LEFT_CORNER
      | CURSOR_TOP_RIGHT_CORNER
      | CURSOR_BOTTOM_RIGHT_CORNER
      | CURSOR_BOTTOM_LEFT_CORNER
    (* Inherit from parent window. *)
      | CURSOR_INHERIT
    (* Blank cursor. *)
      | CURSOR_NONE
    (* Fullscreen crosshair (if available). *)
      | CURSOR_FULL_CROSSHAIR
    fun curToGlut CURSOR_RIGHT_ARROW = GLUT_CURSOR_RIGHT_ARROW
      | curToGlut CURSOR_LEFT_ARROW = GLUT_CURSOR_LEFT_ARROW
      | curToGlut CURSOR_INFO = GLUT_CURSOR_INFO
      | curToGlut CURSOR_DESTROY = GLUT_CURSOR_DESTROY
      | curToGlut CURSOR_HELP = GLUT_CURSOR_HELP
      | curToGlut CURSOR_CYCLE = GLUT_CURSOR_CYCLE
      | curToGlut CURSOR_SPRAY = GLUT_CURSOR_SPRAY
      | curToGlut CURSOR_WAIT = GLUT_CURSOR_WAIT
      | curToGlut CURSOR_TEXT = GLUT_CURSOR_TEXT
      | curToGlut CURSOR_CROSSHAIR = GLUT_CURSOR_CROSSHAIR
      | curToGlut CURSOR_UP_DOWN = GLUT_CURSOR_UP_DOWN
      | curToGlut CURSOR_LEFT_RIGHT = GLUT_CURSOR_LEFT_RIGHT
      | curToGlut CURSOR_TOP_SIDE = GLUT_CURSOR_TOP_SIDE
      | curToGlut CURSOR_BOTTOM_SIDE = GLUT_CURSOR_BOTTOM_SIDE
      | curToGlut CURSOR_LEFT_SIDE = GLUT_CURSOR_LEFT_SIDE
      | curToGlut CURSOR_RIGHT_SIDE = GLUT_CURSOR_RIGHT_SIDE
      | curToGlut CURSOR_TOP_LEFT_CORNER = GLUT_CURSOR_TOP_LEFT_CORNER
      | curToGlut CURSOR_TOP_RIGHT_CORNER = GLUT_CURSOR_TOP_RIGHT_CORNER
      | curToGlut CURSOR_BOTTOM_RIGHT_CORNER = GLUT_CURSOR_BOTTOM_RIGHT_CORNER
      | curToGlut CURSOR_BOTTOM_LEFT_CORNER = GLUT_CURSOR_BOTTOM_LEFT_CORNER
      | curToGlut CURSOR_INHERIT = GLUT_CURSOR_INHERIT
      | curToGlut CURSOR_NONE = GLUT_CURSOR_NONE
      | curToGlut CURSOR_FULL_CROSSHAIR = GLUT_CURSOR_FULL_CROSSHAIR
    fun curFromGlut c =
	  if (c = GLUT_CURSOR_RIGHT_ARROW) then CURSOR_RIGHT_ARROW
	  else if (c = GLUT_CURSOR_LEFT_ARROW) then CURSOR_LEFT_ARROW
	  else if (c = GLUT_CURSOR_INFO) then CURSOR_INFO
	  else if (c = GLUT_CURSOR_DESTROY) then CURSOR_DESTROY
	  else if (c = GLUT_CURSOR_HELP) then CURSOR_HELP
	  else if (c = GLUT_CURSOR_CYCLE) then CURSOR_CYCLE
	  else if (c = GLUT_CURSOR_SPRAY) then CURSOR_SPRAY
	  else if (c = GLUT_CURSOR_WAIT) then CURSOR_WAIT
	  else if (c = GLUT_CURSOR_TEXT) then CURSOR_TEXT
	  else if (c = GLUT_CURSOR_CROSSHAIR) then CURSOR_CROSSHAIR
	  else if (c = GLUT_CURSOR_UP_DOWN) then CURSOR_UP_DOWN
	  else if (c = GLUT_CURSOR_LEFT_RIGHT) then CURSOR_LEFT_RIGHT
	  else if (c = GLUT_CURSOR_TOP_SIDE) then CURSOR_TOP_SIDE
	  else if (c = GLUT_CURSOR_BOTTOM_SIDE) then CURSOR_BOTTOM_SIDE
	  else if (c = GLUT_CURSOR_LEFT_SIDE) then CURSOR_LEFT_SIDE
	  else if (c = GLUT_CURSOR_RIGHT_SIDE) then CURSOR_RIGHT_SIDE
	  else if (c = GLUT_CURSOR_TOP_LEFT_CORNER) then CURSOR_TOP_LEFT_CORNER
	  else if (c = GLUT_CURSOR_TOP_RIGHT_CORNER) then CURSOR_TOP_RIGHT_CORNER
	  else if (c = GLUT_CURSOR_BOTTOM_RIGHT_CORNER) then CURSOR_BOTTOM_RIGHT_CORNER
	  else if (c = GLUT_CURSOR_BOTTOM_LEFT_CORNER) then CURSOR_BOTTOM_LEFT_CORNER
	  else if (c = GLUT_CURSOR_INHERIT) then CURSOR_INHERIT
	  else if (c = GLUT_CURSOR_NONE) then CURSOR_NONE
	  else if (c = GLUT_CURSOR_FULL_CROSSHAIR) then CURSOR_FULL_CROSSHAIR
	  else raise Fail "unknown cursor"
    end

  (* null-terminate an SML string *)
    fun cString s = s ^ "\000"

  (* GLUT initialization API. *)
    val glutInit = _import "glutInit" stdcall : (Int32.int ref * CAlloc.c_pointer array) -> unit;
    fun initWithArgs argv = let
	(* copy the argument vector into a C array *)
	  val args = List.map CString.fromString (CommandLine.name() :: argv)
	  val nargs = length args
	  val argc = ref nargs
	  val argv' = Array.array(nargs + 1, MLton.Pointer.null)
	  fun set (cs, i) = (Array.update(argv', i, cs); i+1)
	  in
	    ignore (List.foldl set 0 args);
	    glutInit (argc, argv');
	  (* the new value of argc has the number of remaining arguments *)
	    if (!argc < nargs)
	      then let
	      (* GLUT consumed some arguments, so return the survivors; we skip
	       * arg 0, since it is the command name, which is not part of the SML
	       * argument list.
	       *)
		fun get (0, args) = args
		  | get (i, args) = get (i-1, CString.toString(Array.sub(argv', i))::args)
		in
		  get (!argc+1, [])
		end
	      else argv
	    before List.app CAlloc.free args
	  end
    fun init () = ignore (initWithArgs (CommandLine.arguments()))
    fun initDisplayMode mode = let
	  val glutInitDisplayMode = _import "glutInitDisplayMode" stdcall : word -> unit;
	  val mode' = List.foldl (fn (m, m') => Word.orb(dmToGlut m, m')) 0w0 mode
	  in
	    glutInitDisplayMode mode'
	  end
    fun initWindowPosition {x, y} = let
	  val glutInitWindowPosition =
		_import "glutInitWindowPosition" stdcall : (int * int) -> unit;
	  in
	    glutInitWindowPosition (x, y)
	  end
    fun initWindowSize {wid, ht} = let
	  val glutInitWindowSize = _import "glutInitWindowSize" stdcall : (int * int) -> unit;
	  in
	    glutInitWindowSize (wid, ht)
	  end
    local
    (* NOTE: MLton doesn't allow 'a as a return type for imports! *)
      val glutMainLoop = _import "glutMainLoop" stdcall : unit -> unit;
    in
    fun mainLoop () = (glutMainLoop(); raise Fail "unexpected return from main loop")
    end

  (* the following require GLUT_API_VERSION >= 4 *)
    fun initDisplayString s = let
	  val glutInitDisplayString = _import "glutInitDisplayString" stdcall : string -> unit;
	  in
	    glutInitDisplayString (cString s)
	  end

  (* GLUT window API *)
    type win_id = int
    fun createWindow s = let
	  val glutCreateWindow = _import "glutCreateWindow" stdcall : string -> int;
	  in
	    glutCreateWindow (cString s)
	  end
    fun createSubWindow {win, x, y, wid, ht} = let
	  val glutCreateSubWindow =
		_import "glutCreateSubWindow" stdcall : (int * int * int * int * int) -> int;
	  val id = glutCreateSubWindow(win, x, y, wid, ht)
	  in
	    if (id < 1) then raise Fail "createSubWindow" else id
	  end
    val destroyWindow	= _import "glutDestroyWindow" stdcall : win_id -> unit;
    val postRedisplay	= _import "glutPostRedisplay" stdcall : unit -> unit;
    val swapBuffers	= _import "glutSwapBuffers" stdcall : unit -> unit;
    val getWindow	= _import "glutGetWindow" stdcall : unit -> int;
    val setWindow	= _import "glutSetWindow" stdcall : win_id -> unit;
    fun setWindowTitle s = let
	  val glutSetWindowTitle = _import "glutSetWindowTitle" stdcall : string -> unit;
	  in
	    glutSetWindowTitle (cString s)
	  end
    fun setIconTitle s = let
	  val glutSetIconTitle = _import "glutSetIconTitle" stdcall : string -> unit;
	  in
	    glutSetIconTitle (cString s)
	  end
    fun positionWindow {x, y} = let
	  val glutPositionWindow = _import "glutPositionWindow" stdcall : (int * int) -> unit;
	  in
	    glutPositionWindow (x, y)
	  end
    fun reshapeWindow {wid, ht} = let
	  val glutReshapeWindow = _import "glutReshapeWindow" stdcall : (int * int) -> unit;
	  in
	    glutReshapeWindow (wid, ht)
	  end
    val popWindow	= _import "glutPopWindow" stdcall : unit -> unit;
    val pushWindow	= _import "glutPushWindow" stdcall : unit -> unit;
    val iconifyWindow	= _import "glutIconifyWindow" stdcall : unit -> unit;
    val showWindow	= _import "glutShowWindow" stdcall : unit -> unit;
    val hideWindow	= _import "glutHideWindow" stdcall : unit -> unit;
  (* the following require GLUT_API_VERSION >= 3 *)
    val fullScreen	= _import "glutFullScreen" stdcall : unit -> unit;
    fun setCursor c = let
	  val glutSetCursor = _import "glutSetCursor" stdcall : int -> unit;
	  in
	    glutSetCursor (curToGlut c)
	  end
  (* the following require GLUT_API_VERSION >= 4 *)
    val postWindowRedisplay = _import "glutPostWindowRedisplay" stdcall : win_id -> unit;
    fun warpPointer {x, y} = let
	  val glutWarpPointer = _import "glutWarpPointer" stdcall : (int * int) -> unit;
	  in
	    glutWarpPointer (x, y)
	  end
(* TODO: MacOS X specific functions:
    val surfaceTexture : {target : GL.enum, internalformat : GL.enum, surfacewin : win_id} -> unit
    val wmCloseFunc : (unit -> unit) option -> unit
    val checkLoop : unit -> unit
*)

  (* menus *)
    type menu_id = int
    val exportCreateMenu	= _export "glutCreateMenuCB" private cdecl : (int -> unit) -> unit;
    val glutCreateMenuCB	= _address "glutCreateMenuCB" private : Ptr.t;
    val glutCreateMenuFunc	= _import "glutCreateMenu" stdcall : Ptr.t -> int;
    fun createMenu menuFn = let
	  val _ = exportCreateMenu menuFn
	  in
	    glutCreateMenuFunc glutCreateMenuCB
	  end
    val destroyMenu = _import "glutDestroyMenu" stdcall : menu_id -> unit;
    fun getMenu () = let
	  val glutGetMenu = _import "glutGetMenu" stdcall : unit -> int;
	  val id = glutGetMenu()
	  in
	    if (id = 0) then NONE else SOME id
	  end
    val setMenu = _import "glutSetMenu" stdcall : int -> unit;
    fun addMenuEntry (label, id) = let
	  val glutAddMenu = _import "glutAddMenu" stdcall : (string * int) -> unit;
	  in
	    glutAddMenu (cString label, id)
	  end
    fun addSubMenu (label, id) = let
	  val glutAddSubMenu = _import "glutAddSubMenu" stdcall : (string * int) -> unit;
	  in
	    glutAddSubMenu (cString label, id)
	  end
    val removeMenuItem = _import "glutRemoveMenuItem" stdcall : int -> unit;

  (* GLUT callbacks.  For a GLUT callback registration function glutXXXFunc,
   * we bind three SML variables:
   *
   *    1) "exportXXXF"		- the ML function for binding an SML function
   *				  as a callback.
   *	2) "glueXXXCB"		- the address of the C wrapper around the SML
   *				  callback.
   *	3) "glutXXXFunc"	- the GLUT function for registering the callback.
   *
   * Note that on Windows, the callback functions use the "cdecl" convention,
   * even though the glut library functions use "stdcall".
   *)

    val exportDisplay		= _export "glutDisplayCB" private cdecl : (unit -> unit) -> unit;
    val glutDisplayCB		= _address "glutDisplayCB" private : Ptr.t;
    val glutDisplayFunc		= _import "glutDisplayFunc" stdcall : Ptr.t -> unit;
    fun displayFunc (SOME f) = (
	  exportDisplay f;
	  glutDisplayFunc glutDisplayCB)
      | displayFunc NONE = glutDisplayFunc Ptr.null

    val exportReshape		= _export "glutReshapeCB" private cdecl : ((int * int) -> unit) -> unit;
    val glutReshapeCB		= _address "glutReshapeCB" private : Ptr.t;
    val glutReshapeFunc		= _import "glutReshapeFunc" stdcall : Ptr.t -> unit;
    fun reshapeFunc (SOME f) = let
	  fun wrapF (wid, ht) = f {wid=wid, ht=ht}
	  in
	    exportReshape wrapF;
	    glutReshapeFunc glutReshapeCB
	  end
      | reshapeFunc NONE = glutReshapeFunc Ptr.null

    val exportKeyboard		= _export "glutKeyboardCB" private cdecl : ((char * int * int) -> unit) -> unit;
    val glutKeyboardCB		= _address "glutKeyboardCB" private : Ptr.t;
    val glutKeyboardFunc	= _import "glutKeyboardFunc" stdcall : Ptr.t -> unit;
    fun keyboardFunc (SOME f) = let
	  fun wrapF (key, x, y) = f(key, {x=x, y=y})
	  in
	    exportKeyboard wrapF;
	    glutKeyboardFunc glutKeyboardCB
	  end
      | keyboardFunc NONE = glutKeyboardFunc Ptr.null

    val exportMouse		= _export "glutMouseCB" private cdecl : ((int * int * int * int) -> unit) -> unit;
    val glutMouseCB		= _address "glutMouseCB" private : Ptr.t;
    val glutMouseFunc		= _import "glutMouseFunc" stdcall : Ptr.t -> unit;
    fun mouseFunc (SOME f) = let
	  fun wrapF (mb, s, x, y) = f(mbFromGlut mb, bsFromGlut s, {x=x, y=y})
	  in
	    exportMouse wrapF;
	    glutMouseFunc glutMouseCB
	  end
      | mouseFunc NONE = glutMouseFunc Ptr.null

    val exportMotion		= _export "glutMotionCB" private cdecl : ((int * int) -> unit) -> unit;
    val glutMotionCB		= _address "glutMotionCB" private : Ptr.t;
    val glutMotionFunc		= _import "glutMotionFunc" stdcall : Ptr.t -> unit;
    fun motionFunc (SOME f) = let
	  fun wrapF (x, y) = f{x=x, y=y}
	  in
	    exportMotion wrapF;
	    glutMotionFunc glutMotionCB
	  end
      | motionFunc NONE = glutMotionFunc Ptr.null

    val exportPassiveMotion	= _export "glutPassiveMotionCB" private cdecl : ((int * int) -> unit) -> unit;
    val glutPassiveMotionCB	= _address "glutPassiveMotionCB" private : Ptr.t;
    val glutPassiveMotionFunc	= _import "glutPassiveMotionFunc" stdcall : Ptr.t -> unit;
    fun passiveMotionFunc (SOME f) = let
	  fun wrapF (x, y) = f{x=x, y=y}
	  in
	    exportPassiveMotion wrapF;
	    glutPassiveMotionFunc glutMotionCB
	  end
      | passiveMotionFunc NONE = glutPassiveMotionFunc Ptr.null

    val exportEntry		= _export "glutEntryCB" private cdecl : (int -> unit) -> unit;
    val glutEntryCB		= _address "glutEntryCB" private : Ptr.t;
    val glutEntryFunc		= _import "glutEntryFunc" stdcall : Ptr.t -> unit;
  (* Entry/exit state. *)
    val GLUT_LEFT = 0
    val GLUT_ENTERED = 1
    fun entryFunc (SOME f) = let
	  fun wrapF state = f(state = GLUT_ENTERED)
	  in
	    exportEntry wrapF;
	    glutEntryFunc glutEntryCB
	  end
      | entryFunc NONE = glutEntryFunc Ptr.null

    val exportVisibility	= _export "glutVisibilityCB" private cdecl : (int -> unit) -> unit;
    val glutVisibilityCB	= _address "glutVisibilityCB" private : Ptr.t;
    val glutVisibilityFunc	= _import "glutVisibilityFunc" stdcall : Ptr.t -> unit;
  (* Visibility state. *)
    val GLUT_NOT_VISIBLE = 0
    val GLUT_VISIBLE = 1
    fun visibilityFunc (SOME f) = let
	  fun wrapF state = f(state = GLUT_VISIBLE)
	  in
	    exportVisibility wrapF;
	    glutVisibilityFunc glutVisibilityCB
	  end
      | visibilityFunc NONE = glutEntryFunc Ptr.null

    val exportIdle		= _export "glutIdleCB" private cdecl : (unit -> unit) -> unit;
    val glutIdleCB		= _address "glutIdleCB" private : Ptr.t;
    val glutIdleFunc		= _import "glutIdleFunc" stdcall : Ptr.t -> unit;
    fun idleFunc (SOME f) = (
	  exportIdle f;
	  glutIdleFunc glutIdleCB)
      | idleFunc NONE = glutIdleFunc Ptr.null

(* FIXME: GLUT allows multiple outstanding timers, but because of MLton's limited support
 * for callbacks, we can only have one function registered at a time.  We need to implement
 * our own multiplexing.
 *)
    val exportTimer		= _export "glutTimerCB" private cdecl : (int -> unit) -> unit;
    val glutTimerCB		= _address "glutTimerCB" private : Ptr.t;
    val glutTimerFunc		= _import "glutTimerFunc" stdcall : (Int32.int * Ptr.t * int) -> unit;
    fun timerFunc (t, f) = let
	  val t = Int32.fromLarge(Time.toMilliseconds t)
	  fun wrapF _ = f()
	  in
	    exportTimer wrapF;
	    glutTimerFunc (t, glutTimerCB, 0)
	  end

  (* the following require GLUT_API_VERSION >= 2 *)
    val exportSpecial		= _export "glutSpecialCB" private cdecl : ((int * int * int) -> unit) -> unit;
    val glutSpecialCB		= _address "glutSpecialCB" private : Ptr.t;
    val glutSpecialFunc		= _import "glutSpecialFunc" stdcall : Ptr.t -> unit;
    fun specialFunc (SOME f) = let
	  fun wrapF (k, x, y) = f(skFromGlut k, {x=x, y=y})
	  in
	    exportSpecial wrapF;
	    glutSpecialFunc glutSpecialCB
	  end
      | specialFunc NONE = glutSpecialFunc Ptr.null

  (* the following require GLUT_API_VERSION >= 3 *)
    val GLUT_MENU_IN_USE = 1
    val GLUT_MENU_NOT_IN_USE = 0
    val exportMenuStatus	= _export "glutMenuStatusCB" private cdecl : ((int * int * int) -> unit) -> unit;
    val glutMenuStatusCB	= _address "glutMenuStatusCB" private : Ptr.t;
    val glutMenuStatusFunc	= _import "glutMenuStatusFunc" stdcall : Ptr.t -> unit;
    fun menuStatusFunc _ = raise Fail "menuStatusFunc"
    fun menuStatusFunc (SOME f) = let
	  fun wrapF (sts, x, y) = f((sts = GLUT_MENU_IN_USE), {x=x, y=y})
	  in
	    exportMenuStatus wrapF;
	    glutMenuStatusFunc glutMenuStatusCB
	  end
      | menuStatusFunc NONE = glutMenuStatusFunc Ptr.null

  (* the following require GLUT_API_VERSION >= 4 *)
    val exportKeyboardUp	= _export "glutKeyboardUpCB" private cdecl : ((char * int * int) -> unit) -> unit;
    val glutKeyboardUpCB	= _address "glutKeyboardUpCB" private : Ptr.t;
    val glutKeyboardUpFunc	= _import "glutKeyboardUpFunc" stdcall : Ptr.t -> unit;
    fun keyboardUpFunc (SOME f) = let
	  fun wrapF (key, x, y) = f(key, {x=x, y=y})
	  in
	    exportKeyboardUp wrapF;
	    glutKeyboardUpFunc glutKeyboardUpCB
	  end
      | keyboardUpFunc NONE = glutKeyboardUpFunc Ptr.null

    val exportSpecialUp		= _export "glutSpecialUpCB" private cdecl : ((int * int * int) -> unit) -> unit;
    val glutSpecialUpCB		= _address "glutSpecialUpCB" private : Ptr.t;
    val glutSpecialUpFunc	= _import "glutSpecialUpFunc" stdcall : Ptr.t -> unit;
    fun specialUpFunc (SOME f) = let
	  fun wrapF (k, x, y) = f(skFromGlut k, {x=x, y=y})
	  in
	    exportSpecialUp wrapF;
	    glutSpecialUpFunc glutSpecialUpCB
	  end
      | specialUpFunc NONE = glutSpecialUpFunc Ptr.null


  (***** GLUT state retrieval sub-API *****)
    local
      val glutGet = _import "glutGet" stdcall : int -> int;
      fun get code () = glutGet code
    in
    val getWindowX			= get 100
    val getWindowY			= get 101
    val getWindowWidth			= get 102
    val getWindowHeight			= get 103
    val getWindowBufferSize		= get 104
    val getWindowStencilSize		= get 105
    val getWindowDepthSize		= get 106
    val getWindowRedSize		= get 107
    val getWindowGreenSize		= get 108
    val getWindowBlueSize		= get 109
    val getWindowAlphaSize		= get 110
    val getWindowAccumRedSize		= get 111
    val getWindowAccumGreenSize		= get 112
    val getWindowAccumBlueSize		= get 113
    val getWindowAccumAlphaSize		= get 114
    val getWindowDoublebuffer		= int2Bool o get 115
    val getWindowRGBA			= int2Bool o get 116
    val getWindowParent			= int2ID o get 117
    val getWindowNumChildren		= get 118
    val getWindowColormapSize		= get 119
    val getWindowNumSamples		= get 120
    val getWindowStereo			= int2Bool o get 121
    val getWindowCursor			= curFromGlut o get 122
    val getScreenWidth			= get 200
    val getScreenHeight			= get 201
    val getScreenWidthMM		= get 202
    val getScreenHeightMM		= get 203
    val getMenuNumItems			= get 300
    val getDisplayModePossible		= int2Bool o get 400
    val getInitWindowX			= get 500
    val getInitWindowY			= get 501
    val getInitWindowWidth		= get 502
    val getInitWindowHeight		= get 503
    val getInitDisplayMode		= get 504
    val getElapsedTime			= Time.fromMilliseconds o Int.toLarge o (get 700)
    val getWindowFormatId		= get 123
    end

    local
      val glutDeviceGet = _import "glutDeviceGet" stdcall : int -> int;
      fun get code () = glutDeviceGet code
    in
    val getHasKeyboard			= int2Bool o get 600
    val getHasMouse			= int2Bool o get 601
    val getHasSpaceball			= int2Bool o get 602
    val getHasDialAndButtonBox		= int2Bool o get 603
    val getHasTablet			= int2Bool o get 604
    val getNumMouseButtons		= get 605
    val getNumSpaceballButtons		= get 606
    val getNumButtonBoxButtons		= get 607
    val getNumDials			= get 608
    val getNumTabletButtons		= get 609
    val getDeviceIgnoreKeyRepeat	= int2Bool o get 610
(* FIXME: the following should return KEY_REPEAT_OFF, KEY_REPEAT_ON,
 * FIXME: KEY_REPEAT_DEFAULT.
    val getDeviceKeyRepeat		= get 611
 *)
    val getHasJoystick			= int2Bool o get 612
    val getOwnsJoystick			= get 613
    val getJoystickButtons		= get 614
    val getJoystickAxes			= get 615
    val getJoystickPollRate		= get 616
    end

  (***** GLUT font sub-API *****)
    type bitmap_font = Ptr.t
    val bitmap9By15 = let
	  val (get, _) = _symbol "GlutFontBitmap9By15" public : (unit -> bitmap_font) * (bitmap_font -> unit);
	  in
	    get()
	  end
    val bitmap8By13 = let
	  val (get, _) = _symbol "GlutFontBitmap8By13" public : (unit -> bitmap_font) * (bitmap_font -> unit);
	  in
	    get()
	  end
    val bitmapTimesRoman10 = let
	  val (get, _) = _symbol "GlutFontBitmapTimesRoman10" public : (unit -> bitmap_font) * (bitmap_font -> unit);
	  in
	    get()
	  end
    val bitmapTimesRoman24 = let
	  val (get, _) = _symbol "GlutFontBitmapTimesRoman24" public : (unit -> bitmap_font) * (bitmap_font -> unit);
	  in
	    get()
	  end
    val bitmapHelvetica10 = let
	  val (get, _) = _symbol "GlutFontBitmapHelvetica10" public : (unit -> bitmap_font) * (bitmap_font -> unit);
	  in
	    get()
	  end
    val bitmapHelvetica12 = let
	  val (get, _) = _symbol "GlutFontBitmapHelvetica12" public : (unit -> bitmap_font) * (bitmap_font -> unit);
	  in
	    get()
	  end
    val bitmapHelvetica18 = let
	  val (get, _) = _symbol "GlutFontBitmapHelvetica18" public : (unit -> bitmap_font) * (bitmap_font -> unit);
	  in
	    get()
	  end

    type stroke_font = Ptr.t
    val strokeRoman = let
	  val (get, _) = _symbol "GlutFontStrokeRoman" public : (unit -> stroke_font) * (stroke_font -> unit);
	  in
	    get()
	  end
    val strokeMonoRoman = let
	  val (get, _) = _symbol "GlutFontStrokeMonoRoman" public : (unit -> stroke_font) * (stroke_font -> unit);
	  in
	    get()
	  end

    val bitmapCharacter = _import "glutBitmapCharacter" stdcall : bitmap_font * int -> unit;
    val bitmapWidth = _import "glutBitmapWidth" stdcall : bitmap_font * int -> int;
    val strokeCharacter = _import "glutStrokeCharacter" stdcall : stroke_font * int -> unit;
    val strokeWidth = _import "glutStrokeWidth" stdcall : stroke_font * int -> int;
  (* the following require GLUT_API_VERSION >= 4 *)
    fun bitmapLength (font, s) = let
	  val glutBitmapLength = _import "glutBitmapLength" stdcall
		: bitmap_font * string -> int;
	  in
	    glutBitmapLength (font, cString s)
	  end
    fun strokeLength (font, s) = let
	  val glutStrokeLength = _import "glutStrokeLength" stdcall
		: bitmap_font * string -> int;
	  in
	    glutStrokeLength (font, cString s)
	  end

  (***** Prebuilt models *****)
    val wireSphere = _import "glutWireSphere" stdcall : double * int * int -> unit;
    val solidSphere = _import "glutSolidSphere" stdcall : double * int * int -> unit;
    val wireCone = _import "glutWireCone" stdcall : double * double * int * int -> unit;
    val solidCone = _import "glutSolidCone" stdcall : double * double * int * int -> unit;
    val wireCube = _import "glutWireCube" stdcall : double -> unit;
    val solidCube = _import "glutSolidCube" stdcall : double -> unit;
    val wireTorus = _import "glutWireTorus" stdcall : double * double * int * int -> unit;
    val solidTorus = _import "glutSolidTorus" stdcall : double * double * int * int -> unit;
    val wireDodecahedron = _import "glutWireDodecahedron" stdcall : unit -> unit;
    val solidDodecahedron = _import "glutSolidDodecahedron" stdcall : unit -> unit;
    val wireTeapot = _import "glutWireTeapot" stdcall : double -> unit;
    val solidTeapot = _import "glutSolidTeapot" stdcall : double -> unit;
    val wireOctahedron = _import "glutWireOctahedron" stdcall : unit -> unit;
    val solidOctahedron = _import "glutSolidOctahedron" stdcall : unit -> unit;
    val wireTetrahedron = _import "glutWireTetrahedron" stdcall : unit -> unit;
    val solidTetrahedron = _import "glutSolidTetrahedron" stdcall : unit -> unit;
    val wireIcosahedron = _import "glutWireIcosahedron" stdcall : unit -> unit;
    val solidIcosahedron = _import "glutSolidIcosahedron" stdcall : unit -> unit;

  end

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