lablGL/gl.ml

   1 (* $Id: gl.ml,v 1.31 2012-03-06 03:31:02 garrigue Exp $ *)
   2
   3 (* Register an exception *)
   4
   5 exception GLerror of string
   6
   7 let _ = Callback.register_exception "glerror" (GLerror "")
   8
   9 (* Types common to all modules *)
  10
  11 type rgb = float * float * float
  12 type rgba = float * float * float * float
  13
  14 type point2 = float * float
  15 type point3 = float * float * float
  16 type point4 = float * float * float * float
  17 type vect3 = float * float *float
  18
  19 type clampf = float
  20 type short = int
  21 type kind = [`bitmap|`byte|`float|`int|`short|`ubyte|`uint|`ushort]
  22 type real_kind = [`byte|`float|`int|`short|`ubyte|`uint|`ushort]
  23
  24 type format =
  25   [`alpha|`bgr|`bgra|`blue|`color_index|`depth_component|`green|`luminance
  26   |`luminance_alpha|`red|`rgb|`rgba|`stencil_index]
  27 let format_size (#format as f) =
  28   match f with
  29     `rgba | `bgra -> 4
  30   | `rgb | `bgr -> 3
  31   | `luminance_alpha -> 2
  32   | _ -> 1
  33
  34 type target =
  35   [`color_4|`index|`normal|`texture_coord_1|`texture_coord_2|`texture_coord_3
  36   |`texture_coord_4|`trim_2|`trim_3|`vertex_3|`vertex_4]
  37 let target_size = function
  38     `index|`normal|`texture_coord_1 -> 1
  39   | `texture_coord_2|`trim_2 -> 2
  40   | `vertex_3|`texture_coord_3|`trim_3 -> 3
  41   | `vertex_4|`color_4|`texture_coord_4 -> 4
  42
  43 type cmp_func =
  44   [`always|`equal|`gequal|`greater|`lequal|`less|`never|`notequal]
  45 type face = [`back|`both|`front]
  46
  47 (* Basic functions *)
  48
  49 external flush : unit -> unit = "ml_glFlush"
  50 external finish : unit -> unit = "ml_glFinish"
  51
  52 type cap =
  53   [`alpha_test|`auto_normal|`blend|`clip_plane0|`clip_plane1|`clip_plane2
  54   |`clip_plane3|`clip_plane4|`clip_plane5|`color_material|`cull_face
  55   |`depth_test|`dither|`fog|`light0|`light1|`light2|`light3|`light4|`light5
  56   |`light6|`light7|`lighting|`line_smooth|`line_stipple
  57   |`index_logic_op |`color_logic_op
  58   |`map1_color_4|`map1_index|`map1_normal|`map1_texture_coord_1
  59   |`map1_texture_coord_2|`map1_texture_coord_3|`map1_texture_coord_4
  60   |`map1_vertex_3|`map1_vertex_4|`map2_color_4|`map2_index|`map2_normal
  61   |`map2_texture_coord_1|`map2_texture_coord_2|`map2_texture_coord_3
  62   |`map2_texture_coord_4|`map2_vertex_3|`map2_vertex_4|`normalize|`point_smooth
  63   |`polygon_offset_fill|`polygon_offset_line|`polygon_offset_point
  64   |`polygon_smooth|`polygon_stipple|`scissor_test|`stencil_test|`texture_1d
  65   |`texture_2d|`texture_gen_q|`texture_gen_r|`texture_gen_s|`texture_gen_t]
  66
  67 external enable : cap -> unit = "ml_glEnable"
  68 external disable : cap -> unit = "ml_glDisable"
  69 external is_enabled : cap -> bool = "ml_glIsEnabled"
  70
  71 type error =
  72   [`no_error|`invalid_enum|`invalid_value|`invalid_operation
  73   |`stack_overflow|`stack_underflow|`out_of_memory|`table_too_large]
  74 external get_error : unit -> error = "ml_glGetError"
  75 let raise_error name =
  76   let err = get_error () in
  77   if err = `no_error then () else
  78   let s =
  79     List.assoc err
  80       [ `invalid_enum, "Invalid Enum";
  81         `invalid_value, "Invalid Value";
  82         `invalid_operation, "Invalid Operation";
  83         `stack_overflow, "Stack Overflow";
  84         `stack_underflow, "Stack Underflow";
  85         `out_of_memory, "Out of Memory";
  86         `table_too_large, "Table Too Large" ]
  87   in
  88   let s = if name = "" then s else (name ^ ": " ^ s) in
  89   raise (GLerror s)