open GL ;;

module Gl = struct
  let enable cap =
    let cap = match cap with
    |`alpha_test           -> GL_ALPHA_TEST
    |`auto_normal          -> GL_AUTO_NORMAL
    |`blend                -> GL_BLEND
    |`clip_plane0          -> GL_CLIP_PLANE0
    |`clip_plane1          -> GL_CLIP_PLANE1
    |`clip_plane2          -> GL_CLIP_PLANE2
    |`clip_plane3          -> GL_CLIP_PLANE3
    |`clip_plane4          -> GL_CLIP_PLANE4
    |`clip_plane5          -> GL_CLIP_PLANE5
    |`color_material       -> GL_COLOR_MATERIAL
    |`cull_face            -> GL_CULL_FACE
    |`depth_test           -> GL_DEPTH_TEST
    |`dither               -> GL_DITHER
    |`fog                  -> GL_FOG
    |`light0               -> GL_LIGHT0
    |`light1               -> GL_LIGHT1
    |`light2               -> GL_LIGHT2
    |`light3               -> GL_LIGHT3
    |`light4               -> GL_LIGHT4
    |`light5               -> GL_LIGHT5
    |`light6               -> GL_LIGHT6
    |`light7               -> GL_LIGHT7
    |`lighting             -> GL_LIGHTING
    |`line_smooth          -> GL_LINE_SMOOTH
    |`line_stipple         -> GL_LINE_STIPPLE
    |`index_logic_op       -> GL_INDEX_LOGIC_OP
    |`color_logic_op       -> GL_COLOR_LOGIC_OP
    |`map1_color_4         -> GL_MAP1_COLOR_4
    |`map1_index           -> GL_MAP1_INDEX
    |`map1_normal          -> GL_MAP1_NORMAL
    |`map1_texture_coord_1 -> GL_MAP1_TEXTURE_COORD_1
    |`map1_texture_coord_2 -> GL_MAP1_TEXTURE_COORD_2
    |`map1_texture_coord_3 -> GL_MAP1_TEXTURE_COORD_3
    |`map1_texture_coord_4 -> GL_MAP1_TEXTURE_COORD_4
    |`map1_vertex_3        -> GL_MAP1_VERTEX_3
    |`map1_vertex_4        -> GL_MAP1_VERTEX_4
    |`map2_color_4         -> GL_MAP2_COLOR_4
    |`map2_index           -> GL_MAP2_INDEX
    |`map2_normal          -> GL_MAP2_NORMAL
    |`map2_texture_coord_1 -> GL_MAP2_TEXTURE_COORD_1
    |`map2_texture_coord_2 -> GL_MAP2_TEXTURE_COORD_2
    |`map2_texture_coord_3 -> GL_MAP2_TEXTURE_COORD_3
    |`map2_texture_coord_4 -> GL_MAP2_TEXTURE_COORD_4
    |`map2_vertex_3        -> GL_MAP2_VERTEX_3
    |`map2_vertex_4        -> GL_MAP2_VERTEX_4
    |`normalize            -> GL_NORMALIZE
    |`point_smooth         -> GL_POINT_SMOOTH
    |`polygon_smooth       -> GL_POLYGON_SMOOTH
    |`polygon_stipple      -> GL_POLYGON_STIPPLE
    |`scissor_test         -> GL_SCISSOR_TEST
    |`stencil_test         -> GL_STENCIL_TEST
    |`texture_1d           -> GL_TEXTURE_1D
    |`texture_2d           -> GL_TEXTURE_2D
                        (* -> GL_TEXTURE_3D *)
    |`texture_gen_q        -> GL_TEXTURE_GEN_Q
    |`texture_gen_r        -> GL_TEXTURE_GEN_R
    |`texture_gen_s        -> GL_TEXTURE_GEN_S
    |`texture_gen_t        -> GL_TEXTURE_GEN_T
                        (*
                           -> GL_COLOR_TABLE
                           -> GL_CONVOLUTION_1D
                           -> GL_CONVOLUTION_2D
                           -> GL_HISTOGRAM
                           -> GL_MINMAX
                           -> GL_POLYGON_OFFSET_FILL
                           -> GL_POLYGON_OFFSET_LINE
                           -> GL_POLYGON_OFFSET_POINT
                           -> GL_POST_COLOR_MATRIX_COLOR_TABLE
                           -> GL_POST_CONVOLUTION_COLOR_TABLE
                           -> GL_RESCALE_NORMAL
                           -> GL_SEPARABLE_2D
                        *)
    in
    glEnable ~cap ;;

  let disable cap =
    let cap = match cap with
    |`alpha_test           -> GL_ALPHA_TEST
    |`auto_normal          -> GL_AUTO_NORMAL
    |`blend                -> GL_BLEND
    |`clip_plane0          -> GL_CLIP_PLANE0
    |`clip_plane1          -> GL_CLIP_PLANE1
    |`clip_plane2          -> GL_CLIP_PLANE2
    |`clip_plane3          -> GL_CLIP_PLANE3
    |`clip_plane4          -> GL_CLIP_PLANE4
    |`clip_plane5          -> GL_CLIP_PLANE5
    |`color_material       -> GL_COLOR_MATERIAL
    |`cull_face            -> GL_CULL_FACE
    |`depth_test           -> GL_DEPTH_TEST
    |`dither               -> GL_DITHER
    |`fog                  -> GL_FOG
    |`light0               -> GL_LIGHT0
    |`light1               -> GL_LIGHT1
    |`light2               -> GL_LIGHT2
    |`light3               -> GL_LIGHT3
    |`light4               -> GL_LIGHT4
    |`light5               -> GL_LIGHT5
    |`light6               -> GL_LIGHT6
    |`light7               -> GL_LIGHT7
    |`lighting             -> GL_LIGHTING
    |`line_smooth          -> GL_LINE_SMOOTH
    |`line_stipple         -> GL_LINE_STIPPLE
    |`index_logic_op       -> GL_INDEX_LOGIC_OP
    |`color_logic_op       -> GL_COLOR_LOGIC_OP
    |`map1_color_4         -> GL_MAP1_COLOR_4
    |`map1_index           -> GL_MAP1_INDEX
    |`map1_normal          -> GL_MAP1_NORMAL
    |`map1_texture_coord_1 -> GL_MAP1_TEXTURE_COORD_1
    |`map1_texture_coord_2 -> GL_MAP1_TEXTURE_COORD_2
    |`map1_texture_coord_3 -> GL_MAP1_TEXTURE_COORD_3
    |`map1_texture_coord_4 -> GL_MAP1_TEXTURE_COORD_4
    |`map1_vertex_3        -> GL_MAP1_VERTEX_3
    |`map1_vertex_4        -> GL_MAP1_VERTEX_4
    |`map2_color_4         -> GL_MAP2_COLOR_4
    |`map2_index           -> GL_MAP2_INDEX
    |`map2_normal          -> GL_MAP2_NORMAL
    |`map2_texture_coord_1 -> GL_MAP2_TEXTURE_COORD_1
    |`map2_texture_coord_2 -> GL_MAP2_TEXTURE_COORD_2
    |`map2_texture_coord_3 -> GL_MAP2_TEXTURE_COORD_3
    |`map2_texture_coord_4 -> GL_MAP2_TEXTURE_COORD_4
    |`map2_vertex_3        -> GL_MAP2_VERTEX_3
    |`map2_vertex_4        -> GL_MAP2_VERTEX_4
    |`normalize            -> GL_NORMALIZE
    |`point_smooth         -> GL_POINT_SMOOTH
    |`polygon_smooth       -> GL_POLYGON_SMOOTH
    |`polygon_stipple      -> GL_POLYGON_STIPPLE
    |`scissor_test         -> GL_SCISSOR_TEST
    |`stencil_test         -> GL_STENCIL_TEST
    |`texture_1d           -> GL_TEXTURE_1D
    |`texture_2d           -> GL_TEXTURE_2D
                        (* -> GL_TEXTURE_3D *)
    |`texture_gen_q        -> GL_TEXTURE_GEN_Q
    |`texture_gen_r        -> GL_TEXTURE_GEN_R
    |`texture_gen_s        -> GL_TEXTURE_GEN_S
    |`texture_gen_t        -> GL_TEXTURE_GEN_T
                        (*
                           -> GL_COLOR_TABLE
                           -> GL_CONVOLUTION_1D
                           -> GL_CONVOLUTION_2D
                           -> GL_HISTOGRAM
                           -> GL_MINMAX
                           -> GL_POLYGON_OFFSET_FILL
                           -> GL_POLYGON_OFFSET_LINE
                           -> GL_POLYGON_OFFSET_POINT
                           -> GL_POST_COLOR_MATRIX_COLOR_TABLE
                           -> GL_POST_CONVOLUTION_COLOR_TABLE
                           -> GL_RESCALE_NORMAL
                           -> GL_SEPARABLE_2D
                        *)
    in
    glDisable ~cap ;;

  let flush = glFlush ;;
  let finish = glFinish ;;

end


module GlDraw = struct
  let viewport ~x ~y ~w ~h = glViewport ~x ~y ~width:w ~height:h ;;
  let shade_model = function
    | `flat ->   glShadeModel GL_FLAT
    | `smooth -> glShadeModel GL_SMOOTH ;;
  let color ?(alpha=1.) (r, g, b) = glColor4 ~r ~g ~b ~a:alpha ;;

  let normal ?(x=0.) ?(y=0.) ?(z=0.) () = glNormal3 ~nx:x ~ny:y ~nz:z ;;
  let normal3 v = glNormal3v ~v ;;

  let point_size size = glPointSize ~size ;;
  let line_width width = glLineWidth ~width ;;

  type shape =
    [`line_loop|`line_strip|`lines|`points|`polygon|`quad_strip|`quads
    |`triangle_fan|`triangle_strip|`triangles]

  let begins shape =
    glBegin ~primitive:(match shape with
    | `points         -> GL_POINTS
    | `lines          -> GL_LINES
    | `polygon        -> GL_POLYGON
    | `triangles      -> GL_TRIANGLES
    | `quads          -> GL_QUADS
    | `line_strip     -> GL_LINE_STRIP
    | `line_loop      -> GL_LINE_LOOP
    | `triangle_strip -> GL_TRIANGLE_STRIP
    | `triangle_fan   -> GL_TRIANGLE_FAN
    | `quad_strip     -> GL_QUAD_STRIP) ;;

  let ends = glEnd ;;
  let index = glIndex ;;

  let vertex ~x ~y ?(z=0.) ?(w=1.) () = glVertex4 ~x ~y ~z ~w ;;
  let vertex2 v = glVertex2v ~v ;;
  let vertex3 v = glVertex3v ~v ;;
  let vertex4 v = glVertex4v ~v ;;

  let polygon_mode ~face mode =
    let mode = match mode with
    | `fill  -> GL_FILL
    | `line  -> GL_LINE
    | `point -> GL_POINT
    in
    let face = match face with
    | `front -> GL_FRONT
    | `both  -> GL_BACK
    | `back  -> GL_FRONT_AND_BACK
    in
    glPolygonMode ~face ~mode ;;

  let cull_face face =
    let mode = match face with
    | `front -> GL_FRONT
    | `both  -> GL_BACK
    | `back  -> GL_FRONT_AND_BACK
    in
    glCullFace ~mode ;;

  let front_face orient =
    glFrontFace ~orientation:(match orient with `ccw -> GL_CCW | `cw -> GL_CW) ;;

  let rect (x1,y1) (x2,y2) = glRect ~x1 ~y1 ~x2 ~y2 ;;

  let edge_flag flag = glEdgeFlag ~flag ;;

  let line_stipple ?(factor=1) pattern = glLineStipple ~factor ~pattern ;;

  let polygon_offset ~factor ~units = glPolygonOffset ~factor ~units ;;

(* TODO
val polygon_stipple : GlPix.bitmap -> unit
*)
end


module GlClear = struct
  let color ?(alpha=1.) (r, g, b) = glClearColor ~r ~g ~b ~a:alpha ;;
  let index c = glClearIndex c ;;
  let depth depth = glClearDepth ~depth ;;
  let clear buf =
    let rec aux acc = function
      | `color   :: buf -> aux (GL_COLOR_BUFFER_BIT  ::acc) buf
      | `depth   :: buf -> aux (GL_DEPTH_BUFFER_BIT  ::acc) buf
      | `accum   :: buf -> aux (GL_ACCUM_BUFFER_BIT  ::acc) buf
      | `stencil :: buf -> aux (GL_STENCIL_BUFFER_BIT::acc) buf
      | [] -> acc
    in
    glClear ~mask:(aux [] buf)
  ;;

  let stencil s = glClearStencil ~s ;;
  let accum ?(alpha=1.) (r, g, b) = glClearAccum r g b alpha ;;
end
(* complete with 1.03 *)


module GlFunc = struct

  let depth_func cmp_func =
    let func = match cmp_func with
    | `always   -> GL_ALWAYS
    | `equal    -> GL_EQUAL
    | `gequal   -> GL_GEQUAL
    | `greater  -> GL_GREATER
    | `lequal   -> GL_LEQUAL
    | `less     -> GL_LESS
    | `never    -> GL_NEVER
    | `notequal -> GL_NOTEQUAL
    in
    glDepthFunc ~func ;;

  let alpha_func cmp_func ~ref =
    let func = match cmp_func with
    | `always   -> GL_ALWAYS
    | `equal    -> GL_EQUAL
    | `gequal   -> GL_GEQUAL
    | `greater  -> GL_GREATER
    | `lequal   -> GL_LEQUAL
    | `less     -> GL_LESS
    | `never    -> GL_NEVER
    | `notequal -> GL_NOTEQUAL
    in
    glAlphaFunc ~func ~ref ;;

  let stencil_func cmp_func ~ref ~mask =
    let func = match cmp_func with
    | `always   -> GL_ALWAYS
    | `equal    -> GL_EQUAL
    | `gequal   -> GL_GEQUAL
    | `greater  -> GL_GREATER
    | `lequal   -> GL_LEQUAL
    | `less     -> GL_LESS
    | `never    -> GL_NEVER
    | `notequal -> GL_NOTEQUAL
    in
    glStencilFunc ~func ~ref ~mask ;;

  let blend_func ~src ~dst =
    glBlendFunc
      ~sfactor:(match src with
          | `zero                -> Sfactor.GL_ZERO
          | `one                 -> Sfactor.GL_ONE
          | `dst_color           -> Sfactor.GL_DST_COLOR
          | `one_minus_dst_color -> Sfactor.GL_ONE_MINUS_DST_COLOR
          | `src_alpha           -> Sfactor.GL_SRC_ALPHA
          | `one_minus_src_alpha -> Sfactor.GL_ONE_MINUS_SRC_ALPHA
          | `dst_alpha           -> Sfactor.GL_DST_ALPHA
          | `one_minus_dst_alpha -> Sfactor.GL_ONE_MINUS_DST_ALPHA
          | `src_alpha_saturate  -> Sfactor.GL_SRC_ALPHA_SATURATE)
      ~dfactor:(match dst with
          | `zero                -> Dfactor.GL_ZERO
          | `one                 -> Dfactor.GL_ONE
          | `src_color           -> Dfactor.GL_SRC_COLOR
          | `one_minus_src_color -> Dfactor.GL_ONE_MINUS_SRC_COLOR
          | `src_alpha           -> Dfactor.GL_SRC_ALPHA
          | `one_minus_src_alpha -> Dfactor.GL_ONE_MINUS_SRC_ALPHA
          | `dst_alpha           -> Dfactor.GL_DST_ALPHA
          | `one_minus_dst_alpha -> Dfactor.GL_ONE_MINUS_DST_ALPHA) ;;
end


module GlMat = struct
  let load_identity () = glLoadIdentity () ;;
  let mode = function
    | `modelview  -> glMatrixMode ~mode:GL_MODELVIEW
    | `projection -> glMatrixMode ~mode:GL_PROJECTION
    | `texture    -> glMatrixMode ~mode:GL_TEXTURE
 (* | `color      -> glMatrixMode ~mode:GL_COLOR *)
  ;;

  let mult mat = glMultMatrix ~mat ;;
  let of_array m = m ;;

  let pop () = glPopMatrix() ;;
  let push () = glPushMatrix() ;;

  let translate3 (x,y,z) = glTranslate ~x ~y ~z ;;
  let translate ?(x=0.) ?(y=0.) ?(z=0.) () = glTranslate ~x ~y ~z ;;

  let scale3 (x,y,z) = glScale ~x ~y ~z ;;
  let scale ?(x=0.) ?(y=0.) ?(z=0.) () = glScale ~x ~y ~z ;;

  let rotate3 ~angle (x,y,z) = glRotate ~angle ~x ~y ~z ;;
  let rotate ~angle ?(x=0.) ?(y=0.) ?(z=0.) () = glRotate ~angle ~x ~y ~z ;;

  let ortho ~x:(left, right) ~y:(bottom, top) ~z:(near_val, far_val) =
    glOrtho ~left ~right ~bottom ~top ~near_val ~far_val ;;

  let frustum ~x:(left, right) ~y:(bottom, top) ~z:(near, far) =
    glFrustum ~left ~right ~bottom ~top ~near ~far ;;

  let get_matrix m =
    let m_type = match m with
    | `modelview_matrix  -> Get.GL_MODELVIEW_MATRIX
    | `projection_matrix -> Get.GL_PROJECTION_MATRIX
    | `texture_matrix    -> Get.GL_TEXTURE_MATRIX
                         (*
                         -> Get.GL_COLOR_MATRIX
                         -> Get.GL_TRANSPOSE_COLOR_MATRIX
                         -> Get.GL_TRANSPOSE_MODELVIEW_MATRIX
                         -> Get.GL_TRANSPOSE_PROJECTION_MATRIX
                         -> Get.GL_TRANSPOSE_TEXTURE_MATRIX
                         *)
    in
    glGetMatrix m_type ;;
end


module GlLight = struct

  let color_material ~face color_material =
    let mode = match color_material with
    | `emission -> GL_EMISSION
    | `ambient ->  GL_AMBIENT
    | `diffuse ->  GL_DIFFUSE
    | `specular -> GL_SPECULAR
    | `ambient_and_diffuse -> GL_AMBIENT_AND_DIFFUSE
    in
    let face = match face with
    | `front -> GL_FRONT
    | `both  -> GL_BACK
    | `back  -> GL_FRONT_AND_BACK
    in
    glColorMaterial ~face ~mode ;;


  let fog fog_param =
    let p = match fog_param with
    | `mode `linear -> GL_FOG_MODE  GL_LINEAR
    | `mode `exp    -> GL_FOG_MODE  GL_EXP
    | `mode `exp2   -> GL_FOG_MODE  GL_EXP2
    | `density p -> GL_FOG_DENSITY p
    | `start p   -> GL_FOG_START p
    | `End p     -> GL_FOG_END p
    | `index p   -> GL_FOG_INDEX p
    | `color rgba  -> GL_FOG_COLOR rgba
                (* -> GL_FOG_COORD_SRC  GL_FOG_COORD      *)
                (* -> GL_FOG_COORD_SRC  GL_FRAGMENT_DEPTH *)
    in
    glFog p ;;


  let light ~num light_param =
    let p = match light_param with
    | `ambient (r,g,b,a)  -> Light.GL_AMBIENT (r,g,b,a)
    | `diffuse (r,g,b,a)  -> Light.GL_DIFFUSE (r,g,b,a)
    | `specular (r,g,b,a) -> Light.GL_SPECULAR (r,g,b,a)
    | `position point4    -> Light.GL_POSITION point4
    | `spot_direction point3   -> Light.GL_SPOT_DIRECTION point3
    | `spot_exponent p         -> Light.GL_SPOT_EXPONENT p
    | `spot_cutoff p           -> Light.GL_SPOT_CUTOFF p
    | `constant_attenuation p  -> Light.GL_CONSTANT_ATTENUATION p
    | `linear_attenuation p    -> Light.GL_LINEAR_ATTENUATION p
    | `quadratic_attenuation p -> Light.GL_QUADRATIC_ATTENUATION p
    in
    glLight (GL_LIGHT num) p ;;


  let light_model p =
    let light_model = match p with
    | `ambient (r,g,b,a) -> GL_LIGHT_MODEL_AMBIENT (r,g,b,a)
    | `local_viewer p -> GL_LIGHT_MODEL_LOCAL_VIEWER p
    | `two_side p     -> GL_LIGHT_MODEL_TWO_SIDE p
    | `color_control `separate_specular_color -> GL_LIGHT_MODEL_COLOR_CONTROL  GL_SEPARATE_SPECULAR_COLOR
    | `color_control `single_color ->            GL_LIGHT_MODEL_COLOR_CONTROL  GL_SINGLE_COLOR
    in
    glLightModel ~light_model ;;


  let material ~face material_param =
    let mode = match material_param with
    | `ambient (r,g,b,a)    -> Material.GL_AMBIENT (r,g,b,a)
    | `diffuse (r,g,b,a)    -> Material.GL_DIFFUSE (r,g,b,a)
    | `specular (r,g,b,a)   -> Material.GL_SPECULAR (r,g,b,a)
    | `emission (r,g,b,a)   -> Material.GL_EMISSION (r,g,b,a)
    | `shininess (spec_exp) -> Material.GL_SHININESS (spec_exp)
    | `ambient_and_diffuse (r,g,b,a) -> Material.GL_AMBIENT_AND_DIFFUSE (r,g,b,a)
    | `color_indexes (ambient, diffuse, specular) -> Material.GL_COLOR_INDEXES (ambient, diffuse, specular)
    in
    let face = match face with
    | `front -> GL_FRONT
    | `both  -> GL_BACK
    | `back  -> GL_FRONT_AND_BACK
    in
    glMaterial ~face ~mode ;;
end


module GlList = struct

  let is_list l = glIsList l ;;

  let gen_lists ~len = glGenLists ~range:len ;;

  let delete_lists base ~len =
    glDeleteLists ~gl_list:base ~range:len ;;

  let begins l ~mode =
    glNewList ~gl_list:l ~mode:(match mode with
      | `compile -> GL_COMPILE
      | `compile_and_execute -> GL_COMPILE_AND_EXECUTE) ;;

  let ends = glEndList ;;

  let call l = glCallList ~gl_list:l ;;

  let call_lists lists =
    let gl_lists = match lists with
    | `int list_array -> list_array
    | `byte str ->
        let len = String.length str in
        Array.init (pred len) (fun i -> int_of_char str.[i])
    in
    glCallLists ~gl_lists ;;

  let list_base base = glListBase ~base ;;

  let nth base ~pos = base + pos ;;

  let create mode =
    let l = glGenLists ~range:1 in begins l ~mode; l ;;

  let delete l = delete_lists l ~len:1 ;;

  let call_lists ?base lists =
    begin match base with None -> ()
    | Some base -> list_base base
    end;
    call_lists lists ;;
end


module GlMisc = struct

  let hint hint_target hint_mode =
    let target = match hint_target with
    | `fog                    -> GL_FOG_HINT
    | `line_smooth            -> GL_LINE_SMOOTH_HINT
    | `perspective_correction -> GL_PERSPECTIVE_CORRECTION_HINT
    | `point_smooth           -> GL_POINT_SMOOTH_HINT
    | `polygon_smooth         -> GL_POLYGON_SMOOTH_HINT
    in
    let mode = match hint_mode with
    | `fastest   -> GL_FASTEST
    | `nicest    -> GL_NICEST
    | `dont_care -> GL_DONT_CARE
    in
    glHint ~target ~mode ;;

  let push_attrib attrib =
    let attrib = List.map (function
    | `accum_buffer    -> Attrib.GL_ACCUM_BUFFER_BIT
    | `color_buffer    -> Attrib.GL_COLOR_BUFFER_BIT
    | `current         -> Attrib.GL_CURRENT_BIT
    | `depth_buffer    -> Attrib.GL_DEPTH_BUFFER_BIT
    | `enable          -> Attrib.GL_ENABLE_BIT
    | `eval            -> Attrib.GL_EVAL_BIT
    | `fog             -> Attrib.GL_FOG_BIT
    | `hint            -> Attrib.GL_HINT_BIT
    | `lighting        -> Attrib.GL_LIGHTING_BIT
    | `line            -> Attrib.GL_LINE_BIT
    | `list            -> Attrib.GL_LIST_BIT
 (* | `multisample     -> Attrib.GL_MULTISAMPLE_BIT *)
    | `pixel_mode      -> Attrib.GL_PIXEL_MODE_BIT
    | `point           -> Attrib.GL_POINT_BIT
    | `polygon         -> Attrib.GL_POLYGON_BIT
    | `polygon_stipple -> Attrib.GL_POLYGON_STIPPLE_BIT
    | `scissor         -> Attrib.GL_SCISSOR_BIT
    | `stencil_buffer  -> Attrib.GL_STENCIL_BUFFER_BIT
    | `texture         -> Attrib.GL_TEXTURE_BIT
    | `transform       -> Attrib.GL_TRANSFORM_BIT
    | `viewport        -> Attrib.GL_VIEWPORT_BIT) attrib
    in
    glPushAttrib attrib ;;

  let pop_attrib = glPopAttrib ;;
end


module GlMap = struct
  let eval_coord1 u = glEvalCoord1 ~u ;;
  let eval_coord2 u v = glEvalCoord2 ~u ~v ;;

  let grid1 ~n:un ~range:(u1, u2) = glMapGrid1 ~un ~u1 ~u2 ;;
  let grid2 ~n1:un ~range1:(u1, u2)
            ~n2:vn ~range2:(v1, v2) =
    glMapGrid2 ~un ~u1 ~u2 ~vn ~v1 ~v2 ;;

  let eval_mesh1 ~mode ~range:(i1,i2) =
    let mode = match mode with
    | `point -> EvalMesh1.GL_POINT
    | `line  -> EvalMesh1.GL_LINE
    in
    glEvalMesh1 ~mode ~i1 ~i2 ;;

  let eval_mesh2 ~mode ~range1:(i1,i2) ~range2:(j1,j2) =
    let mode = match mode with
    | `point -> EvalMesh2.GL_POINT
    | `line  -> EvalMesh2.GL_LINE
    | `fill  -> EvalMesh2.GL_FILL
    in
    glEvalMesh2 ~mode ~i1 ~i2 ~j1 ~j2 ;;
end


open Glu ;;

module GluMat = struct
  let look_at ~eye:(eyeX, eyeY, eyeZ)
        ~center:(centerX, centerY, centerZ)
        ~up:(upX, upY, upZ) =
    gluLookAt ~eyeX ~eyeY ~eyeZ
        ~centerX ~centerY ~centerZ
        ~upX ~upY ~upZ ;;

  let ortho2d = gluOrtho2D ;;
  let perspective ~fovy ~aspect ~z:(zNear,zFar) = gluPerspective ~fovy ~aspect ~zNear ~zFar ;;
end


module GluQuadric = struct
  let create = gluNewQuadric ;;

  let cylinder ~base ~top ~height ~slices ~stacks ?(quad = create ()) () =
    gluCylinder ~quad ~base ~top ~height ~slices ~stacks ;;

  let disk ~inner ~outer ~slices ~loops ?(quad = create ()) () =
    gluDisk ~quad ~inner ~outer ~slices ~loops ;;

  let partial_disk ~inner ~outer ~slices ~loops ~start ~sweep ?(quad = create ()) () =
    gluPartialDisk ~quad ~inner ~outer ~slices ~loops ~start ~sweep ;;

  let sphere ~radius ~slices ~stacks ?(quad = create ()) () =
    gluSphere ~quad ~radius ~slices ~stacks ;;

  let texture quad b = gluQuadricTexture quad b ;;

  let draw_style quad d =
    let draw_style = match d with
    | `fill       -> GLU_FILL
    | `line       -> GLU_LINE
    | `silhouette -> GLU_SILHOUETTE
    | `point      -> GLU_POINT
    in
    gluQuadricDrawStyle ~quad ~draw_style ;;
 
  let orientation quad o =
    let orientation = match o with
    | `inside  -> GLU_OUTSIDE
    | `outside -> GLU_INSIDE
    in
    gluQuadricOrientation ~quad ~orientation ;;

  let normals quad n =
    let normal = match n with
    | `none   -> GLU_NONE
    | `flat   -> GLU_FLAT
    | `smooth -> GLU_SMOOTH
    in
    gluQuadricNormals ~quad ~normal ;;

end


open Glut ;;

external identity: 'a -> 'b = "%identity"

module Glut = struct
  type button_t =
      | LEFT_BUTTON
      | MIDDLE_BUTTON
      | RIGHT_BUTTON
      | OTHER_BUTTON of int

  type mouse_button_state_t =
      | DOWN
      | UP

  type special_key_t =
      | 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

  let mainLoop = glutMainLoop ;;
  let init = glutInit ;;
  let createWindow = glutCreateWindow ;;
  let initWindowSize ~w ~h = glutInitWindowSize ~width:w ~height:h ;;

  let initDisplayMode
    ?(double_buffer=false)
    ?(index=false)
    ?(accum=false)
    ?(alpha=false)
    ?(depth=false)
    ?(stencil=false)
    ?(multisample=false)
    ?(stereo=false)
    ?(luminance=false)
    () =
    let mode = [] in
    let mode = if double_buffer then GLUT_DOUBLE      :: mode else mode in
    let mode = if index         then GLUT_INDEX       :: mode else mode in
    let mode = if accum         then GLUT_ACCUM       :: mode else mode in
    let mode = if alpha         then GLUT_ALPHA       :: mode else mode in
    let mode = if depth         then GLUT_DEPTH       :: mode else mode in
    let mode = if stencil       then GLUT_STENCIL     :: mode else mode in
    let mode = if multisample   then GLUT_MULTISAMPLE :: mode else mode in
    let mode = if stereo        then GLUT_STEREO      :: mode else mode in
    let mode = if luminance     then GLUT_LUMINANCE   :: mode else mode in
    (* GLUT_RGBA
       GLUT_RGB
       GLUT_SINGLE *)
    glutInitDisplayMode ~mode ;;

  let swapBuffers = glutSwapBuffers ;;
  let postRedisplay = glutPostRedisplay ;;
  let fullScreen = glutFullScreen ;;
  let initWindowPosition = glutInitWindowPosition ;;
  let initWindowSize ~w ~h = glutInitWindowSize ~width:w ~height:h ;;
  let setWindowTitle ~title = glutSetWindowTitle ~name:title ;;

  let displayFunc ~cb = glutDisplayFunc ~display:cb ;;

  let idleFunc ~cb =
    match cb with
    | Some idle -> glutIdleFunc ~idle
    | None -> glutRemoveIdleFunc() ;;

  let keyboardFunc ~cb =
    let keyboard ~key:c ~x ~y = cb ~key:(int_of_char c) ~x ~y in
    glutKeyboardFunc ~keyboard ;;

  let keyboardUpFunc ~cb =
    let keyboard_up ~key:c ~x ~y = cb ~key:(int_of_char c) ~x ~y in
    glutKeyboardUpFunc ~keyboard_up ;;

  let reshapeFunc ~cb =
    let reshape ~width ~height = cb ~w:width ~h:height in
    glutReshapeFunc ~reshape ;;

  let specialFunc ~cb =
    let special ~key ~x ~y =
      let key = match key with
      | GLUT_KEY_F1  -> KEY_F1
      | GLUT_KEY_F2  -> KEY_F2
      | GLUT_KEY_F3  -> KEY_F3
      | GLUT_KEY_F4  -> KEY_F4
      | GLUT_KEY_F5  -> KEY_F5
      | GLUT_KEY_F6  -> KEY_F6
      | GLUT_KEY_F7  -> KEY_F7
      | GLUT_KEY_F8  -> KEY_F8
      | GLUT_KEY_F9  -> KEY_F9
      | GLUT_KEY_F10 -> KEY_F10
      | GLUT_KEY_F11 -> KEY_F11
      | GLUT_KEY_F12 -> KEY_F12
      | GLUT_KEY_LEFT      -> KEY_LEFT
      | GLUT_KEY_UP        -> KEY_UP
      | GLUT_KEY_RIGHT     -> KEY_RIGHT
      | GLUT_KEY_DOWN      -> KEY_DOWN
      | GLUT_KEY_PAGE_UP   -> KEY_PAGE_UP
      | GLUT_KEY_PAGE_DOWN -> KEY_PAGE_DOWN
      | GLUT_KEY_HOME      -> KEY_HOME
      | GLUT_KEY_END       -> KEY_END
      | GLUT_KEY_INSERT    -> KEY_INSERT
      in
      cb ~key ~x ~y
    in
    glutSpecialFunc ~special ;;

  let specialUpFunc ~cb =
    let special_up ~key ~x ~y =
      let key = match key with
      | GLUT_KEY_F1  -> KEY_F1
      | GLUT_KEY_F2  -> KEY_F2
      | GLUT_KEY_F3  -> KEY_F3
      | GLUT_KEY_F4  -> KEY_F4
      | GLUT_KEY_F5  -> KEY_F5
      | GLUT_KEY_F6  -> KEY_F6
      | GLUT_KEY_F7  -> KEY_F7
      | GLUT_KEY_F8  -> KEY_F8
      | GLUT_KEY_F9  -> KEY_F9
      | GLUT_KEY_F10 -> KEY_F10
      | GLUT_KEY_F11 -> KEY_F11
      | GLUT_KEY_F12 -> KEY_F12
      | GLUT_KEY_LEFT      -> KEY_LEFT
      | GLUT_KEY_UP        -> KEY_UP
      | GLUT_KEY_RIGHT     -> KEY_RIGHT
      | GLUT_KEY_DOWN      -> KEY_DOWN
      | GLUT_KEY_PAGE_UP   -> KEY_PAGE_UP
      | GLUT_KEY_PAGE_DOWN -> KEY_PAGE_DOWN
      | GLUT_KEY_HOME      -> KEY_HOME
      | GLUT_KEY_END       -> KEY_END
      | GLUT_KEY_INSERT    -> KEY_INSERT
      in
      cb ~key ~x ~y
    in
    glutSpecialUpFunc ~special_up ;;

  let mouseFunc ~cb =
    let mouse ~button ~state ~x ~y =
      let button = match button with
      | GLUT_LEFT_BUTTON   -> LEFT_BUTTON 
      | GLUT_MIDDLE_BUTTON -> MIDDLE_BUTTON 
      | GLUT_RIGHT_BUTTON  -> RIGHT_BUTTON
      | GLUT_WHEEL_UP      -> OTHER_BUTTON 3
      | GLUT_WHEEL_DOWN    -> OTHER_BUTTON 3
      in
      let state = match state with
      | GLUT_DOWN -> DOWN
      | GLUT_UP   -> UP
      in
      cb ~button ~state ~x ~y
    in
    glutMouseFunc ~mouse ;;

  let timerFunc ~ms ~cb ~value = glutTimerFunc ~msecs:ms ~timer:cb ~value ;;
  let motionFunc ~cb = glutMotionFunc ~motion:cb ;;
  let passiveMotionFunc ~cb = glutPassiveMotionFunc ~passive:cb ;;

  type entry_exit_state_t =
    | LEFT
    | ENTERED

  let entryFunc ~cb =
    let entry ~state =
      cb ~state:(match state with
      | GLUT_LEFT    -> LEFT
      | GLUT_ENTERED -> ENTERED)
    in
    glutEntryFunc ~entry ;;

  type visibility_state_t =
    | NOT_VISIBLE
    | VISIBLE

  let visibilityFunc ~cb =
    let visibility ~state =
      cb ~state:(match state with
      | GLUT_NOT_VISIBLE -> NOT_VISIBLE
      | GLUT_VISIBLE     -> VISIBLE)
    in
    glutVisibilityFunc ~visibility ;;

end


(* vim: sw=2 sts=2 ts=2 et fdm=marker
 *)