Fix corner case
[llpp.git] / lablGL / glTex.ml
blobf18abb9bb7084bc168b4f43a89cee543633ec773
1 (* $Id: glTex.ml,v 1.14 2012-03-06 03:31:02 garrigue Exp $ *)
3 open Gl
4 open GlPix
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"
12 (*external multi_coord2 : *)
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
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
37 external gen : coord:coord -> gen_param -> unit = "ml_glTexGen"
39 let npot = ref None
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)
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
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
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
103 external parameter : target:[`texture_1d|`texture_2d] -> parameter -> unit
104 = "ml_glTexParameter"
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;
116 let gen_texture () = (gen_textures ~len:1).(0)
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