lablGL/glTex.ml

   1 (* $Id: glTex.ml,v 1.14 2012-03-06 03:31:02 garrigue Exp $ *)
   2
   3 open Gl
   4 open GlPix
   5
   6 external coord1 : float -> unit = "ml_glTexCoord1d"
   7 external coord2 : float -> float -> unit = "ml_glTexCoord2d"
   8 external coord3 : float -> float -> float -> unit = "ml_glTexCoord3d"
   9 external coord4 : float -> float -> float -> float -> unit
  10     = "ml_glTexCoord4d"
  11
  12 (*external multi_coord2 : *)
  13
  14 let default x = function Some x -> x | None -> x
  15 let coord ~s ?t ?r ?q () =
  16   match q with
  17     Some q -> coord4 s (default 0.0 t) (default 0.0 r) q
  18   | None -> match r with
  19       Some r -> coord3 s (default 0.0 t) r
  20     | None -> match t with
  21         Some t -> coord2 s t
  22       | None -> coord1 s
  23 let coord2 (s,t) = coord2 s t
  24 let coord3 (s,t,r) = coord3 s t r
  25 let coord4 (s,t,r,q) = coord4 s t r q
  26 type env_param = [
  27     `mode of [`modulate|`decal|`blend|`replace]
  28   | `color of rgba
  29 ]
  30 external env : env_param -> unit = "ml_glTexEnv"
  31 type coord = [`s|`t|`r|`q]
  32 type gen_param = [
  33     `mode of [`object_linear|`eye_linear|`sphere_map]
  34   | `object_plane of point4
  35   | `eye_plane of point4
  36 ]
  37 external gen : coord:coord -> gen_param -> unit = "ml_glTexGen"
  38
  39 let npot = ref None
  40
  41 let check_pow2 n =
  42   if !npot = None then
  43     npot := Some (GlMisc.check_extension "GL_ARB_texture_non_power_of_two");
  44   (!npot = Some true) || (n land (n - 1) = 0)
  45
  46 type format = [
  47     `color_index
  48   | `red
  49   | `green
  50   | `blue
  51   | `alpha
  52   | `rgb
  53   | `bgr
  54   | `rgba
  55   | `bgra
  56   | `luminance
  57   | `luminance_alpha
  58 ]
  59
  60 external image1d :
  61     proxy:bool -> level:int -> internal:int ->
  62     width:int -> border:int -> format:[< format] -> [< kind] Raw.t -> unit
  63     = "ml_glTexImage1D_bc""ml_glTexImage1D"
  64 let image1d ?(proxy=false) ?(level=0) ?internal:i ?(border=false) img =
  65   let internal = match i with None -> format_size (format img) | Some i -> i in
  66   let border = if border then 1 else 0 in
  67   if not (check_pow2 (width img - 2 * border)) then
  68     raise (GLerror "Gl.image1d : bad width");
  69   if height img < 1 then raise (GLerror "Gl.image1d : bad height");
  70   image1d ~proxy ~level ~internal ~width:(width img) ~border
  71     ~format:(format img) (to_raw img)
  72 external image2d :
  73     proxy:bool -> level:int -> internal:int -> width:int ->
  74     height:int -> border:int -> format:[< format] -> [< kind] Raw.t -> unit
  75     = "ml_glTexImage2D_bc""ml_glTexImage2D"
  76 let image2d ?(proxy=false) ?(level=0) ?internal:i ?(border=false) img =
  77   let internal = match i with None -> format_size (format img) | Some i -> i in
  78   let border = if border then 1 else 0 in
  79   if not (check_pow2 (width img - 2 * border)) then
  80     raise (GLerror "Gl.image2d : bad width");
  81   if not (check_pow2 (height img - 2 * border)) then
  82     raise (GLerror "Gl.image2d : bad height");
  83   image2d ~proxy ~level ~internal ~border
  84     ~width:(width img) ~height:(height img) ~format:(format img) (to_raw img)
  85 type filter = [
  86     `nearest
  87   | `linear
  88   | `nearest_mipmap_nearest
  89   | `linear_mipmap_nearest
  90   | `nearest_mipmap_linear
  91   | `linear_mipmap_linear
  92 ]
  93 type wrap = [`clamp|`repeat]
  94 type parameter = [
  95     `min_filter of filter
  96   | `mag_filter of [`nearest|`linear]
  97   | `wrap_s of wrap
  98   | `wrap_t of wrap
  99   | `border_color of rgba
 100   | `priority of clampf
 101   | `generate_mipmap of bool
 102 ]
 103 external parameter : target:[`texture_1d|`texture_2d] -> parameter -> unit
 104     = "ml_glTexParameter"
 105
 106 type texture_id = nativeint
 107 external _gen_textures : int -> [`uint] Raw.t -> unit = "ml_glGenTextures"
 108 let gen_textures ~len =
 109   let raw = Raw.create `uint ~len in
 110   _gen_textures len raw;
 111   let arr = Array.make len Nativeint.zero in
 112   for i = 0 to len - 1 do
 113     arr.(i) <- Raw.get_long raw ~pos:i
 114   done;
 115   arr
 116 let gen_texture () =  (gen_textures 1).(0)
 117
 118 external bind_texture : target:[`texture_1d|`texture_2d] -> texture_id -> unit
 119     = "ml_glBindTexture"
 120 external delete_texture : texture_id -> unit = "ml_glDeleteTexture"
 121 let delete_textures a = Array.iter (fun id -> delete_texture id) a