tsdl.ml

(*---------------------------------------------------------------------------
   Copyright (c) 2013 Daniel C. Bünzli. All rights reserved.
   Distributed under the BSD3 license, see license at the end of the file.
   %%NAME%% release %%VERSION%%
  ---------------------------------------------------------------------------*)

let unsafe_get = Array.unsafe_get

open Ctypes
open Foreign

module Sdl = struct 
  
(* Enum cases and #ifdef'd constants, see support/ in the distribution *)

open Tsdl_consts

(* Formatting with continuation. *)

let kpp k fmt = 
  let k fmt = k (Format.flush_str_formatter ()) in 
  Format.kfprintf k Format.str_formatter fmt

(* Invalid_argument strings *)

let str = Printf.sprintf 
let err_index i = str "invalid index: %d" i
let err_length_mul l mul = str "invalid length: %d not a multiple of %d" l mul
let err_drop_file = "null file name (drop_file_free already called ?)"
let err_read_field = "cannot read field" 
let err_bigarray_pitch pitch ba_el_size = 
  "invalid bigarray kind: pitch (%d bytes) not a multiple of bigarray element \
   byte size (%d)"

let err_bigarray_data len ba_el_size = 
  "invalid bigarray kind: data (%d bytes) not a multiple of bigarray element \
   byte size (%d)"

(* ctypes views *)

let write_never _ = assert false

let bool = 
  view ~read:((<>)0) ~write:(fun b -> compare b false) int;;

let int_as_uint8_t = 
  view ~read:Unsigned.UInt8.to_int ~write:Unsigned.UInt8.of_int uint8_t

let int_as_uint16_t = 
  view ~read:Unsigned.UInt16.to_int ~write:Unsigned.UInt16.of_int uint16_t

let int_as_uint32_t =
  view ~read:Unsigned.UInt32.to_int ~write:Unsigned.UInt32.of_int uint32_t

let int_as_int32_t = 
  view ~read:Signed.Int32.to_int ~write:Signed.Int32.of_int int32_t

let int32_as_uint32_t = 
  view ~read:Unsigned.UInt32.to_int32 ~write:Unsigned.UInt32.of_int32 uint32_t

let string_as_char_array n = (* FIXME: drop this if ctypes proposes better *)
  let n_array = array n char in
  let read a =
    let len = Array.length a in
    let b = Buffer.create len in 
    try 
      for i = 0 to len - 1 do 
        let c = Array.get a i in 
        if c = '\000' then raise Exit else Buffer.add_char b c
      done;
      Buffer.contents b
    with Exit -> Buffer.contents b
  in
  let write s = 
    let a = Array.make char n in 
    let len = min (Array.length a) (String.length s) in
    for i = 0 to len - 1 do Array.set a i (s.[i]) done;
    a
  in
  view ~read ~write n_array

let get_error = 
  foreign "SDL_GetError" (void @-> returning string)

let error () = `Error (get_error ())
  
let zero_to_ok = 
  let read = function 0 -> `Ok () | err -> error () in 
  view ~read ~write:write_never int

let one_to_ok = 
  let read = function 1 -> `Ok () | err -> error () in 
  view ~read ~write:write_never int

let bool_to_ok = 
  let read = function 0 -> `Ok false | 1 -> `Ok true | _ -> error () in 
  view ~read ~write:write_never int

let nat_to_ok = 
  let read = function n when n < 0 -> error () | n -> `Ok n in 
  view ~read ~write:write_never int

let some_to_ok t = 
  let read = function Some v -> `Ok v | None -> error () in 
  view ~read ~write:write_never t

let sdl_free = foreign "SDL_free" (ptr void @-> returning void)

(* Since we never let SDL redefine our main make sure this is always
   called. *)

let () = 
  let set_main_ready = foreign "SDL_SetMainReady" (void @-> returning void) in
  set_main_ready ()

(* SDL results *) 

type 'a result = [ `Ok of 'a | `Error of string ]

(* Integer types and maps *)

type uint8 = int
type uint16 = int
type int16 = int
type uint32 = int32
type uint64 = int64

module Int = struct type t = int let compare : int -> int -> int = compare end
module Imap = Map.Make(Int) 

(* Bigarrays *) 

type ('a, 'b) bigarray = ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t

let ba_create k len = Bigarray.Array1.create k Bigarray.c_layout len
let ba_kind_byte_size :  ('a, 'b) Bigarray.kind -> int = fun k -> 
  let open Bigarray in
  (* FIXME: see http://caml.inria.fr/mantis/view.php?id=6263 *)
  match Obj.magic k with 
  | k when k = char || k = int8_signed || k = int8_unsigned -> 1
  | k when k = int16_signed || k = int16_unsigned -> 2
  | k when k = int32 || k = float32 -> 4
  | k when k = float64 || k = int64 || k = complex32 -> 8 
  | k when k = complex64 -> 16
  | k when k = int || k = nativeint -> Sys.word_size / 8
  | k -> assert false

let access_ptr_typ_of_ba_kind : ('a, 'b) Bigarray.kind -> 'a ptr typ = fun k -> 
  let open Bigarray in
  (* FIXME: use typ_of_bigarray_kind when ctypes support it. *)
  match Obj.magic k with
  | k when k = float32 -> Obj.magic (ptr Ctypes.float)
  | k when k = float64 -> Obj.magic (ptr Ctypes.double)
  | k when k = complex32 -> Obj.magic (ptr Ctypes.complex32)
  | k when k = complex64 -> Obj.magic (ptr Ctypes.complex64)
  | k when k = int8_signed -> Obj.magic (ptr Ctypes.int8_t)
  | k when k = int8_unsigned -> Obj.magic (ptr Ctypes.uint8_t)
  | k when k = int16_signed -> Obj.magic (ptr Ctypes.int16_t)
  | k when k = int16_unsigned -> Obj.magic (ptr Ctypes.uint16_t)
  | k when k = int -> Obj.magic (ptr Ctypes.camlint)
  | k when k = int32 -> Obj.magic (ptr Ctypes.int32_t)
  | k when k = int64 -> Obj.magic (ptr Ctypes.int64_t)
  | k when k = nativeint -> Obj.magic (ptr Ctypes.nativeint)
  | k when k = char -> Obj.magic (ptr Ctypes.char)
  | _ -> assert false
        
let ba_byte_size ba = 
  let el_size = ba_kind_byte_size (Bigarray.Array1.kind ba) in 
  el_size * Bigarray.Array1.dim ba 

(* Basics *)

(* Initialization and shutdown *) 

module Init = struct
  type t = Unsigned.uint32
  let i = Unsigned.UInt32.of_int
  let ( + ) = Unsigned.UInt32.logor
  let test f m = Unsigned.UInt32.(compare (logand f m) zero <> 0)
  let eq f f' = Unsigned.UInt32.(compare f f' = 0)
  let timer = i sdl_init_timer
  let audio = i sdl_init_audio
  let video = i sdl_init_video
  let joystick = i sdl_init_joystick
  let haptic = i sdl_init_haptic
  let gamecontroller = i sdl_init_gamecontroller
  let events = i sdl_init_events
  let everything = i sdl_init_everything
  let noparachute = i sdl_init_noparachute
end

let init = 
  foreign "SDL_Init" (uint32_t @-> returning zero_to_ok)

let init_sub_system = 
  foreign "SDL_InitSubSystem" (uint32_t @-> returning zero_to_ok)

let quit = 
  foreign "SDL_Quit" (void @-> returning void)

let quit_sub_system = 
  foreign "SDL_QuitSubSystem" (uint32_t @-> returning void)

let was_init = 
  foreign "SDL_WasInit" (uint32_t @-> returning uint32_t)

let was_init = function
| None -> was_init (Unsigned.UInt32.of_int 0) 
| Some m -> was_init m

(* Hints *)

module Hint = struct
  type t = string
  let framebuffer_acceleration = sdl_hint_framebuffer_acceleration
  let idle_timer_disabled = sdl_hint_idle_timer_disabled
  let orientations = sdl_hint_orientations
  let render_driver = sdl_hint_render_driver
  let render_opengl_shaders = sdl_hint_render_opengl_shaders
  let render_scale_quality = sdl_hint_render_scale_quality
  let render_vsync = sdl_hint_render_vsync

  type priority = int
  let default = sdl_hint_default
  let normal = sdl_hint_normal  
  let override = sdl_hint_override
end

let clear_hints = 
  foreign "SDL_ClearHints" (void @-> returning void)

let get_hint = 
  foreign "SDL_GetHint" (string @-> returning string_opt) 

let set_hint = 
  foreign "SDL_SetHint" (string @-> string @-> returning bool)

let set_hint_with_priority = 
  foreign "SDL_SetHintWithPriority" 
    (string @-> string @-> int @-> returning bool)

(* Errors *)

let clear_error = 
  foreign "SDL_ClearError" (void @-> returning void)

let set_error = 
  foreign "SDL_SetError" (string @-> returning int)

let set_error fmt = 
  kpp (fun s -> ignore (set_error s)) fmt 

(* Log *) 

module Log = struct
  type category = int
  let category_application = sdl_log_category_application
  let category_error = sdl_log_category_error
  let category_system = sdl_log_category_system
  let category_audio = sdl_log_category_audio
  let category_video = sdl_log_category_video
  let category_render = sdl_log_category_render
  let category_input = sdl_log_category_input
  let category_custom = sdl_log_category_custom 

  type priority = int
  let priority_compare : int -> int -> int = Pervasives.compare 
  let priority_verbose = sdl_log_priority_verbose
  let priority_debug = sdl_log_priority_debug
  let priority_info = sdl_log_priority_info
  let priority_warn = sdl_log_priority_warn
  let priority_error = sdl_log_priority_error
  let priority_critical = sdl_log_priority_critical
end

let log_fun_t = (int @-> string @-> string @-> returning void)

let log = 
  foreign "SDL_Log" (string @-> string @-> returning void)

let log fmt = 
  kpp (fun s -> ignore (log "%s" s)) fmt

let log_critical = 
  foreign "SDL_LogCritical" log_fun_t

let log_critical c fmt = 
  kpp (fun s -> ignore (log_critical c "%s" s)) fmt

let log_debug = 
  foreign "SDL_LogDebug" log_fun_t

let log_debug c fmt = 
  kpp (fun s -> ignore (log_debug c "%s" s)) fmt

let log_error = 
  foreign "SDL_LogError" log_fun_t

let log_error c fmt = 
  kpp (fun s -> ignore (log_error c "%s" s)) fmt

let log_info = 
  foreign "SDL_LogInfo" log_fun_t

let log_info c fmt = 
  kpp (fun s -> ignore (log_info c "%s" s)) fmt

let log_verbose = 
  foreign "SDL_LogVerbose" log_fun_t

let log_verbose c fmt = 
  kpp (fun s -> ignore (log_verbose c "%s" s)) fmt

let log_warn = 
  foreign "SDL_LogWarn" log_fun_t

let log_warn c fmt = 
  kpp (fun s -> ignore (log_warn c "%s" s)) fmt

let log_get_priority =
  foreign "SDL_LogGetPriority" (int @-> returning int)

let log_message = 
  foreign "SDL_LogMessage" 
    (int @-> int @-> string @-> string @-> returning void)

let log_message c p fmt = 
  kpp (fun s -> ignore (log_message c p "%s" s)) fmt

let log_reset_priorities = 
  foreign "SDL_LogResetPriorities" (void @-> returning void)

let log_set_all_priority = 
  foreign "SDL_LogSetAllPriority" (int @-> returning void)

let log_set_priority = 
  foreign "SDL_LogSetPriority" (int @-> int @-> returning void)

(* Version *)

let version = structure "SDL_version"
let version_major = field version "major" uint8_t
let version_minor = field version "minor" uint8_t
let version_patch = field version "patch" uint8_t
let () = seal version

let get_version =
  foreign "SDL_GetVersion" (ptr version @-> returning void) 

let get_version () =
  let get v f = Unsigned.UInt8.to_int (getf v f) in
  let v = make version in
  get_version (addr v);
  (get v version_major), (get v version_minor), (get v version_patch)

let get_revision = 
  foreign "SDL_GetRevision" (void @-> returning string)  

let get_revision_number = 
  foreign "SDL_GetRevisionNumber" (void @-> returning int)

(* IO absraction *) 

type _rw_ops
let rw_ops_struct : _rw_ops structure typ = structure "SDL_RWops" 
let rw_ops : _rw_ops structure ptr typ = ptr rw_ops_struct
let rw_ops_opt : _rw_ops structure ptr option typ = ptr_opt rw_ops_struct

let rw_ops_size = field rw_ops_struct "size" 
    (funptr (rw_ops @-> returning int64_t))
let rw_ops_seek = field rw_ops_struct "seek" 
    (funptr (rw_ops @-> int64_t @-> int @-> returning int64_t))
let rw_ops_read = field rw_ops_struct "read" 
    (funptr (rw_ops @-> ptr void @-> size_t @-> size_t @-> returning size_t))
let rw_ops_write = field rw_ops_struct "write" 
    (funptr (rw_ops @-> ptr void @-> size_t @-> size_t @-> returning size_t))
let rw_ops_close = field rw_ops_struct "close" 
    (funptr (rw_ops @-> returning int))
let _ = field rw_ops_struct "type" uint32_t
(* ... #ifdef'd union follows, we don't care we don't use Ctypes.make *)
let () = seal rw_ops_struct

type rw_ops = _rw_ops structure ptr

let rw_from_file = 
  foreign "SDL_RWFromFile" 
    (string @-> string @-> returning (some_to_ok rw_ops_opt))

let rw_close ops =
  let close = getf (!@ ops) rw_ops_close in
  if close ops = 0 then `Ok () else (error ())

(* File system paths *)

let get_base_path = 
  foreign "SDL_GetBasePath" (void @-> returning (ptr char))

let get_base_path () = 
  let p = get_base_path () in
  let path = coerce (ptr char) (some_to_ok string_opt) p in 
  sdl_free (coerce (ptr char) (ptr void) p); 
  path

let get_pref_path = 
  foreign "SDL_GetPrefPath" (string @-> string @-> returning (ptr char))

let get_pref_path ~org ~app =
  let p = get_pref_path org app in 
  let path = coerce (ptr char) (some_to_ok string_opt) p in 
  sdl_free (coerce (ptr char) (ptr void) p);
  path

(* Video *) 

type window = unit ptr
let window : window typ = ptr void
let window_opt : window option typ = ptr_opt void

(* Colors *)

type _color
type color = _color structure
let color : color typ = structure "SDL_Color" 
let color_r = field color "r" uint8_t
let color_g = field color "g" uint8_t
let color_b = field color "b" uint8_t
let color_a = field color "a" uint8_t
let () = seal color

module Color = struct
  let create ~r ~g ~b ~a =
    let c = make color in
    setf c color_r (Unsigned.UInt8.of_int r); 
    setf c color_g (Unsigned.UInt8.of_int g); 
    setf c color_b (Unsigned.UInt8.of_int b);     
    setf c color_a (Unsigned.UInt8.of_int a);
    c
    
  let r c = Unsigned.UInt8.to_int (getf c color_r)
  let g c = Unsigned.UInt8.to_int (getf c color_g)
  let b c = Unsigned.UInt8.to_int (getf c color_b)
  let a c = Unsigned.UInt8.to_int (getf c color_a)
end

(* Points *) 

type _point
type point = _point structure
let point : point typ = structure "SDL_Point"
let point_x = field point "x" int
let point_y = field point "y" int
let () = seal point

module Point = struct
  let create ~x ~y = 
    let p = make point in 
    setf p point_x x; 
    setf p point_y y; 
    p

  let x p = getf p point_x 
  let y p = getf p point_y

  let opt_addr = function
  | None -> coerce (ptr void) (ptr point) null
  | Some v -> addr v
end

(* Rectangle *) 

type _rect
type rect = _rect structure
let rect : rect typ = structure "SDL_Rect" 
let rect_x = field rect "x" int 
let rect_y = field rect "y" int 
let rect_w = field rect "w" int 
let rect_h = field rect "h" int 
let () = seal rect

module Rect = struct
  let create ~x ~y ~w ~h = 
    let r = make rect in 
    setf r rect_x x;
    setf r rect_y y; 
    setf r rect_w w; 
    setf r rect_h h; 
    r

  let x r = getf r rect_x 
  let y r = getf r rect_y
  let w r = getf r rect_w 
  let h r = getf r rect_h 

  let opt_addr = function
  | None -> coerce (ptr void) (ptr rect) null
  | Some v -> addr v
end

let enclose_points = 
  foreign "SDL_EnclosePoints" 
    (ptr void @-> int @-> ptr rect @-> ptr rect @-> returning bool)

let enclose_points_ba ?clip ps =
  let len = Bigarray.Array1.dim ps in 
  if len mod 2 <> 0 then invalid_arg (err_length_mul len 2) else
  let count = len / 2 in
  let ps = to_voidp (bigarray_start array1 ps) in
  let res = make rect in 
  if enclose_points ps count (Rect.opt_addr clip) (addr res)
  then Some res 
  else None

let enclose_points ?clip ps =
  let count = List.length ps in
  let ps = to_voidp (Array.start (Array.of_list point ps)) in
  let res = make rect in
  if enclose_points ps count (Rect.opt_addr clip) (addr res)
  then Some res 
  else None
    
let has_intersection = 
  foreign "SDL_HasIntersection" 
    (ptr rect @-> ptr rect @-> returning bool)

let has_intersection a b = 
  has_intersection (addr a) (addr b)

let intersect_rect = 
  foreign "SDL_IntersectRect" 
    (ptr rect @-> ptr rect @-> ptr rect @-> returning bool)

let intersect_rect a b = 
  let res = make rect in 
  if intersect_rect (addr a) (addr b) (addr res) then Some res else None

let intersect_rect_and_line = 
  foreign "SDL_IntersectRectAndLine"
    (ptr rect @-> ptr int @-> ptr int @-> ptr int @-> ptr int @-> 
     returning bool)

let intersect_rect_and_line r x1 y1 x2 y2 = 
  let alloc v = allocate int v in
  let x1, y1 = alloc x1, alloc y1 in 
  let x2, y2 = alloc x2, alloc y2 in 
  if intersect_rect_and_line (addr r) x1 y1 x2 y2 
  then Some ((!@x1, !@y1), (!@x2, !@y2))
  else None 

let rect_empty r = 
  (* symbol doesn't exist: SDL_FORCE_INLINE directive
     foreign "SDL_RectEmpty" (ptr rect @-> returning bool) *)
  Rect.w r <= 0 || Rect.h r <= 0

let rect_equals a b = 
  (* symbol doesn't exist: SDL_FORCE_INLINE directive
    foreign "SDL_RectEquals" (ptr rect @-> ptr rect @-> returning bool) *)
  (Rect.x a = Rect.x b) && (Rect.y a = Rect.y b) &&
  (Rect.w a = Rect.w b) && (Rect.h a = Rect.h b)

let union_rect = 
  foreign "SDL_UnionRect" 
    (ptr rect @-> ptr rect @-> ptr rect @-> returning void)

let union_rect a b = 
  let res = make rect in
  union_rect (addr a) (addr b) (addr res); 
  res

(* Palettes *) 

type _palette
type palette_struct = _palette structure
let palette_struct : palette_struct typ = structure "SDL_Palette" 
let palette_ncolors = field palette_struct "ncolors" int
let palette_colors = field palette_struct "colors" (ptr color)
let _ = field palette_struct "version" uint32_t
let _ = field palette_struct "refcount" int
let () = seal palette_struct

type palette = palette_struct ptr
let palette : palette typ = ptr palette_struct 
let palette_opt : palette option typ = ptr_opt palette_struct

let alloc_palette =
  foreign "SDL_AllocPalette" 
    (int @-> returning (some_to_ok palette_opt))

let free_palette =
  foreign "SDL_FreePalette" (palette @-> returning void)

let get_palette_ncolors p = 
  getf (!@ p) palette_ncolors

let get_palette_colors p = 
  let ps = !@ p in
  Array.to_list 
    (Array.from_ptr (getf ps palette_colors) (getf ps palette_ncolors))
  
let get_palette_colors_ba p = 
  let ps = !@ p in 
  (* FIXME: ctypes should have an Array.copy function *)
  let n = getf ps palette_ncolors in
  let ba = Bigarray.(Array1.create int8_unsigned c_layout (n * 4)) in
  let ba_ptr = 
    Array.from_ptr (coerce (ptr int) (ptr color) (bigarray_start array1 ba)) n
  in
  let ca = Array.from_ptr (getf ps palette_colors) n in 
  for i = 0 to n - 1 do Array.set ba_ptr i (Array.get ca i) done;
  ba
  
let set_palette_colors = 
  foreign "SDL_SetPaletteColors" 
    (palette @-> ptr void @-> int @-> int @-> returning zero_to_ok)

let set_palette_colors_ba p cs ~fst = 
  let len = Bigarray.Array1.dim cs in 
  if len mod 4 <> 0 then invalid_arg (err_length_mul len 4) else 
  let count = len / 4 in
  let cs = to_voidp (bigarray_start array1 cs) in
  set_palette_colors p cs fst count

let set_palette_colors p cs ~fst =
  let count = List.length cs in
  let a = Array.of_list color cs in
  set_palette_colors p (to_voidp (Array.start a)) fst count

(* Pixel formats *)

type gamma_ramp = (int, Bigarray.int16_unsigned_elt) bigarray

let calculate_gamma_ramp =
  foreign "SDL_CalculateGammaRamp" 
    (float @-> ptr void @-> returning void)

let calculate_gamma_ramp g = 
  let ba = Bigarray.(Array1.create int16_unsigned c_layout 256) in
  calculate_gamma_ramp g (to_voidp (bigarray_start array1 ba));
  ba

module Blend = struct
  type mode = int 
  let mode_none = sdl_blendmode_none  
  let mode_blend = sdl_blendmode_blend  
  let mode_add = sdl_blendmode_add
  let mode_mod = sdl_blendmode_mod  
end

module Pixel = struct
  type format_enum = Unsigned.UInt32.t 
  let i = Unsigned.UInt32.of_int32
  let to_uint32 = Unsigned.UInt32.to_int32
  let eq f f' = Unsigned.UInt32.(compare f f' = 0)
  let format_unknown = i sdl_pixelformat_unknown
  let format_index1lsb = i sdl_pixelformat_index1lsb
  let format_index1msb = i sdl_pixelformat_index1msb
  let format_index4lsb = i sdl_pixelformat_index4lsb
  let format_index4msb = i sdl_pixelformat_index4msb
  let format_index8 = i sdl_pixelformat_index8
  let format_rgb332 = i sdl_pixelformat_rgb332
  let format_rgb444 = i sdl_pixelformat_rgb444
  let format_rgb555 = i sdl_pixelformat_rgb555
  let format_bgr555 = i sdl_pixelformat_bgr555
  let format_argb4444 = i sdl_pixelformat_argb4444
  let format_rgba4444 = i sdl_pixelformat_rgba4444
  let format_abgr4444 = i sdl_pixelformat_abgr4444
  let format_bgra4444 = i sdl_pixelformat_bgra4444
  let format_argb1555 = i sdl_pixelformat_argb1555
  let format_rgba5551 = i sdl_pixelformat_rgba5551
  let format_abgr1555 = i sdl_pixelformat_abgr1555
  let format_bgra5551 = i sdl_pixelformat_bgra5551
  let format_rgb565 = i sdl_pixelformat_rgb565
  let format_bgr565 = i sdl_pixelformat_bgr565
  let format_rgb24 = i sdl_pixelformat_rgb24
  let format_bgr24 = i sdl_pixelformat_bgr24
  let format_rgb888 = i sdl_pixelformat_rgb888
  let format_rgbx8888 = i sdl_pixelformat_rgbx8888
  let format_bgr888 = i sdl_pixelformat_bgr888
  let format_bgrx8888 = i sdl_pixelformat_bgrx8888
  let format_argb8888 = i sdl_pixelformat_argb8888
  let format_rgba8888 = i sdl_pixelformat_rgba8888
  let format_abgr8888 = i sdl_pixelformat_abgr8888
  let format_bgra8888 = i sdl_pixelformat_bgra8888
  let format_argb2101010 = i sdl_pixelformat_argb2101010
  let format_yv12 = i sdl_pixelformat_yv12
  let format_iyuv = i sdl_pixelformat_iyuv
  let format_yuy2 = i sdl_pixelformat_yuy2
  let format_uyvy = i sdl_pixelformat_uyvy
  let format_yvyu = i sdl_pixelformat_yvyu
end

(* Note. Giving direct access to the palette field of SDL_PixelFormat
   is problematic. We can't ensure the pointer won't become invalid at
   a certain point. *)

type _pixel_format
type pixel_format_struct = _pixel_format structure
let pixel_format_struct : pixel_format_struct typ = structure "SDL_PixelFormat"
let pf_format = field pixel_format_struct "format" uint32_t
let pf_palette = field pixel_format_struct "palette" palette
let pf_bits_per_pixel = field pixel_format_struct "BitsPerPixel" uint8_t
let pf_bytes_per_pixel = field pixel_format_struct "BytesPerPixel" uint8_t
let _ = field pixel_format_struct "padding" uint16_t
let _ = field pixel_format_struct "Rmask" uint32_t
let _ = field pixel_format_struct "Gmask" uint32_t
let _ = field pixel_format_struct "Bmask" uint32_t
let _ = field pixel_format_struct "Amask" uint32_t
let _ = field pixel_format_struct "Rloss" uint8_t
let _ = field pixel_format_struct "Gloss" uint8_t
let _ = field pixel_format_struct "Bloss" uint8_t
let _ = field pixel_format_struct "Aloss" uint8_t
let _ = field pixel_format_struct "Rshift" uint8_t
let _ = field pixel_format_struct "Gshift" uint8_t
let _ = field pixel_format_struct "Bshift" uint8_t
let _ = field pixel_format_struct "Ashift" uint8_t
let _ = field pixel_format_struct "refcount" int
let _ = field pixel_format_struct "next" (ptr pixel_format_struct)
let () = seal pixel_format_struct

type pixel_format = pixel_format_struct ptr
let pixel_format : pixel_format typ = ptr pixel_format_struct 
let pixel_format_opt : pixel_format option typ = ptr_opt pixel_format_struct

let alloc_format = 
  foreign "SDL_AllocFormat" 
    (uint32_t @-> returning (some_to_ok pixel_format_opt))

let free_format = 
  foreign "SDL_FreeFormat" (pixel_format @-> returning void)

let get_pixel_format_name = 
  foreign "SDL_GetPixelFormatName" (uint32_t @-> returning string)

let get_pixel_format_format pf = 
  getf (!@ pf) pf_format 

let get_pixel_format_bits_pp pf = 
  Unsigned.UInt8.to_int (getf (!@ pf) pf_bits_per_pixel)

let get_pixel_format_bytes_pp pf = 
  Unsigned.UInt8.to_int (getf (!@ pf) pf_bytes_per_pixel)

let get_rgb = 
  foreign "SDL_GetRGB" 
    (int32_as_uint32_t @-> pixel_format @-> ptr uint8_t @-> 
     ptr uint8_t @-> ptr uint8_t @-> returning void)

let get_rgb pf p = 
  let alloc () = allocate uint8_t Unsigned.UInt8.zero in
  let to_int = Unsigned.UInt8.to_int in
  let r, g, b = alloc (), alloc (), alloc () in
  get_rgb p pf r g b; 
   to_int (!@ r), to_int (!@ g), to_int (!@ b)
  
let get_rgba = 
  foreign "SDL_GetRGBA" 
    (int32_as_uint32_t @-> pixel_format @-> ptr uint8_t @-> 
     ptr uint8_t @-> ptr uint8_t @-> ptr uint8_t @-> returning void)

let get_rgba pf p = 
  let alloc () = allocate uint8_t Unsigned.UInt8.zero in
  let to_int = Unsigned.UInt8.to_int in
  let r, g, b, a = alloc (), alloc (), alloc (), alloc () in
  get_rgba p pf r g b a; 
   to_int (!@ r), to_int (!@ g), to_int (!@ b), to_int (!@ a)

let map_rgb = 
  foreign "SDL_MapRGB" 
    (pixel_format @-> int_as_uint8_t @-> int_as_uint8_t @-> int_as_uint8_t @-> 
     returning int32_as_uint32_t)

let map_rgba = 
  foreign "SDL_MapRGBA" 
    (pixel_format @-> int_as_uint8_t @-> int_as_uint8_t @-> int_as_uint8_t @-> 
     int_as_uint8_t @-> returning int32_as_uint32_t)

let masks_to_pixel_format_enum = 
  foreign "SDL_MasksToPixelFormatEnum" 
    (int @-> int32_as_uint32_t @-> int32_as_uint32_t @-> int32_as_uint32_t @-> 
     int32_as_uint32_t @-> returning uint32_t)

let pixel_format_enum_to_masks = 
  foreign "SDL_PixelFormatEnumToMasks" 
    (uint32_t @-> ptr int @-> 
     ptr uint32_t @-> ptr uint32_t @-> ptr uint32_t @-> ptr uint32_t @-> 
     returning bool)

let pixel_format_enum_to_masks pf = 
  let ui () = allocate uint32_t (Unsigned.UInt32.of_int 0) in 
  let get iptr = Unsigned.UInt32.to_int32 (!@ iptr) in
  let bpp = allocate int 0 in 
  let rm, gm, bm, am = ui (), ui (), ui (), ui () in 
  if not (pixel_format_enum_to_masks pf bpp rm gm bm am) then error () else 
  `Ok (!@ bpp, get rm, get gm, get bm, get am)
  
let set_pixel_format_palette = 
  foreign "SDL_SetPixelFormatPalette" 
    (pixel_format @-> palette @-> returning zero_to_ok)

(* Surface *)

type _surface
type surface_struct = _surface structure
let surface_struct : surface_struct typ = structure "SDL_Surface" 
let _ = field surface_struct "flags" uint32_t
let surface_format = field surface_struct "format" pixel_format
let surface_w = field surface_struct "w" int
let surface_h = field surface_struct "h" int
let surface_pitch = field surface_struct "pitch" int
let surface_pixels = field surface_struct "pixels" (ptr void)
let _ = field surface_struct "userdata" (ptr void)
let _ = field surface_struct "locked" int
let _ = field surface_struct "lock_data" (ptr void)
let _ = field surface_struct "clip_rect" rect 
let _ = field surface_struct "map" (ptr void)
let _ = field surface_struct "refcount" int
let () = seal surface_struct

type surface = surface_struct ptr
let surface : surface typ = ptr surface_struct 
let surface_opt : surface option typ = ptr_opt surface_struct

let blit_scaled = 
  (* SDL_BlitScaled is #ifdef'd to SDL_UpperBlitScaled *)
  foreign "SDL_UpperBlitScaled"
    (surface @-> ptr rect @-> surface @-> ptr rect @-> returning zero_to_ok) 

let blit_scaled ~src sr ~dst dr = 
  blit_scaled src (addr sr) dst (Rect.opt_addr dr)

let blit_surface = 
  (* SDL_BlitSurface is #ifdef'd to SDL_UpperBlit *)
  foreign "SDL_UpperBlit"
    (surface @-> ptr rect @-> surface @-> ptr rect @-> returning zero_to_ok)

let blit_surface ~src sr ~dst dr = 
  blit_surface src (addr sr) dst (addr dr)

let convert_pixels = 
  foreign "SDL_ConvertPixels"
    (int @-> int @-> uint32_t @-> ptr void @-> int @-> uint32_t @-> 
     ptr void @-> int @-> returning zero_to_ok)

let convert_pixels ~w ~h ~src sp spitch ~dst dp dpitch = 
  (* FIXME: we could try check bounds. *) 
  let spitch = ba_kind_byte_size (Bigarray.Array1.kind sp) * spitch in
  let dpitch = ba_kind_byte_size (Bigarray.Array1.kind dp) * dpitch in
  let sp = to_voidp (bigarray_start array1 sp) in 
  let dp = to_voidp (bigarray_start array1 dp) in 
  convert_pixels w h src sp spitch dst dp dpitch

let convert_surface = 
  foreign "SDL_ConvertSurface" 
    (surface @-> pixel_format @-> uint32_t @-> 
     returning (some_to_ok surface_opt))

let convert_surface s pf = 
  convert_surface s pf Unsigned.UInt32.zero

let convert_surface_format = 
  foreign "SDL_ConvertSurfaceFormat"
    (surface @-> uint32_t @-> uint32_t @-> returning (some_to_ok surface_opt))

let convert_surface_format s pf = 
  convert_surface_format s pf Unsigned.UInt32.zero

let create_rgb_surface = 
  foreign "SDL_CreateRGBSurface"
    (uint32_t @-> int @-> int @-> int @-> int32_as_uint32_t @-> 
     int32_as_uint32_t @-> int32_as_uint32_t @-> int32_as_uint32_t @-> 
     returning (some_to_ok surface_opt))

let create_rgb_surface ~w ~h ~depth rmask gmask bmask amask = 
  create_rgb_surface Unsigned.UInt32.zero w h depth rmask gmask bmask amask

let create_rgb_surface_from =
  foreign "SDL_CreateRGBSurfaceFrom"
    (ptr void @-> int @-> int @-> int @-> int @-> int32_as_uint32_t @-> 
     int32_as_uint32_t @-> int32_as_uint32_t @-> int32_as_uint32_t @-> 
     returning (some_to_ok surface_opt))

let create_rgb_surface_from p ~w ~h ~depth ~pitch rmask gmask bmask amask = 
  (* FIXME: we could try check bounds. *) 
  let pitch = ba_kind_byte_size (Bigarray.Array1.kind p) * pitch in
  let p = to_voidp (bigarray_start array1 p) in
  create_rgb_surface_from p w h depth pitch rmask gmask bmask amask

let fill_rect =
  foreign "SDL_FillRect" 
    (surface @-> ptr rect @-> int32_as_uint32_t @-> returning zero_to_ok)

let fill_rect s r c = 
  fill_rect s (Rect.opt_addr r) c 

let fill_rects = 
  foreign "SDL_FillRects" 
    (surface @-> ptr void @-> int @-> int32_as_uint32_t @-> 
     returning zero_to_ok)
    
let fill_rects_ba s rs col =
  let len = Bigarray.Array1.dim rs in 
  if len mod 4 <> 0 then invalid_arg (err_length_mul len 4) else 
  let count = len / 4 in
  let rs = to_voidp (bigarray_start array1 rs) in
  fill_rects s rs count col

let fill_rects s rs col =
  let count = List.length rs in
  let a = Array.of_list rect rs in
  fill_rects s (to_voidp (Array.start a)) count col

let free_surface = 
  foreign "SDL_FreeSurface" (surface @-> returning void)

let get_clip_rect = 
  foreign "SDL_GetClipRect" (surface @-> ptr rect @-> returning void)

let get_clip_rect s = 
  let r = make rect in 
  (get_clip_rect s (addr r); r)

let get_color_key = 
  foreign "SDL_GetColorKey"
    (surface @-> ptr uint32_t @-> returning zero_to_ok)

let get_color_key s = 
  let key = allocate uint32_t Unsigned.UInt32.zero in 
  match get_color_key s key with 
  | `Ok () -> `Ok (Unsigned.UInt32.to_int32 (!@ key)) | `Error _ as e -> e

let get_surface_alpha_mod =
  foreign "SDL_GetSurfaceAlphaMod" 
    (surface @-> ptr uint8_t @-> returning zero_to_ok)

let get_surface_alpha_mod s = 
  let alpha = allocate uint8_t Unsigned.UInt8.zero in 
  match get_surface_alpha_mod s alpha with 
  | `Ok () -> `Ok (Unsigned.UInt8.to_int (!@ alpha)) | `Error _ as e -> e

let get_surface_blend_mode = 
  foreign "SDL_GetSurfaceBlendMode"
    (surface @-> ptr int @-> returning zero_to_ok)

let get_surface_blend_mode s = 
  let mode = allocate int 0 in 
  match get_surface_blend_mode s mode with 
  `Ok () -> `Ok (!@ mode) | `Error _ as e -> e

let get_surface_color_mod = 
  foreign "SDL_GetSurfaceColorMod"
    (surface @-> ptr uint8_t @-> ptr uint8_t @-> ptr uint8_t @-> 
     returning zero_to_ok)

let get_surface_color_mod s = 
  let alloc () = allocate uint8_t Unsigned.UInt8.zero in 
  let get v = Unsigned.UInt8.to_int (!@ v) in
  let r, g, b = alloc (), alloc (), alloc () in 
  match get_surface_color_mod s r g b with 
  | `Ok () -> `Ok (get r, get g, get b) | `Error _ as e -> e

let get_surface_format_enum s = 
  (* We don't give direct access to the format field. This prevents 
     memory ownership problems. *)
  get_pixel_format_format (getf (!@ s) surface_format)

let get_surface_pitch s = 
  getf (!@ s) surface_pitch

let get_surface_pixels s kind =
  let pitch = get_surface_pitch s in
  let kind_size = ba_kind_byte_size kind in 
  if pitch mod kind_size <> 0 
  then invalid_arg (err_bigarray_pitch pitch kind_size)
  else
  let h = getf (!@ s) surface_h in
  let ba_size = (pitch * h) / kind_size in
  let pixels = getf (!@ s) surface_pixels in 
  let pixels = coerce (ptr void) (access_ptr_typ_of_ba_kind kind) pixels in
  bigarray_of_ptr array1 ba_size kind pixels

let get_surface_size s = 
  getf (!@ s) surface_w, getf (!@ s) surface_h

let load_bmp_rw = 
  foreign "SDL_LoadBMP_RW" 
    (rw_ops @-> bool @-> returning (some_to_ok surface_opt))

let load_bmp_rw rw ~close = 
  load_bmp_rw rw close 

let load_bmp file = 
  (* SDL_LoadBMP is cpp based *) 
  match rw_from_file file "rb" with 
  | `Error _ as e -> e
  | `Ok rw -> load_bmp_rw rw ~close:true

let lock_surface = 
  foreign "SDL_LockSurface" (surface @-> returning zero_to_ok)

let lower_blit = 
  foreign "SDL_LowerBlit"
    (surface @-> ptr rect @-> surface @-> ptr rect @-> returning zero_to_ok)

let lower_blit ~src sr ~dst dr = 
  lower_blit src (addr sr) dst (addr dr)

let lower_blit_scaled = 
  foreign "SDL_LowerBlitScaled"
    (surface @-> ptr rect @-> surface @-> ptr rect @-> returning zero_to_ok)

let lower_blit_scaled ~src sr ~dst dr = 
  lower_blit_scaled src (addr sr) dst (addr dr)

let save_bmp_rw = 
  foreign "SDL_SaveBMP_RW" 
    (surface @-> rw_ops @-> bool @-> returning zero_to_ok)

let save_bmp_rw s rw ~close = 
  save_bmp_rw s rw close

let save_bmp s file = 
  (* SDL_SaveBMP is cpp based *) 
  match rw_from_file file "wb" with 
  | `Error _ as e -> e
  | `Ok rw -> save_bmp_rw s rw ~close:true

let set_clip_rect = 
  foreign "SDL_SetClipRect" (surface @-> ptr rect @-> returning bool)

let set_clip_rect s r = 
  set_clip_rect s (addr r)

let set_color_key = 
  foreign "SDL_SetColorKey" 
    (surface @-> bool @-> int32_as_uint32_t @-> returning zero_to_ok)

let set_surface_alpha_mod = 
  foreign "SDL_SetSurfaceAlphaMod" 
    (surface @-> int_as_uint8_t @-> returning zero_to_ok)

let set_surface_blend_mode = 
  foreign "SDL_SetSurfaceBlendMode" 
    (surface @-> int @-> returning zero_to_ok)

let set_surface_color_mod = 
  foreign "SDL_SetSurfaceColorMod" 
    (surface @-> int_as_uint8_t @-> int_as_uint8_t @-> int_as_uint8_t @-> 
     returning zero_to_ok)

let set_surface_palette = 
  foreign "SDL_SetSurfacePalette" 
    (surface @-> palette @-> returning zero_to_ok)

let set_surface_rle = 
  foreign "SDL_SetSurfaceRLE" (surface @-> bool @-> returning zero_to_ok)

let unlock_surface =
  foreign "SDL_UnlockSurface" (surface @-> returning void)

(* Renderers *)

type flip = int 
module Flip = struct
  let ( + ) = ( lor )
  let none = sdl_flip_none
  let horizontal = sdl_flip_horizontal
  let vertical = sdl_flip_vertical
end

type texture = unit ptr
let texture : texture typ = ptr void
let texture_opt : texture option typ = ptr_opt void

type renderer = unit ptr
let renderer : renderer typ = ptr void
let renderer_opt : renderer option typ = ptr_opt void

module Renderer = struct
  type flags = Unsigned.uint32
  let i = Unsigned.UInt32.of_int
  let ( + ) = Unsigned.UInt32.logor
  let test f m = Unsigned.UInt32.(compare (logand f m) zero <> 0)
  let eq f f' = Unsigned.UInt32.(compare f f' = 0)
  let none = Unsigned.UInt32.zero
  let software = i sdl_renderer_software
  let accelerated = i sdl_renderer_accelerated 
  let presentvsync = i sdl_renderer_presentvsync
  let targettexture = i sdl_renderer_targettexture
end

type renderer_info = 
  { ri_name : string;
    ri_flags : Renderer.flags; 
    ri_texture_formats : Pixel.format_enum list; 
    ri_max_texture_width : int; 
    ri_max_texture_height : int; }

let renderer_info = structure "SDL_RendererInfo"
let ri_name = field renderer_info "name" string
let ri_flags = field renderer_info "flags" uint32_t
let ri_num_tf = field renderer_info "num_texture_formats" uint32_t 
let ri_tfs = field renderer_info "texture_formats" (array 16 uint32_t)
let ri_max_texture_width = field renderer_info "max_texture_width" int 
let ri_max_texture_height = field renderer_info "max_texture_height" int 
let () = seal renderer_info

let renderer_info_of_c c =
  let ri_name = getf c ri_name in
  let ri_flags = getf c ri_flags in
  let num_tf = Unsigned.UInt32.to_int (getf c ri_num_tf) in 
  let tfs = getf c ri_tfs in
  let ri_texture_formats = 
    let acc = ref [] in
    for i = 0 to num_tf - 1 do acc := (Array.get tfs i) :: !acc done; 
    List.rev !acc
  in
  let ri_max_texture_width = getf c ri_max_texture_width in
  let ri_max_texture_height = getf c ri_max_texture_height in  
  { ri_name; ri_flags; ri_texture_formats; ri_max_texture_width; 
    ri_max_texture_height }

let create_renderer = 
  foreign "SDL_CreateRenderer" 
    (window @-> int @-> uint32_t @-> returning (some_to_ok renderer_opt))

let create_renderer ?(index = -1) ?(flags = Unsigned.UInt32.zero) w =
  create_renderer w index flags

let create_software_renderer = 
  foreign "SDL_CreateSoftwareRenderer" 
    (surface @-> returning (some_to_ok renderer_opt))

let destroy_renderer = 
  foreign "SDL_DestroyRenderer" (renderer @-> returning void)
    
let get_num_render_drivers =
  foreign "SDL_GetNumRenderDrivers" (void @-> returning nat_to_ok)

let get_render_draw_blend_mode =
  foreign "SDL_GetRenderDrawBlendMode" 
    (renderer @-> ptr int @-> returning zero_to_ok)

let get_render_draw_blend_mode r = 
  let m = allocate int 0 in 
  match get_render_draw_blend_mode r m with 
  | `Ok () -> `Ok !@m | `Error _ as e -> e

let get_render_draw_color = 
  foreign "SDL_GetRenderDrawColor" 
    (renderer @-> ptr uint8_t @-> ptr uint8_t @-> ptr uint8_t @-> 
     ptr uint8_t @-> returning zero_to_ok)

let get_render_draw_color rend = 
  let alloc () = allocate uint8_t Unsigned.UInt8.zero in 
  let get v = Unsigned.UInt8.to_int (!@ v) in 
  let r, g, b, a = alloc (), alloc (), alloc (), alloc () in
  match get_render_draw_color rend r g b a with 
  | `Ok () -> `Ok (get r, get g, get b, get a) | `Error _ as e -> e

let get_render_driver_info = 
  foreign "SDL_GetRenderDriverInfo" 
    (int @-> ptr renderer_info @-> returning zero_to_ok)

let get_render_driver_info i = 
  let info = make renderer_info in 
  match get_render_driver_info i (addr info) with 
  | `Ok () -> `Ok (renderer_info_of_c info) | `Error _ as e -> e

let get_render_target = 
  foreign "SDL_GetRenderTarget" (renderer @-> returning texture_opt)

let get_renderer =
  foreign "SDL_GetRenderer" 
    (window @-> returning (some_to_ok renderer_opt))

let get_renderer_info =
  foreign "SDL_GetRendererInfo" 
    (renderer @-> ptr renderer_info @-> returning zero_to_ok)

let get_renderer_info r = 
  let info = make renderer_info in
  match get_renderer_info r (addr info) with 
  | `Ok () -> `Ok (renderer_info_of_c info) | `Error _ as e -> e

let get_renderer_output_size = 
  foreign "SDL_GetRendererOutputSize" 
    (renderer @-> ptr int @-> ptr int @-> returning zero_to_ok)

let get_renderer_output_size r =
  let w = allocate int 0 in 
  let h = allocate int 0 in 
  match get_renderer_output_size r w h with 
  | `Ok () -> `Ok (!@ w, !@ h) | `Error _ as e -> e

let render_clear = 
  foreign "SDL_RenderClear" (renderer @-> returning zero_to_ok)

let render_copy = 
  foreign "SDL_RenderCopy" 
    (renderer @-> texture @-> ptr rect @-> ptr rect @-> 
     returning zero_to_ok)
 
let render_copy ?src ?dst r t = 
  render_copy r t (Rect.opt_addr src) (Rect.opt_addr dst)

let render_copy_ex = 
  foreign "SDL_RenderCopyEx" 
    (renderer @-> texture @-> ptr rect @-> ptr rect @-> double @-> 
     ptr point @-> int @-> returning zero_to_ok)

let render_copy_ex ?src ?dst r t angle c flip = 
  render_copy_ex r t (Rect.opt_addr src) (Rect.opt_addr dst) angle 
    (Point.opt_addr c) flip

let render_draw_line = 
  foreign "SDL_RenderDrawLine" 
    (renderer @-> int @-> int @-> int @-> int @-> returning zero_to_ok)
                                
let render_draw_lines =
  foreign "SDL_RenderDrawLines" 
    (renderer @-> ptr void @-> int @-> returning zero_to_ok) 

let render_draw_lines_ba r ps = 
  let len = Bigarray.Array1.dim ps in 
  if len mod 2 <> 0 then invalid_arg (err_length_mul len 2) else 
  let count = len / 2 in
  let ps = to_voidp (bigarray_start array1 ps) in
  render_draw_lines r ps count

let render_draw_lines r ps =
  let count = List.length ps in
  let a = Array.of_list point ps in
  render_draw_lines r (to_voidp (Array.start a)) count

let render_draw_point = 
  foreign "SDL_RenderDrawPoint"
    (renderer @-> int @-> int @-> returning zero_to_ok)

let render_draw_points = 
  foreign "SDL_RenderDrawPoints"
    (renderer @-> ptr void @-> int @-> returning zero_to_ok)

let render_draw_points_ba r ps = 
  let len = Bigarray.Array1.dim ps in 
  if len mod 2 <> 0 then invalid_arg (err_length_mul len 2) else 
  let count = len / 2 in
  let ps = to_voidp (bigarray_start array1 ps) in
  render_draw_points r ps count

let render_draw_points r ps =
  let count = List.length ps in
  let a = Array.of_list point ps in
  render_draw_points r (to_voidp (Array.start a)) count

let render_draw_rect = 
  foreign "SDL_RenderDrawRect" 
    (renderer @-> ptr rect @-> returning zero_to_ok)

let render_draw_rect rend r = 
  render_draw_rect rend (Rect.opt_addr r)

let render_draw_rects = 
  foreign "SDL_RenderDrawRects" 
    (renderer @-> ptr void @-> int @-> returning zero_to_ok)

let render_draw_rects_ba r rs = 
  let len = Bigarray.Array1.dim rs in 
  if len mod 4 <> 0 then invalid_arg (err_length_mul len 4) else 
  let count = len / 4 in
  let rs = to_voidp (bigarray_start array1 rs) in
  render_draw_rects r rs count

let render_draw_rects r rs =
  let count = List.length rs in
  let a = Array.of_list rect rs in
  render_draw_rects r (to_voidp (Array.start a)) count

let render_fill_rect =
  foreign "SDL_RenderFillRect"
    (renderer @-> ptr rect @-> returning zero_to_ok)

let render_fill_rect rend r =
  render_fill_rect rend (Rect.opt_addr r)

let render_fill_rects = 
  foreign "SDL_RenderFillRects" 
    (renderer @-> ptr void @-> int @-> returning zero_to_ok)

let render_fill_rects_ba r rs = 
  let len = Bigarray.Array1.dim rs in 
  if len mod 4 <> 0 then invalid_arg (err_length_mul len 4) else 
  let count = len / 4 in
  let rs = to_voidp (bigarray_start array1 rs) in
  render_fill_rects r rs count

let render_fill_rects r rs =
  let count = List.length rs in
  let a = Array.of_list rect rs in
  render_fill_rects r (to_voidp (Array.start a)) count

let render_get_clip_rect =
  foreign "SDL_RenderGetClipRect" 
    (renderer @-> ptr rect @-> returning void) 

let render_get_clip_rect rend = 
  let r = make rect in 
  render_get_clip_rect rend (addr r); 
  r

let render_get_logical_size =
  foreign "SDL_RenderGetLogicalSize" 
    (renderer @-> ptr int @-> ptr int @-> returning void)

let render_get_logical_size r = 
  let w = allocate int 0 in 
  let h = allocate int 0 in 
  render_get_logical_size r w h; 
  !@ w, !@ h

let render_get_scale = 
  foreign "SDL_RenderGetScale" 
    (renderer @-> ptr float @-> ptr float @-> returning void)

let render_get_scale r = 
  let x = allocate float 0. in 
  let y = allocate float 0. in 
  render_get_scale r x y; 
  !@ x, !@ y

let render_get_viewport = 
  foreign "SDL_RenderGetViewport" 
    (renderer @-> ptr rect @-> returning void)

let render_get_viewport rend = 
  let r = make rect in 
  render_get_viewport rend (addr r); 
  r

let render_present = 
  foreign "SDL_RenderPresent" (renderer @-> returning void)

let render_read_pixels = 
  foreign "SDL_RenderReadPixels" 
    (renderer @-> ptr rect @-> uint32_t @-> ptr void @-> int @-> 
     returning zero_to_ok)

let render_read_pixels r rect format pixels pitch = 
  let format = match format with None -> Unsigned.UInt32.zero | Some f -> f in 
  let pixels = to_voidp (bigarray_start array1 pixels) in
  render_read_pixels r (Rect.opt_addr rect) format pixels pitch 

let render_set_clip_rect =
  foreign "SDL_RenderSetClipRect" 
    (renderer @-> ptr rect @-> returning zero_to_ok)

let render_set_clip_rect rend r = 
  render_set_clip_rect rend (Rect.opt_addr r)

let render_set_logical_size = 
  foreign "SDL_RenderSetLogicalSize"
    (renderer @-> int @-> int @-> returning zero_to_ok)

let render_set_scale =
  foreign "SDL_RenderSetScale" 
    (renderer @-> float @-> float @-> returning zero_to_ok)

let render_set_viewport = 
  foreign "SDL_RenderSetViewport"
    (renderer @-> ptr rect @-> returning zero_to_ok)

let render_set_viewport rend r = 
  render_set_viewport rend (Rect.opt_addr r)

let render_target_supported = 
  foreign "SDL_RenderTargetSupported" (renderer @-> returning bool)

let set_render_draw_blend_mode = 
  foreign "SDL_SetRenderDrawBlendMode" 
    (renderer @-> int @-> returning zero_to_ok)

let set_render_draw_color = 
  foreign "SDL_SetRenderDrawColor" 
    (renderer @-> int_as_uint8_t @-> int_as_uint8_t @-> int_as_uint8_t @-> 
     int_as_uint8_t @-> returning zero_to_ok)

let set_render_target =
  foreign "SDL_SetRenderTarget"
    (renderer @-> texture @-> returning zero_to_ok)

let set_render_target r t = 
  let t = match t with None -> null | Some t -> t in 
  set_render_target r t

(* Textures *) 

module Texture = struct
  type access = int
  let access_static = sdl_textureaccess_static
  let access_streaming = sdl_textureaccess_streaming  
  let access_target = sdl_textureaccess_target

  let i = Unsigned.UInt32.of_int
  type modulate = Unsigned.uint32
  let modulate_none = i sdl_texturemodulate_none
  let modulate_color = i sdl_texturemodulate_color
  let modulate_alpha = i sdl_texturemodulate_alpha
end

let create_texture =
  foreign "SDL_CreateTexture"
    (renderer @-> uint32_t @-> int @-> int @-> int @-> 
     returning (some_to_ok renderer_opt))

let create_texture r pf access ~w ~h = 
  create_texture r pf access w h 
  
let create_texture_from_surface =
  foreign "SDL_CreateTextureFromSurface"
    (renderer @-> surface @-> returning (some_to_ok texture_opt))

let destroy_texture =
  foreign "SDL_DestroyTexture" (texture @-> returning void)

let get_texture_alpha_mod = 
  foreign "SDL_GetTextureAlphaMod" 
    (texture @-> ptr uint8_t @-> returning zero_to_ok)

let get_texture_alpha_mod t = 
  let alpha = allocate uint8_t Unsigned.UInt8.zero in 
  match get_texture_alpha_mod t alpha with
  | `Ok () -> `Ok (Unsigned.UInt8.to_int (!@ alpha)) | `Error _ as e -> e

let get_texture_blend_mode = 
  foreign "SDL_GetTextureBlendMode" 
    (texture @-> ptr int @-> returning zero_to_ok)

let get_texture_blend_mode t = 
  let m = allocate int 0 in 
  match get_texture_blend_mode t m with 
  | `Ok () -> `Ok (!@ m) | `Error _ as e -> e

let get_texture_color_mod =
  foreign "SDL_GetTextureColorMod" 
    (renderer @-> ptr uint8_t @-> ptr uint8_t @-> ptr uint8_t @-> 
     returning zero_to_ok)

let get_texture_color_mod t = 
  let alloc () = allocate uint8_t Unsigned.UInt8.zero in 
  let get v = Unsigned.UInt8.to_int (!@ v) in 
  let r, g, b = alloc (), alloc (), alloc () in
  match get_texture_color_mod t r g b with 
  | `Ok () -> `Ok (get r, get g, get b) | `Error _ as e -> e

let query_texture =
  foreign "SDL_QueryTexture" 
    (texture @-> ptr uint32_t @-> ptr int @-> ptr int @-> ptr int @-> 
     returning zero_to_ok)

let _texture_height t = 
  let h = allocate int 0 in
  let unull = coerce (ptr void) (ptr uint32_t) null in 
  let inull = coerce (ptr void) (ptr int) null in
  match query_texture t unull inull inull h with 
  | `Ok () -> `Ok (!@ h) | `Error _ as e -> e

let lock_texture = 
  foreign "SDL_LockTexture" 
    (texture @-> ptr rect @-> ptr (ptr void) @-> ptr int @-> 
     returning zero_to_ok)

let lock_texture t r kind =
  match (match r with None -> _texture_height t | Some r -> `Ok (Rect.h r)) with
  | `Error _ as e -> e
  | `Ok h -> 
      let pitch = allocate int 0 in 
      let p = allocate (ptr void) null in
      match lock_texture t (Rect.opt_addr r) p pitch with 
      | `Error _ as e -> e
      | `Ok () -> 
          let p = !@ p in 
          let pitch = !@ pitch in
          let kind_size = ba_kind_byte_size kind in 
          if pitch mod kind_size <> 0 
          then invalid_arg (err_bigarray_pitch pitch kind_size)
          else
          let ba_size = (pitch * h) / kind_size in
          let pixels = coerce (ptr void) (access_ptr_typ_of_ba_kind kind) p in
          `Ok (bigarray_of_ptr array1 ba_size kind pixels, pitch / kind_size)

let query_texture t = 
  let pf = allocate uint32_t Unsigned.UInt32.zero in 
  let access = allocate int 0 in 
  let w = allocate int 0 in 
  let h = allocate int 0 in 
  match query_texture t pf access w h with 
  | `Ok () -> `Ok (!@ pf, !@ access, (!@ w, !@ h)) | `Error _ as e -> e

let set_texture_alpha_mod = 
  foreign "SDL_SetTextureAlphaMod" 
    (texture @-> int_as_uint8_t @-> returning zero_to_ok)

let set_texture_blend_mode =
  foreign "SDL_SetTextureBlendMode" 
    (texture @-> int @-> returning zero_to_ok)

let set_texture_color_mod =
  foreign "SDL_SetTextureColorMod" 
    (texture @-> int_as_uint8_t @-> int_as_uint8_t @-> int_as_uint8_t @-> 
     returning zero_to_ok)

let unlock_texture = 
  foreign "SDL_UnlockTexture" (texture @-> returning void)

let update_texture = 
  foreign "SDL_UpdateTexture" 
    (texture @-> ptr rect @-> ptr void @-> int @-> returning zero_to_ok)

let update_texture t rect pixels pitch = 
  let pitch = pitch * (ba_kind_byte_size (Bigarray.Array1.kind pixels)) in
  let pixels = to_voidp (bigarray_start array1 pixels) in 
  update_texture t (Rect.opt_addr rect) pixels pitch
  
let update_yuv_texture = 
  foreign "SDL_UpdateYUVTexture" 
    (texture @-> ptr rect @-> 
     ptr void @-> int @-> ptr void @-> int @-> ptr void @-> int @-> 
     returning zero_to_ok)

let update_yuv_texture r rect ~y ypitch ~u upitch ~v vpitch = 
  let yp = to_voidp (bigarray_start array1 y) in 
  let up = to_voidp (bigarray_start array1 u) in 
  let vp = to_voidp (bigarray_start array1 v) in 
  update_yuv_texture r (Rect.opt_addr rect) yp ypitch up upitch vp vpitch

(* Video drivers *)

let get_current_video_driver = 
  foreign "SDL_GetCurrentVideoDriver" (void @-> returning string_opt)

let get_num_video_drivers =
  foreign "SDL_GetNumVideoDrivers" (void @-> returning nat_to_ok)

let get_video_driver = 
  foreign "SDL_GetVideoDriver" (int @-> returning (some_to_ok string_opt))

let video_init = 
  foreign "SDL_VideoInit" (string_opt @-> returning zero_to_ok)

let video_quit = 
  foreign "SDL_VideoQuit" (void @-> returning void)

(* Displays *) 

type driverdata = unit ptr
let driverdata = ptr_opt void

type display_mode = 
  { dm_format : Pixel.format_enum; 
    dm_w : int; 
    dm_h : int; 
    dm_refresh_rate : int option; 
    dm_driverdata : driverdata option }

type _display_mode 
let display_mode : _display_mode structure typ = structure "SDL_DisplayMode"
let dm_format = field display_mode "format" uint32_t
let dm_w = field display_mode "w" int
let dm_h = field display_mode "h" int
let dm_refresh_rate = field display_mode "refresh_rate" int
let dm_driverdata = field display_mode "driverdata" driverdata
let () = seal display_mode

let display_mode_to_c o = 
  let c = make display_mode in 
  let rate = match o.dm_refresh_rate with None -> 0 | Some r -> r in
  setf c dm_format o.dm_format; 
  setf c dm_w o.dm_w; 
  setf c dm_h o.dm_h; 
  setf c dm_refresh_rate rate; 
  setf c dm_driverdata o.dm_driverdata;
  c

let display_mode_of_c c =
  let dm_format = getf c dm_format in 
  let dm_w = getf c dm_w in 
  let dm_h = getf c dm_h in 
  let dm_refresh_rate = match getf c dm_refresh_rate with 
  | 0 -> None | r -> Some r
  in 
  let dm_driverdata = getf c dm_driverdata in 
  { dm_format; dm_w; dm_h; dm_refresh_rate; dm_driverdata }

let get_closest_display_mode = 
  foreign "SDL_GetClosestDisplayMode" 
    (int @-> ptr display_mode @-> ptr display_mode @-> 
       returning (ptr_opt void))

let get_closest_display_mode i m = 
  let mode = display_mode_to_c m in 
  let closest = make display_mode in 
  match get_closest_display_mode i (addr mode) (addr closest) with 
  | None -> None 
  | Some _ -> Some (display_mode_of_c closest)

let get_current_display_mode = 
  foreign "SDL_GetCurrentDisplayMode" 
    (int @-> ptr display_mode @-> returning zero_to_ok)

let get_current_display_mode i =
  let mode = make display_mode in 
  match get_current_display_mode i (addr mode) with 
  | `Ok () -> `Ok (display_mode_of_c mode) | `Error _ as e -> e

let get_desktop_display_mode = 
  foreign "SDL_GetDesktopDisplayMode" 
    (int @-> ptr display_mode @-> returning zero_to_ok)

let get_desktop_display_mode i =
  let mode = make display_mode in 
  match get_desktop_display_mode i (addr mode) with 
  | `Ok () -> `Ok (display_mode_of_c mode) | `Error _ as e -> e

let get_display_bounds = 
  foreign "SDL_GetDisplayBounds" 
    (int @-> ptr rect @-> returning zero_to_ok) 
    
let get_display_bounds i = 
  let r = make rect in
  match get_display_bounds i (addr r) with 
  | `Ok () -> `Ok r | `Error _ as e -> e 
  
let get_display_mode = 
  foreign "SDL_GetDisplayMode"
    (int @-> int @-> ptr display_mode @-> returning zero_to_ok)

let get_display_mode d i =
  let mode = make display_mode in
  match get_display_mode d i (addr mode) with
  | `Ok () -> `Ok (display_mode_of_c mode) | `Error _ as e -> e

let get_num_display_modes = 
  foreign "SDL_GetNumDisplayModes" (int @-> returning nat_to_ok)

let get_display_name =
  foreign "SDL_GetDisplayName" (int @-> returning (some_to_ok string_opt))

let get_num_video_displays = 
  foreign "SDL_GetNumVideoDisplays" (void @-> returning nat_to_ok)

(* Windows *)

module Window = struct
  let pos_undefined = sdl_windowpos_undefined
  let pos_centered = sdl_windowpos_centered

  type flags = Unsigned.uint32
  let i = Unsigned.UInt32.of_int
  let ( + ) = Unsigned.UInt32.logor
  let test f m = Unsigned.UInt32.(compare (logand f m) zero <> 0)
  let eq f f' = Unsigned.UInt32.(compare f f' = 0)
  let windowed = i 0 
  let fullscreen = i sdl_window_fullscreen
  let fullscreen_desktop = i sdl_window_fullscreen_desktop
  let opengl = i sdl_window_opengl
  let shown = i sdl_window_shown
  let shown = i sdl_window_shown
  let hidden = i sdl_window_hidden
  let borderless = i sdl_window_borderless
  let resizable = i sdl_window_resizable
  let minimized = i sdl_window_minimized
  let maximized = i sdl_window_maximized
  let input_grabbed = i sdl_window_input_grabbed
  let input_focus = i sdl_window_input_focus
  let mouse_focus = i sdl_window_mouse_focus
  let foreign = i sdl_window_foreign
end

let create_window = 
  foreign "SDL_CreateWindow" 
    (string @-> int @-> int @-> int @-> int @-> uint32_t @-> 
     returning (some_to_ok window_opt))

let create_window t ?(x = Window.pos_undefined) ?(y = Window.pos_undefined) 
    ~w ~h flags = create_window t x y w h flags

let create_window_and_renderer =
  foreign "SDL_CreateWindowAndRenderer"
    (int @-> int @-> uint32_t @-> ptr window @-> ptr renderer @-> 
     (returning zero_to_ok))

let create_window_and_renderer ~w ~h flags =
  let win = allocate window null in 
  let r = allocate renderer null in
  match create_window_and_renderer w h flags win r with 
  | `Ok () -> `Ok (!@ win, !@ r) | `Error _ as e -> e

let destroy_window =
  foreign "SDL_DestroyWindow" (window @-> returning void)
      
let get_window_brightness = 
  foreign "SDL_GetWindowBrightness" (window @-> returning float)

let get_window_display_index = 
  foreign "SDL_GetWindowDisplayIndex" (window @-> returning nat_to_ok)
    
let get_window_display_mode = 
  foreign "SDL_GetWindowDisplayMode" 
    (window @-> (ptr display_mode) @-> returning int)

let get_window_display_mode w = 
  let mode = make display_mode in 
  match get_window_display_mode w (addr mode) with 
  | 0 -> `Ok (display_mode_of_c mode) | err -> error ()
                                                 
let get_window_flags = 
  foreign "SDL_GetWindowFlags" (window @-> returning uint32_t)

let get_window_from_id = 
  foreign "SDL_GetWindowFromID" 
    (int_as_uint32_t @-> returning (some_to_ok window_opt))

let get_window_gamma_ramp =
  foreign "SDL_GetWindowGammaRamp" 
    (window @-> ptr void @-> ptr void @-> ptr void @-> returning zero_to_ok)

let get_window_gamma_ramp w = 
  let create_ramp () = ba_create Bigarray.int16_unsigned 256 in
  let r, g, b = create_ramp (), create_ramp (), create_ramp () in 
  let ramp_ptr r = to_voidp (bigarray_start array1 r) in
  match get_window_gamma_ramp w (ramp_ptr r) (ramp_ptr g) (ramp_ptr b) with 
  | `Ok () -> `Ok (r, g, b) | `Error _ as e -> e

let get_window_grab = 
  foreign "SDL_GetWindowGrab" (window @-> returning bool)

let get_window_id = 
  foreign "SDL_GetWindowID" (window @-> returning int_as_uint32_t)

let get_window_maximum_size = 
  foreign "SDL_GetWindowMaximumSize" 
    (window @-> (ptr int) @-> (ptr int) @-> returning void)

let get_window_maximum_size win = 
  let w = allocate int 0 in 
  let h = allocate int 0 in
  get_window_maximum_size win w h; 
  !@ w, !@ h

let get_window_minimum_size = 
  foreign "SDL_GetWindowMinimumSize" 
    (window @-> (ptr int) @-> (ptr int) @-> returning void)
    
let get_window_minimum_size win = 
  let w = allocate int 0 in 
  let h = allocate int 0 in
  get_window_minimum_size win w h; 
  !@ w, !@ h
    
let get_window_pixel_format = 
  foreign "SDL_GetWindowPixelFormat" (window @-> returning uint32_t)
    
let get_window_position = 
  foreign "SDL_GetWindowPosition" 
    (window @-> (ptr int) @-> (ptr int) @-> returning void)

let get_window_position win = 
  let x = allocate int 0 in 
  let y = allocate int 0 in
  get_window_position win x y; 
  !@ x, !@ y

let get_window_size = 
  foreign "SDL_GetWindowSize" 
    (window @-> (ptr int) @-> (ptr int) @-> returning void)

let get_window_size win = 
  let w = allocate int 0 in 
  let h = allocate int 0 in
  get_window_size win w h; 
  !@ w, !@ h

let get_window_surface = 
  foreign "SDL_GetWindowSurface"
    (window @-> returning (some_to_ok surface_opt))

let get_window_title = 
  foreign "SDL_GetWindowTitle" (window @-> returning string)

let hide_window = 
  foreign "SDL_HideWindow" (window @-> returning void)

let maximize_window = 
  foreign "SDL_MaximizeWindow" (window @-> returning void)

let minimize_window = 
  foreign "SDL_MinimizeWindow" (window @-> returning void)

let raise_window = 
  foreign "SDL_RaiseWindow" (window @-> returning void)

let restore_window = 
  foreign "SDL_RestoreWindow" (window @-> returning void)

let set_window_bordered = 
  foreign "SDL_SetWindowBordered" (window @-> bool @-> returning void)

let set_window_brightness = 
  foreign "SDL_SetWindowBrightness" 
    (window @-> float @-> returning zero_to_ok)

let set_window_display_mode = 
  foreign "SDL_SetWindowDisplayMode" 
    (window @-> (ptr display_mode) @-> returning zero_to_ok)

let set_window_display_mode w m = 
  let mode = display_mode_to_c m in 
  set_window_display_mode w (addr mode)

let set_window_fullscreen = 
  foreign "SDL_SetWindowFullscreen" 
    (window @-> uint32_t @-> returning zero_to_ok)

let set_window_gamma_ramp = 
  foreign "SDL_SetWindowGammaRamp" 
    (window @-> ptr void @-> ptr void @-> ptr void @-> 
     returning zero_to_ok)

let set_window_gamma_ramp w r g b = 
  let ramp_ptr r = to_voidp (bigarray_start array1 r) in
  set_window_gamma_ramp w (ramp_ptr r) (ramp_ptr g) (ramp_ptr b) 

let set_window_grab = 
  foreign "SDL_SetWindowGrab" (window @-> bool @-> returning void)

let set_window_icon = 
  foreign "SDL_SetWindowIcon" (window @-> surface @-> returning void)

let set_window_maximum_size = 
  foreign "SDL_SetWindowMaximumSize"
    (window @-> int @-> int @-> returning void)

let set_window_maximum_size win ~w ~h = 
  set_window_maximum_size win w h

let set_window_minimum_size = 
  foreign "SDL_SetWindowMinimumSize" 
    (window @-> int @-> int @-> returning void)

let set_window_minimum_size win ~w ~h = 
  set_window_minimum_size win w h

let set_window_position = 
  foreign "SDL_SetWindowPosition" 
    (window @-> int @-> int @-> returning void)

let set_window_position win ~x ~y = 
  set_window_position win x y

let set_window_size = 
  foreign "SDL_SetWindowSize" (window @-> int @-> int @-> returning void)

let set_window_size win ~w ~h = 
  set_window_size win w h

let set_window_title =
  foreign "SDL_SetWindowTitle" (window @-> string @-> returning void)

let show_window = 
  foreign "SDL_ShowWindow" (window @-> returning void)

let update_window_surface = 
  foreign "SDL_UpdateWindowSurface" (window @-> returning zero_to_ok)

let update_window_surface_rects = 
  foreign "SDL_UpdateWindowSurfaceRects" 
    (window @-> ptr void @-> int @-> returning zero_to_ok)

let update_window_surface_rects_ba w rs =
  let len = Bigarray.Array1.dim rs in 
  if len mod 4 <> 0 then invalid_arg (err_length_mul len 4) else 
  let count = len / 4 in
  let rs = to_voidp (bigarray_start array1 rs) in
  update_window_surface_rects w rs count

let update_window_surface_rects w rs = 
  let count = List.length rs in 
  let rs = to_voidp (Array.start (Array.of_list rect rs)) in 
  update_window_surface_rects w rs count

(* OpenGL contexts *)

type gl_context = unit ptr
let gl_context : unit ptr typ = ptr void
let gl_context_opt : unit ptr option typ = ptr_opt void

module Gl = struct
  type context_flags = int
  let context_debug_flag = sdl_gl_context_debug_flag
  let context_forward_compatible_flag = sdl_gl_context_forward_compatible_flag
  let context_robust_access_flag = sdl_gl_context_robust_access_flag
  let context_reset_isolation_flag = sdl_gl_context_reset_isolation_flag

  type profile = int  
  let context_profile_core = sdl_gl_context_profile_core
  let context_profile_compatibility = sdl_gl_context_profile_compatibility
  let context_profile_es = sdl_gl_context_profile_es 

  type attr = int
  let red_size = sdl_gl_red_size
  let green_size = sdl_gl_green_size
  let blue_size = sdl_gl_blue_size
  let alpha_size = sdl_gl_alpha_size
  let buffer_size = sdl_gl_buffer_size
  let doublebuffer = sdl_gl_doublebuffer
  let depth_size = sdl_gl_depth_size
  let stencil_size = sdl_gl_stencil_size
  let accum_red_size = sdl_gl_accum_red_size
  let accum_green_size = sdl_gl_accum_green_size
  let accum_blue_size = sdl_gl_accum_blue_size
  let accum_alpha_size = sdl_gl_accum_alpha_size
  let stereo = sdl_gl_stereo
  let multisamplebuffers = sdl_gl_multisamplebuffers
  let multisamplesamples = sdl_gl_multisamplesamples
  let accelerated_visual = sdl_gl_accelerated_visual
  let context_major_version = sdl_gl_context_major_version
  let context_minor_version = sdl_gl_context_minor_version
  let context_egl = sdl_gl_context_egl
  let context_flags = sdl_gl_context_flags
  let context_profile_mask = sdl_gl_context_profile_mask
  let share_with_current_context = sdl_gl_share_with_current_context
  let framebuffer_srgb_capable = sdl_gl_framebuffer_srgb_capable
end

let gl_bind_texture = 
  foreign "SDL_GL_BindTexture" 
    (texture @-> ptr float @-> ptr float @-> returning zero_to_ok)

let gl_bind_texture t = 
  let w = allocate float 0. in 
  let h = allocate float 0. in 
  match gl_bind_texture t w h with 
  | `Ok () -> `Ok (!@ w, !@ h) | `Error _ as e -> e

let gl_create_context =
  foreign "SDL_GL_CreateContext" 
    (window @-> returning (some_to_ok gl_context_opt))

let gl_delete_context = 
  foreign "SDL_GL_DeleteContext" (gl_context @-> returning void)

let gl_extension_supported = 
  foreign "SDL_GL_ExtensionSupported" (string @-> returning bool)

let gl_get_attribute = 
  foreign "SDL_GL_GetAttribute" (int @-> (ptr int) @-> returning int)
  
let gl_get_attribute att = 
  let value = allocate int 0 in
  match gl_get_attribute att value with 
  | 0 -> `Ok (!@ value) | err -> error ()
  
let gl_get_current_context = 
  foreign "SDL_GL_GetCurrentContext" 
    (void @-> returning (some_to_ok gl_context_opt))

let gl_get_drawable_size = 
  foreign "SDL_GL_GetDrawableSize" 
    (window @-> ptr int @-> ptr int @-> returning void)

let gl_get_drawable_size win = 
  let w = allocate int 0 in 
  let h = allocate int 0 in 
  gl_get_drawable_size win w h; 
  (!@ w, !@ h)
  
let gl_get_swap_interval = 
  foreign "SDL_GL_GetSwapInterval" (void @-> returning nat_to_ok)

let gl_make_current = 
  foreign "SDL_GL_MakeCurrent" 
    (window @-> gl_context @-> returning zero_to_ok)
    
let gl_set_attribute = 
  foreign "SDL_GL_SetAttribute" (int @-> int @-> returning zero_to_ok)
    
let gl_set_swap_interval = 
  foreign "SDL_GL_SetSwapInterval" (int @-> returning zero_to_ok)
    
let gl_swap_window = 
  foreign "SDL_GL_SwapWindow" (window @-> returning void)

let gl_unbind_texture = 
  foreign "SDL_GL_UnbindTexture" (texture @-> returning zero_to_ok)

(* Screen saver *)

let disable_screen_saver = 
  foreign "SDL_DisableScreenSaver" (void @-> returning void)

let enable_screen_saver = 
  foreign "SDL_EnableScreenSaver" (void @-> returning void)

let is_screen_saver_enabled = 
  foreign "SDL_IsScreenSaverEnabled" (void @-> returning bool)

(* Message boxes *)

module Message_box = struct
  let i = Unsigned.UInt32.of_int

  type button_flags = Unsigned.uint32
  let button_returnkey_default = i sdl_messagebox_button_returnkey_default
  let button_escapekey_default = i sdl_messagebox_button_escapekey_default

  type button_data = 
    { button_flags : button_flags; 
      button_id : int;
      button_text : string } 

  let button_data = structure "SDL_MessageBoxButtonData"
  let button_flags = field button_data "flags" uint32_t
  let button_buttonid = field button_data "buttonid" int
  let button_text = field button_data "text" string
  let () = seal button_data
  
  type flags = Unsigned.uint32
  let error = i sdl_messagebox_error
  let warning = i sdl_messagebox_warning
  let information = i sdl_messagebox_information

  type color = int * int * int 
  let color = structure "SDL_MessageBoxColor" 
  let color_r = field color "r" uint8_t 
  let color_g = field color "g" uint8_t 
  let color_b = field color "b" uint8_t 
  let () = seal color
  
  type color_type = int
  let color_background = sdl_messagebox_color_background
  let color_text = sdl_messagebox_color_text
  let color_button_border = sdl_messagebox_color_button_border
  let color_button_background = sdl_messagebox_color_button_background
  let color_button_selected = sdl_messagebox_color_button_selected
  let color_button_max = sdl_messagebox_color_max

  type color_scheme = 
    { color_background : color;
      color_text : color; 
      color_button_border : color; 
      color_button_background : color; 
      color_button_selected : color; }

  let color_scheme = structure "SDL_MessageBoxColorScheme"
  let colors = field color_scheme "colors" (array color_button_max color)
  let () = seal color_scheme

  type data = 
    { flags : flags; 
      window : window option; 
      title : string; 
      message : string; 
      buttons : button_data list; 
      color_scheme : color_scheme option }

  let data = structure "SDL_MessageBoxData"
  let d_flags = field data "flags" uint32_t 
  let d_window = field data "window" window 
  let d_title = field data "title" string 
  let d_message = field data "message" string 
  let d_numbuttons = field data "numbuttons" int 
  let d_buttons = field data "buttons" (ptr button_data)
  let d_color_scheme = field data "colorScheme" (ptr color_scheme)
  let () = seal data

  let buttons_to_c bl = 
    let button_data_to_c b =
      let bt = make button_data in 
      setf bt button_flags b.button_flags; 
      setf bt button_buttonid b.button_id; 
      setf bt button_text b.button_text;
      bt
    in
    Array.start (Array.of_list button_data (List.map button_data_to_c bl))

  let color_scheme_to_c s =
    let st = make color_scheme in 
    let colors = getf st colors in
    let set i (rv, gv, bv) = 
      let ct = Array.get colors i in 
      setf ct color_r (Unsigned.UInt8.of_int rv); 
      setf ct color_g (Unsigned.UInt8.of_int rv); 
      setf ct color_b (Unsigned.UInt8.of_int rv); 
    in
    set color_background s.color_background;
    set color_text s.color_text;
    set color_button_border s.color_button_border;
    set color_button_background s.color_button_background;
    set color_button_selected s.color_button_selected;
    st

  let data_to_c d =
    let dt = make data in 
    setf dt d_flags d.flags; 
    setf dt d_window (match d.window with None -> null | Some w -> w);
    setf dt d_title d.title; 
    setf dt d_message d.message;
    setf dt d_numbuttons (List.length d.buttons); 
    setf dt d_buttons (buttons_to_c d.buttons); 
    setf dt d_color_scheme 
      begin match d.color_scheme with 
      | None -> coerce (ptr void) (ptr color_scheme) null
      | Some s -> addr (color_scheme_to_c s)
      end;
    dt
end

let show_message_box = 
  foreign "SDL_ShowMessageBox" 
    (ptr Message_box.data @-> ptr int @-> returning zero_to_ok)

let show_message_box d = 
  let d = addr (Message_box.data_to_c d) in 
  let ret = allocate int 0 in 
  match show_message_box d ret with 
  | `Ok () -> `Ok (!@ ret) | `Error _ as e -> e

let show_simple_message_box = 
  foreign "SDL_ShowSimpleMessageBox" 
    (uint32_t @-> string @-> string @-> window_opt @-> returning zero_to_ok)

let show_simple_message_box t ~title msg w =
  show_simple_message_box t title msg w 

(* Clipboard *)

let get_clipboard_text = 
  foreign "SDL_GetClipboardText" (void @-> returning (some_to_ok string_opt))

let has_clipboard_text = 
  foreign "SDL_HasClipboardText" (void @-> returning bool)

let set_clipboard_text = 
  foreign "SDL_SetClipboardText" (string @-> returning zero_to_ok)

(* Input *)

type button_state = uint8
let pressed = sdl_pressed 
let released = sdl_released

type toggle_state = uint8
let disable = sdl_disable
let enable = sdl_enable

(* Keyboard *)

type scancode = int
let scancode = int 

module Scancode = struct
  let num_scancodes = sdl_num_scancodes
  let unknown = sdl_scancode_unknown
  let a = sdl_scancode_a
  let b = sdl_scancode_b
  let c = sdl_scancode_c
  let d = sdl_scancode_d
  let e = sdl_scancode_e
  let f = sdl_scancode_f
  let g = sdl_scancode_g
  let h = sdl_scancode_h
  let i = sdl_scancode_i
  let j = sdl_scancode_j
  let k = sdl_scancode_k
  let l = sdl_scancode_l
  let m = sdl_scancode_m
  let n = sdl_scancode_n
  let o = sdl_scancode_o
  let p = sdl_scancode_p
  let q = sdl_scancode_q
  let r = sdl_scancode_r
  let s = sdl_scancode_s
  let t = sdl_scancode_t
  let u = sdl_scancode_u
  let v = sdl_scancode_v
  let w = sdl_scancode_w
  let x = sdl_scancode_x
  let y = sdl_scancode_y
  let z = sdl_scancode_z
  let k1 = sdl_scancode_1
  let k2 = sdl_scancode_2
  let k3 = sdl_scancode_3
  let k4 = sdl_scancode_4
  let k5 = sdl_scancode_5
  let k6 = sdl_scancode_6
  let k7 = sdl_scancode_7
  let k8 = sdl_scancode_8
  let k9 = sdl_scancode_9
  let k0 = sdl_scancode_0
  let return = sdl_scancode_return
  let escape = sdl_scancode_escape
  let backspace = sdl_scancode_backspace
  let tab = sdl_scancode_tab
  let space = sdl_scancode_space
  let minus = sdl_scancode_minus
  let equals = sdl_scancode_equals
  let leftbracket = sdl_scancode_leftbracket
  let rightbracket = sdl_scancode_rightbracket
  let backslash = sdl_scancode_backslash
  let nonushash = sdl_scancode_nonushash
  let semicolon = sdl_scancode_semicolon
  let apostrophe = sdl_scancode_apostrophe
  let grave = sdl_scancode_grave
  let comma = sdl_scancode_comma
  let period = sdl_scancode_period
  let slash = sdl_scancode_slash
  let capslock = sdl_scancode_capslock
  let f1 = sdl_scancode_f1
  let f2 = sdl_scancode_f2
  let f3 = sdl_scancode_f3
  let f4 = sdl_scancode_f4
  let f5 = sdl_scancode_f5
  let f6 = sdl_scancode_f6
  let f7 = sdl_scancode_f7
  let f8 = sdl_scancode_f8
  let f9 = sdl_scancode_f9
  let f10 = sdl_scancode_f10
  let f11 = sdl_scancode_f11
  let f12 = sdl_scancode_f12
  let printscreen = sdl_scancode_printscreen
  let scrolllock = sdl_scancode_scrolllock
  let pause = sdl_scancode_pause
  let insert = sdl_scancode_insert
  let home = sdl_scancode_home
  let pageup = sdl_scancode_pageup
  let delete = sdl_scancode_delete
  let kend = sdl_scancode_end
  let pagedown = sdl_scancode_pagedown
  let right = sdl_scancode_right
  let left = sdl_scancode_left
  let down = sdl_scancode_down
  let up = sdl_scancode_up
  let numlockclear = sdl_scancode_numlockclear
  let kp_divide = sdl_scancode_kp_divide
  let kp_multiply = sdl_scancode_kp_multiply
  let kp_minus = sdl_scancode_kp_minus
  let kp_plus = sdl_scancode_kp_plus
  let kp_enter = sdl_scancode_kp_enter
  let kp_1 = sdl_scancode_kp_1
  let kp_2 = sdl_scancode_kp_2
  let kp_3 = sdl_scancode_kp_3
  let kp_4 = sdl_scancode_kp_4
  let kp_5 = sdl_scancode_kp_5
  let kp_6 = sdl_scancode_kp_6
  let kp_7 = sdl_scancode_kp_7
  let kp_8 = sdl_scancode_kp_8
  let kp_9 = sdl_scancode_kp_9
  let kp_0 = sdl_scancode_kp_0
  let kp_period = sdl_scancode_kp_period
  let nonusbackslash = sdl_scancode_nonusbackslash
  let application = sdl_scancode_application
  let kp_equals = sdl_scancode_kp_equals
  let f13 = sdl_scancode_f13
  let f14 = sdl_scancode_f14
  let f15 = sdl_scancode_f15
  let f16 = sdl_scancode_f16
  let f17 = sdl_scancode_f17
  let f18 = sdl_scancode_f18
  let f19 = sdl_scancode_f19
  let f20 = sdl_scancode_f20
  let f21 = sdl_scancode_f21
  let f22 = sdl_scancode_f22
  let f23 = sdl_scancode_f23
  let f24 = sdl_scancode_f24
  let execute = sdl_scancode_execute
  let help = sdl_scancode_help
  let menu = sdl_scancode_menu
  let select = sdl_scancode_select
  let stop = sdl_scancode_stop
  let again = sdl_scancode_again
  let undo = sdl_scancode_undo
  let cut = sdl_scancode_cut
  let copy = sdl_scancode_copy
  let paste = sdl_scancode_paste
  let find = sdl_scancode_find
  let mute = sdl_scancode_mute
  let volumeup = sdl_scancode_volumeup
  let volumedown = sdl_scancode_volumedown
  let kp_comma = sdl_scancode_kp_comma
  let kp_equalsas400 = sdl_scancode_kp_equalsas400
  let international1 = sdl_scancode_international1
  let international2 = sdl_scancode_international2
  let international3 = sdl_scancode_international3
  let international4 = sdl_scancode_international4
  let international5 = sdl_scancode_international5
  let international6 = sdl_scancode_international6
  let international7 = sdl_scancode_international7
  let international8 = sdl_scancode_international8
  let international9 = sdl_scancode_international9
  let lang1 = sdl_scancode_lang1
  let lang2 = sdl_scancode_lang2
  let lang3 = sdl_scancode_lang3
  let lang4 = sdl_scancode_lang4
  let lang5 = sdl_scancode_lang5
  let lang6 = sdl_scancode_lang6
  let lang7 = sdl_scancode_lang7
  let lang8 = sdl_scancode_lang8
  let lang9 = sdl_scancode_lang9
  let alterase = sdl_scancode_alterase
  let sysreq = sdl_scancode_sysreq
  let cancel = sdl_scancode_cancel
  let clear = sdl_scancode_clear
  let prior = sdl_scancode_prior
  let return2 = sdl_scancode_return2
  let separator = sdl_scancode_separator
  let out = sdl_scancode_out
  let oper = sdl_scancode_oper
  let clearagain = sdl_scancode_clearagain
  let crsel = sdl_scancode_crsel
  let exsel = sdl_scancode_exsel
  let kp_00 = sdl_scancode_kp_00
  let kp_000 = sdl_scancode_kp_000
  let thousandsseparator = sdl_scancode_thousandsseparator
  let decimalseparator = sdl_scancode_decimalseparator
  let currencyunit = sdl_scancode_currencyunit
  let currencysubunit = sdl_scancode_currencysubunit
  let kp_leftparen = sdl_scancode_kp_leftparen
  let kp_rightparen = sdl_scancode_kp_rightparen
  let kp_leftbrace = sdl_scancode_kp_leftbrace
  let kp_rightbrace = sdl_scancode_kp_rightbrace
  let kp_tab = sdl_scancode_kp_tab
  let kp_backspace = sdl_scancode_kp_backspace
  let kp_a = sdl_scancode_kp_a
  let kp_b = sdl_scancode_kp_b
  let kp_c = sdl_scancode_kp_c
  let kp_d = sdl_scancode_kp_d
  let kp_e = sdl_scancode_kp_e
  let kp_f = sdl_scancode_kp_f
  let kp_xor = sdl_scancode_kp_xor
  let kp_power = sdl_scancode_kp_power
  let kp_percent = sdl_scancode_kp_percent
  let kp_less = sdl_scancode_kp_less
  let kp_greater = sdl_scancode_kp_greater
  let kp_ampersand = sdl_scancode_kp_ampersand
  let kp_dblampersand = sdl_scancode_kp_dblampersand
  let kp_verticalbar = sdl_scancode_kp_verticalbar
  let kp_dblverticalbar = sdl_scancode_kp_dblverticalbar
  let kp_colon = sdl_scancode_kp_colon
  let kp_hash = sdl_scancode_kp_hash
  let kp_space = sdl_scancode_kp_space
  let kp_at = sdl_scancode_kp_at
  let kp_exclam = sdl_scancode_kp_exclam
  let kp_memstore = sdl_scancode_kp_memstore
  let kp_memrecall = sdl_scancode_kp_memrecall
  let kp_memclear = sdl_scancode_kp_memclear
  let kp_memadd = sdl_scancode_kp_memadd
  let kp_memsubtract = sdl_scancode_kp_memsubtract
  let kp_memmultiply = sdl_scancode_kp_memmultiply
  let kp_memdivide = sdl_scancode_kp_memdivide
  let kp_plusminus = sdl_scancode_kp_plusminus
  let kp_clear = sdl_scancode_kp_clear
  let kp_clearentry = sdl_scancode_kp_clearentry
  let kp_binary = sdl_scancode_kp_binary
  let kp_octal = sdl_scancode_kp_octal
  let kp_decimal = sdl_scancode_kp_decimal
  let kp_hexadecimal = sdl_scancode_kp_hexadecimal
  let lctrl = sdl_scancode_lctrl
  let lshift = sdl_scancode_lshift
  let lalt = sdl_scancode_lalt
  let lgui = sdl_scancode_lgui
  let rctrl = sdl_scancode_rctrl
  let rshift = sdl_scancode_rshift
  let ralt = sdl_scancode_ralt
  let rgui = sdl_scancode_rgui
  let mode = sdl_scancode_mode
  let audionext = sdl_scancode_audionext
  let audioprev = sdl_scancode_audioprev
  let audiostop = sdl_scancode_audiostop
  let audioplay = sdl_scancode_audioplay
  let audiomute = sdl_scancode_audiomute
  let mediaselect = sdl_scancode_mediaselect
  let www = sdl_scancode_www
  let mail = sdl_scancode_mail
  let calculator = sdl_scancode_calculator
  let computer = sdl_scancode_computer
  let ac_search = sdl_scancode_ac_search
  let ac_home = sdl_scancode_ac_home
  let ac_back = sdl_scancode_ac_back
  let ac_forward = sdl_scancode_ac_forward
  let ac_stop = sdl_scancode_ac_stop
  let ac_refresh = sdl_scancode_ac_refresh
  let ac_bookmarks = sdl_scancode_ac_bookmarks
  let brightnessdown = sdl_scancode_brightnessdown
  let brightnessup = sdl_scancode_brightnessup
  let displayswitch = sdl_scancode_displayswitch
  let kbdillumtoggle = sdl_scancode_kbdillumtoggle
  let kbdillumdown = sdl_scancode_kbdillumdown
  let kbdillumup = sdl_scancode_kbdillumup
  let eject = sdl_scancode_eject
  let sleep = sdl_scancode_sleep
  let app1 = sdl_scancode_app1
  let app2 = sdl_scancode_app2
    
  let enum_of_scancode = [| 
    `Unknown; `Unknown; `Unknown; `Unknown; `A; `B; `C; `D; `E; `F;
    `G; `H; `I; `J; `K; `L; `M; `N; `O; `P; `Q; `R; `S; `T; `U; `V;
    `W; `X; `Y; `Z; `K1; `K2; `K3; `K4; `K5; `K6; `K7; `K8; `K9; `K0;
    `Return; `Escape; `Backspace; `Tab; `Space; `Minus; `Equals;
    `Leftbracket; `Rightbracket; `Backslash; `Nonushash; `Semicolon;
    `Apostrophe; `Grave; `Comma; `Period; `Slash; `Capslock; `F1; `F2;
    `F3; `F4; `F5; `F6; `F7; `F8; `F9; `F10; `F11; `F12; `Printscreen;
    `Scrolllock; `Pause; `Insert; `Home; `Pageup; `Delete; `End;
    `Pagedown; `Right; `Left; `Down; `Up; `Numlockclear; `Kp_divide;
    `Kp_multiply; `Kp_minus; `Kp_plus; `Kp_enter; `Kp_1; `Kp_2; `Kp_3;
    `Kp_4; `Kp_5; `Kp_6; `Kp_7; `Kp_8; `Kp_9; `Kp_0; `Kp_period;
    `Nonusbackslash; `Application; `Power; `Kp_equals; `F13; `F14;
    `F15; `F16; `F17; `F18; `F19; `F20; `F21; `F22; `F23; `F24;
    `Execute; `Help; `Menu; `Select; `Stop; `Again; `Undo; `Cut;
    `Copy; `Paste; `Find; `Mute; `Volumeup; `Volumedown; `Unknown;
    `Unknown; `Unknown; `Kp_comma; `Kp_equalsas400; `International1;
    `International2; `International3; `International4;
    `International5; `International6; `International7;
    `International8; `International9; `Lang1; `Lang2; `Lang3; `Lang4;
    `Lang5; `Lang6; `Lang7; `Lang8; `Lang9; `Alterase; `Sysreq;
    `Cancel; `Clear; `Prior; `Return2; `Separator; `Out; `Oper;
    `Clearagain; `Crsel; `Exsel; `Unknown; `Unknown; `Unknown;
    `Unknown; `Unknown; `Unknown; `Unknown; `Unknown; `Unknown;
    `Unknown; `Unknown; `Kp_00; `Kp_000; `Thousandsseparator;
    `Decimalseparator; `Currencyunit; `Currencysubunit; `Kp_leftparen;
    `Kp_rightparen; `Kp_leftbrace; `Kp_rightbrace; `Kp_tab;
    `Kp_backspace; `Kp_a; `Kp_b; `Kp_c; `Kp_d; `Kp_e; `Kp_f; `Kp_xor;
    `Kp_power; `Kp_percent; `Kp_less; `Kp_greater; `Kp_ampersand;
    `Kp_dblampersand; `Kp_verticalbar; `Kp_dblverticalbar; `Kp_colon;
    `Kp_hash; `Kp_space; `Kp_at; `Kp_exclam; `Kp_memstore;
    `Kp_memrecall; `Kp_memclear; `Kp_memadd; `Kp_memsubtract;
    `Kp_memmultiply; `Kp_memdivide; `Kp_plusminus; `Kp_clear;
    `Kp_clearentry; `Kp_binary; `Kp_octal; `Kp_decimal;
    `Kp_hexadecimal; `Unknown; `Unknown; `Lctrl; `Lshift; `Lalt;
    `Lgui; `Rctrl; `Rshift; `Ralt; `Rgui; `Unknown; `Unknown;
    `Unknown; `Unknown; `Unknown; `Unknown; `Unknown; `Unknown;
    `Unknown; `Unknown; `Unknown; `Unknown; `Unknown; `Unknown;
    `Unknown; `Unknown; `Unknown; `Unknown; `Unknown; `Unknown;
    `Unknown; `Unknown; `Unknown; `Unknown; `Unknown; `Mode;
    `Audionext; `Audioprev; `Audiostop; `Audioplay; `Audiomute;
    `Mediaselect; `Www; `Mail; `Calculator; `Computer; `Ac_search;
    `Ac_home; `Ac_back; `Ac_forward; `Ac_stop; `Ac_refresh;
    `Ac_bookmarks; `Brightnessdown; `Brightnessup; `Displayswitch;
    `Kbdillumtoggle; `Kbdillumdown; `Kbdillumup; `Eject; `Sleep;
    `App1; `App2; |]

  let enum s = 
    if 0 <= s && s <= app2 then unsafe_get enum_of_scancode s else 
    `Unknown 
end

type keycode = int32
let keycode = int32_t

module K = struct
  let unknown = sdlk_unknown
  let return = sdlk_return
  let escape = sdlk_escape
  let backspace = sdlk_backspace
  let tab = sdlk_tab
  let space = sdlk_space
  let exclaim = sdlk_exclaim
  let quotedbl = sdlk_quotedbl
  let hash = sdlk_hash
  let percent = sdlk_percent
  let dollar = sdlk_dollar
  let ampersand = sdlk_ampersand
  let quote = sdlk_quote
  let leftparen = sdlk_leftparen
  let rightparen = sdlk_rightparen
  let asterisk = sdlk_asterisk
  let plus = sdlk_plus
  let comma = sdlk_comma
  let minus = sdlk_minus
  let period = sdlk_period
  let slash = sdlk_slash
  let k0 = sdlk_0
  let k1 = sdlk_1
  let k2 = sdlk_2
  let k3 = sdlk_3
  let k4 = sdlk_4
  let k5 = sdlk_5
  let k6 = sdlk_6
  let k7 = sdlk_7
  let k8 = sdlk_8
  let k9 = sdlk_9
  let colon = sdlk_colon
  let semicolon = sdlk_semicolon
  let less = sdlk_less
  let equals = sdlk_equals
  let greater = sdlk_greater
  let question = sdlk_question
  let at = sdlk_at
  let leftbracket = sdlk_leftbracket
  let backslash = sdlk_backslash
  let rightbracket = sdlk_rightbracket
  let caret = sdlk_caret
  let underscore = sdlk_underscore
  let backquote = sdlk_backquote
  let a = sdlk_a
  let b = sdlk_b
  let c = sdlk_c
  let d = sdlk_d
  let e = sdlk_e
  let f = sdlk_f
  let g = sdlk_g
  let h = sdlk_h
  let i = sdlk_i
  let j = sdlk_j
  let k = sdlk_k
  let l = sdlk_l
  let m = sdlk_m
  let n = sdlk_n
  let o = sdlk_o
  let p = sdlk_p
  let q = sdlk_q
  let r = sdlk_r
  let s = sdlk_s
  let t = sdlk_t
  let u = sdlk_u
  let v = sdlk_v
  let w = sdlk_w
  let x = sdlk_x
  let y = sdlk_y
  let z = sdlk_z
  let capslock = sdlk_capslock
  let f1 = sdlk_f1
  let f2 = sdlk_f2
  let f3 = sdlk_f3
  let f4 = sdlk_f4
  let f5 = sdlk_f5
  let f6 = sdlk_f6
  let f7 = sdlk_f7
  let f8 = sdlk_f8
  let f9 = sdlk_f9
  let f10 = sdlk_f10
  let f11 = sdlk_f11
  let f12 = sdlk_f12
  let printscreen = sdlk_printscreen
  let scrolllock = sdlk_scrolllock
  let pause = sdlk_pause
  let insert = sdlk_insert
  let home = sdlk_home
  let pageup = sdlk_pageup
  let delete = sdlk_delete
  let kend = sdlk_end
  let pagedown = sdlk_pagedown
  let right = sdlk_right
  let left = sdlk_left
  let down = sdlk_down
  let up = sdlk_up
  let numlockclear = sdlk_numlockclear
  let kp_divide = sdlk_kp_divide
  let kp_multiply = sdlk_kp_multiply
  let kp_minus = sdlk_kp_minus
  let kp_plus = sdlk_kp_plus
  let kp_enter = sdlk_kp_enter
  let kp_1 = sdlk_kp_1
  let kp_2 = sdlk_kp_2
  let kp_3 = sdlk_kp_3
  let kp_4 = sdlk_kp_4
  let kp_5 = sdlk_kp_5
  let kp_6 = sdlk_kp_6
  let kp_7 = sdlk_kp_7
  let kp_8 = sdlk_kp_8
  let kp_9 = sdlk_kp_9
  let kp_0 = sdlk_kp_0
  let kp_period = sdlk_kp_period
  let application = sdlk_application
  let power = sdlk_power
  let kp_equals = sdlk_kp_equals
  let f13 = sdlk_f13
  let f14 = sdlk_f14
  let f15 = sdlk_f15
  let f16 = sdlk_f16
  let f17 = sdlk_f17
  let f18 = sdlk_f18
  let f19 = sdlk_f19
  let f20 = sdlk_f20
  let f21 = sdlk_f21
  let f22 = sdlk_f22
  let f23 = sdlk_f23
  let f24 = sdlk_f24
  let execute = sdlk_execute
  let help = sdlk_help
  let menu = sdlk_menu
  let select = sdlk_select
  let stop = sdlk_stop
  let again = sdlk_again
  let undo = sdlk_undo
  let cut = sdlk_cut
  let copy = sdlk_copy
  let paste = sdlk_paste
  let find = sdlk_find
  let mute = sdlk_mute
  let volumeup = sdlk_volumeup
  let volumedown = sdlk_volumedown
  let kp_comma = sdlk_kp_comma
  let kp_equalsas400 = sdlk_kp_equalsas400
  let alterase = sdlk_alterase
  let sysreq = sdlk_sysreq
  let cancel = sdlk_cancel
  let clear = sdlk_clear
  let prior = sdlk_prior
  let return2 = sdlk_return2
  let separator = sdlk_separator
  let out = sdlk_out
  let oper = sdlk_oper
  let clearagain = sdlk_clearagain
  let crsel = sdlk_crsel
  let exsel = sdlk_exsel
  let kp_00 = sdlk_kp_00
  let kp_000 = sdlk_kp_000
  let thousandsseparator = sdlk_thousandsseparator
  let decimalseparator = sdlk_decimalseparator
  let currencyunit = sdlk_currencyunit
  let currencysubunit = sdlk_currencysubunit
  let kp_leftparen = sdlk_kp_leftparen
  let kp_rightparen = sdlk_kp_rightparen
  let kp_leftbrace = sdlk_kp_leftbrace
  let kp_rightbrace = sdlk_kp_rightbrace
  let kp_tab = sdlk_kp_tab
  let kp_backspace = sdlk_kp_backspace
  let kp_a = sdlk_kp_a
  let kp_b = sdlk_kp_b
  let kp_c = sdlk_kp_c
  let kp_d = sdlk_kp_d
  let kp_e = sdlk_kp_e
  let kp_f = sdlk_kp_f
  let kp_xor = sdlk_kp_xor
  let kp_power = sdlk_kp_power
  let kp_percent = sdlk_kp_percent
  let kp_less = sdlk_kp_less
  let kp_greater = sdlk_kp_greater
  let kp_ampersand = sdlk_kp_ampersand
  let kp_dblampersand = sdlk_kp_dblampersand
  let kp_verticalbar = sdlk_kp_verticalbar
  let kp_dblverticalbar = sdlk_kp_dblverticalbar
  let kp_colon = sdlk_kp_colon
  let kp_hash = sdlk_kp_hash
  let kp_space = sdlk_kp_space
  let kp_at = sdlk_kp_at
  let kp_exclam = sdlk_kp_exclam
  let kp_memstore = sdlk_kp_memstore
  let kp_memrecall = sdlk_kp_memrecall
  let kp_memclear = sdlk_kp_memclear
  let kp_memadd = sdlk_kp_memadd
  let kp_memsubtract = sdlk_kp_memsubtract
  let kp_memmultiply = sdlk_kp_memmultiply
  let kp_memdivide = sdlk_kp_memdivide
  let kp_plusminus = sdlk_kp_plusminus
  let kp_clear = sdlk_kp_clear
  let kp_clearentry = sdlk_kp_clearentry
  let kp_binary = sdlk_kp_binary
  let kp_octal = sdlk_kp_octal
  let kp_decimal = sdlk_kp_decimal
  let kp_hexadecimal = sdlk_kp_hexadecimal
  let lctrl = sdlk_lctrl
  let lshift = sdlk_lshift
  let lalt = sdlk_lalt
  let lgui = sdlk_lgui
  let rctrl = sdlk_rctrl
  let rshift = sdlk_rshift
  let ralt = sdlk_ralt
  let rgui = sdlk_rgui
  let mode = sdlk_mode
  let audionext = sdlk_audionext
  let audioprev = sdlk_audioprev
  let audiostop = sdlk_audiostop
  let audioplay = sdlk_audioplay
  let audiomute = sdlk_audiomute
  let mediaselect = sdlk_mediaselect
  let www = sdlk_www
  let mail = sdlk_mail
  let calculator = sdlk_calculator
  let computer = sdlk_computer
  let ac_search = sdlk_ac_search
  let ac_home = sdlk_ac_home
  let ac_back = sdlk_ac_back
  let ac_forward = sdlk_ac_forward
  let ac_stop = sdlk_ac_stop
  let ac_refresh = sdlk_ac_refresh
  let ac_bookmarks = sdlk_ac_bookmarks
  let brightnessdown = sdlk_brightnessdown
  let brightnessup = sdlk_brightnessup
  let displayswitch = sdlk_displayswitch
  let kbdillumtoggle = sdlk_kbdillumtoggle
  let kbdillumdown = sdlk_kbdillumdown
  let kbdillumup = sdlk_kbdillumup
  let eject = sdlk_eject
  let sleep = sdlk_sleep
end

type keymod = int
let keymod = int_as_uint16_t

module Kmod = struct
  let none = kmod_none
  let lshift = kmod_lshift
  let rshift = kmod_rshift
  let lctrl = kmod_lctrl
  let rctrl = kmod_rctrl
  let lalt = kmod_lalt
  let ralt = kmod_ralt
  let lgui = kmod_lgui
  let rgui = kmod_rgui
  let num = kmod_num
  let caps = kmod_caps
  let mode = kmod_mode
  let reserved = kmod_reserved
  let ctrl = kmod_ctrl
  let shift = kmod_shift
  let alt = kmod_alt
  let gui = kmod_gui
end

let get_keyboard_focus = 
  foreign "SDL_GetKeyboardFocus" (void @-> returning window_opt)

let get_keyboard_state = 
  foreign "SDL_GetKeyboardState" (ptr int @-> returning (ptr int))

let get_keyboard_state () = 
  let count = allocate int 0 in 
  let p = get_keyboard_state count in 
  bigarray_of_ptr array1 (!@ count) Bigarray.int8_unsigned p 

let get_key_from_name = 
  foreign "SDL_GetKeyFromName" (string @-> returning keycode)

let get_key_from_scancode = 
  foreign "SDL_GetKeyFromScancode" (scancode @-> returning keycode)

let get_key_name = 
  foreign "SDL_GetKeyName" (keycode @-> returning string)

let get_mod_state = 
  foreign "SDL_GetModState" (void @-> returning keymod)

let get_scancode_from_key = 
  foreign "SDL_GetScancodeFromKey" (keycode @-> returning scancode)

let get_scancode_from_name = 
  foreign "SDL_GetScancodeFromName" (string @-> returning scancode)

let get_scancode_name = 
  foreign "SDL_GetScancodeName" (scancode @-> returning string)

let has_screen_keyboard_support = 
  foreign "SDL_HasScreenKeyboardSupport" (void @-> returning bool)

let is_screen_keyboard_shown = 
  foreign "SDL_IsScreenKeyboardShown" (window @-> returning bool)

let is_text_input_active = 
  foreign "SDL_IsTextInputActive" (void @-> returning bool)

let set_mod_state = 
  foreign "SDL_SetModState" (keymod @-> returning void)

let set_text_input_rect = 
  foreign "SDL_SetTextInputRect" (ptr rect @-> returning void)

let set_text_input_rect r = 
  set_text_input_rect (Rect.opt_addr r)

let start_text_input = 
  foreign "SDL_StartTextInput" (void @-> returning void)

let stop_text_input = 
  foreign "SDL_StopTextInput" (void @-> returning void)

(* Mouse *)

type cursor = unit ptr
let cursor : cursor typ = ptr void
let cursor_opt : cursor option typ = ptr_opt void

module System_cursor = struct
  type t = int
  let arrow = sdl_system_cursor_arrow
  let ibeam = sdl_system_cursor_ibeam
  let wait = sdl_system_cursor_wait
  let crosshair = sdl_system_cursor_crosshair
  let waitarrow = sdl_system_cursor_waitarrow
  let size_nw_se = sdl_system_cursor_sizenwse
  let size_ne_sw = sdl_system_cursor_sizenesw
  let size_we = sdl_system_cursor_sizewe
  let size_ns = sdl_system_cursor_sizens
  let size_all = sdl_system_cursor_sizeall
  let no = sdl_system_cursor_no
  let hand = sdl_system_cursor_hand
end

module Button = struct
  let i = Int32.of_int
  let lmask = i sdl_button_lmask 
  let mmask = i sdl_button_mmask 
  let rmask = i sdl_button_rmask 
  let x1mask = i sdl_button_x1mask 
  let x2mask = i sdl_button_x2mask 
end

let create_color_cursor =
  foreign "SDL_CreateColorCursor" 
    (surface @-> int @-> int @-> returning (some_to_ok cursor_opt))
    
let create_color_cursor s ~hot_x ~hot_y = 
  create_color_cursor s hot_x hot_y 
    
let create_cursor =
  foreign "SDL_CreateCursor" 
    (ptr void @-> ptr void @-> int @-> int @-> int @-> int @-> 
     returning (some_to_ok cursor_opt))
    
let create_cursor d m ~w ~h ~hot_x ~hot_y = 
  (* FIXME: we could try to check bounds *)
  let d = to_voidp (bigarray_start array1 d) in 
  let m = to_voidp (bigarray_start array1 m) in 
  create_cursor d m w h hot_x hot_y

let create_system_cursor = 
  foreign "SDL_CreateSystemCursor"
    (int @-> returning (some_to_ok cursor_opt))
    
let free_cursor =
  foreign "SDL_FreeCursor" (cursor @-> returning void)
    
let get_cursor =
  foreign "SDL_GetCursor" (void @-> returning cursor_opt)

let get_default_cursor = 
  foreign "SDL_GetDefaultCursor" (void @-> returning cursor_opt)
    
let get_mouse_focus =
  foreign "SDL_GetMouseFocus" (void @-> returning window_opt)
    
let get_mouse_state =
  foreign "SDL_GetMouseState" 
    (ptr int @-> ptr int @-> returning int32_as_uint32_t)

let get_mouse_state () =
  let x = allocate int 0 in 
  let y = allocate int 0 in 
  let s = get_mouse_state x y in 
  s, (!@ x, !@ y)

let get_relative_mouse_mode =
  foreign "SDL_GetRelativeMouseMode" (void @-> returning bool)

let get_relative_mouse_state =
  foreign "SDL_GetRelativeMouseState" 
    (ptr int @-> ptr int @-> returning int32_as_uint32_t)

let get_relative_mouse_state () =
  let x = allocate int 0 in 
  let y = allocate int 0 in 
  let s = get_relative_mouse_state x y in 
  s, (!@ x, !@ y)

let show_cursor = 
  foreign "SDL_ShowCursor" (int @-> returning bool_to_ok) 
    
let get_cursor_shown () = 
  show_cursor (-1)
    
let set_cursor =
  foreign "SDL_SetCursor" (cursor_opt @-> returning void)
    
let set_relative_mouse_mode =
  foreign "SDL_SetRelativeMouseMode" (bool @-> returning zero_to_ok)
    
let show_cursor b =
  show_cursor (if b then 1 else 0) 
    
let warp_mouse_in_window =
  foreign "SDL_WarpMouseInWindow" 
    (window_opt @-> int @-> int @-> returning void)
    
let warp_mouse_in_window w ~x ~y = 
  warp_mouse_in_window w x y

(* Touch *)

type touch_id = int64
let touch_id = int64_t
let touch_mouse_id = Int64.of_int (sdl_touch_mouseid)

type gesture_id = int64 
let gesture_id = int64_t 

type finger_id = int64 
let finger_id = int64_t 

type _finger
type finger = _finger structure
let finger : finger typ = structure "SDL_Finger" 
let finger_finger_id = field finger "id" finger_id
let finger_x = field finger "x" float 
let finger_y = field finger "y" float
let finger_pressure = field finger "pressure" float
let () = seal finger

module Finger = struct
  let id f = getf f finger_finger_id
  let x f = getf f finger_x
  let y f = getf f finger_y
  let pressure f = getf f finger_pressure
end

let get_num_touch_devices = 
  foreign "SDL_GetNumTouchDevices" (void @-> returning int)

let get_num_touch_fingers = 
  foreign "SDL_GetNumTouchFingers" (touch_id @-> returning int)

let get_touch_device = 
  foreign "SDL_GetTouchDevice" (int @-> returning touch_id) 

let get_touch_device i = 
  match get_touch_device i with 
  | 0L -> error () | id -> `Ok id 

let get_touch_finger = 
  foreign "SDL_GetTouchFinger" 
    (touch_id @-> int @-> returning (ptr_opt finger))

let get_touch_finger id i = 
  match get_touch_finger id i with 
  | None -> None | Some p -> Some (!@ p)

let load_dollar_templates = 
  foreign "SDL_LoadDollarTemplates"
    (touch_id @-> rw_ops @-> returning zero_to_ok)

let record_gesture = 
  foreign "SDL_RecordGesture" (touch_id @-> returning one_to_ok)
    
let save_dollar_template = 
  foreign "SDL_SaveDollarTemplate"
    (gesture_id @-> rw_ops @-> returning zero_to_ok)
    
let save_all_dollar_templates = 
  foreign "SDL_SaveAllDollarTemplates" (rw_ops @-> returning zero_to_ok)

(* Joystick *)

type _joystick_guid
type joystick_guid = _joystick_guid structure
let joystick_guid : joystick_guid typ = structure "SDL_JoystickGUID"
(* FIXME: No array here, see
   https://github.com/ocamllabs/ocaml-ctypes/issues/113 *)
(* let _= field joystick_guid "data" (array 16 uint8_t) *)
let _= field joystick_guid "data0" uint8_t
let _= field joystick_guid "data1" uint8_t
let _= field joystick_guid "data2" uint8_t
let _= field joystick_guid "data3" uint8_t
let _= field joystick_guid "data4" uint8_t
let _= field joystick_guid "data5" uint8_t
let _= field joystick_guid "data6" uint8_t
let _= field joystick_guid "data7" uint8_t
let _= field joystick_guid "data8" uint8_t
let _= field joystick_guid "data9" uint8_t
let _= field joystick_guid "data10" uint8_t
let _= field joystick_guid "data11" uint8_t
let _= field joystick_guid "data12" uint8_t
let _= field joystick_guid "data13" uint8_t
let _= field joystick_guid "data14" uint8_t
let _= field joystick_guid "data15" uint8_t
let () = seal joystick_guid

type joystick_id = int32
let joystick_id = int32_t

type joystick = unit ptr
let joystick : joystick typ = ptr void
let joystick_opt : joystick option typ = ptr_opt void

module Hat = struct
  type t = int
  let centered = sdl_hat_centered
  let up = sdl_hat_up
  let right = sdl_hat_right
  let down = sdl_hat_down
  let left = sdl_hat_left
  let rightup = sdl_hat_rightup
  let rightdown = sdl_hat_rightdown
  let leftup = sdl_hat_leftup
  let leftdown = sdl_hat_leftdown
end

let joystick_close = 
  foreign "SDL_JoystickClose" (joystick @-> returning void)

let joystick_event_state = 
  foreign "SDL_JoystickEventState" (int @-> returning nat_to_ok)

let joystick_get_event_state () = 
  joystick_event_state sdl_query

let joystick_set_event_state s = 
  joystick_event_state s

let joystick_get_attached = 
  foreign "SDL_JoystickGetAttached" (joystick @-> returning bool)

let joystick_get_axis = 
  foreign "SDL_JoystickGetAxis" (joystick @-> int @-> returning int16_t)

let joystick_get_ball = 
  foreign "SDL_JoystickGetBall" 
    (joystick @-> int @-> (ptr int) @-> (ptr int) @-> returning int)

let joystick_get_ball j i = 
  let x = allocate int 0 in 
  let y = allocate int 0 in
  match joystick_get_ball j i x y with 
  | 0 -> `Ok (!@ x, !@ y) | _ -> error ()

let joystick_get_button = 
  foreign "SDL_JoystickGetButton" 
    (joystick @-> int @-> returning int_as_uint8_t)

let joystick_get_device_guid =
  foreign "SDL_JoystickGetDeviceGUID" (int @-> returning joystick_guid)

let joystick_get_guid = 
  foreign "SDL_JoystickGetGUID" (joystick @-> returning joystick_guid)

let joystick_get_guid_from_string =
  foreign "SDL_JoystickGetGUIDFromString" (string @-> returning joystick_guid)

let joystick_get_guid_string =
  foreign "SDL_JoystickGetGUIDString" 
    (joystick_guid @-> ptr char @-> int @-> returning void)

let joystick_get_guid_string guid = 
  let len = 33 in
  let s = Array.start (Array.make char 33) in 
  joystick_get_guid_string guid s len; 
  coerce (ptr char) string s

let joystick_get_hat = 
  foreign "SDL_JoystickGetHat" (joystick @-> int @-> returning int_as_uint8_t)

let joystick_instance_id = 
  foreign "SDL_JoystickInstanceID" (joystick @-> returning joystick_id)

let joystick_instance_id j = 
  match joystick_instance_id j with 
  | n when n < 0l -> error () | n -> `Ok n

let joystick_name =
  foreign "SDL_JoystickName" (joystick @-> returning (some_to_ok string_opt))

let joystick_name_for_index =
  foreign "SDL_JoystickNameForIndex" (int @-> returning (some_to_ok string_opt))

let joystick_num_axes = 
  foreign "SDL_JoystickNumAxes" (joystick @-> returning nat_to_ok)

let joystick_num_balls = 
  foreign "SDL_JoystickNumBalls" (joystick @-> returning nat_to_ok)

let joystick_num_buttons =
  foreign "SDL_JoystickNumButtons" (joystick @-> returning nat_to_ok)

let joystick_num_hats =
  foreign "SDL_JoystickNumHats" (joystick @-> returning nat_to_ok)

let joystick_open = 
  foreign "SDL_JoystickOpen" (int @-> returning (some_to_ok joystick_opt))

let joystick_update =
  foreign "SDL_JoystickUpdate" (void @-> returning void)

let num_joysticks = 
  foreign "SDL_NumJoysticks" (void @-> returning nat_to_ok)

(* Game controller *)

type game_controller = unit ptr
let game_controller : game_controller typ = ptr void
let game_controller_opt : game_controller option typ = ptr_opt void

type _button_bind
let button_bind : _button_bind structure typ = 
  structure "SDL_GameControllerBindType" 
let button_bind_bind_type = field button_bind "bindType" int
let button_bind_value1 = field button_bind "value1" int  (* simplified enum *) 
let button_bind_value2 = field button_bind "value2" int  
let () = seal button_bind
    
module Controller = struct
  type bind_type = int
  let bind_type_none = sdl_controller_bindtype_none
  let bind_type_button = sdl_controller_bindtype_button
  let bind_type_axis = sdl_controller_bindtype_axis
  let bind_type_hat = sdl_controller_bindtype_hat
    
  type axis = int
  let axis_invalid = sdl_controller_axis_invalid
  let axis_left_x = sdl_controller_axis_leftx
  let axis_left_y = sdl_controller_axis_lefty
  let axis_right_x = sdl_controller_axis_rightx
  let axis_right_y = sdl_controller_axis_righty
  let axis_trigger_left = sdl_controller_axis_triggerleft
  let axis_trigger_right = sdl_controller_axis_triggerright
  let axis_max = sdl_controller_axis_max
    
  type button = int
  let button_invalid = sdl_controller_button_invalid
  let button_a = sdl_controller_button_a
  let button_b = sdl_controller_button_b
  let button_x = sdl_controller_button_x
  let button_y = sdl_controller_button_y
  let button_back = sdl_controller_button_back
  let button_guide = sdl_controller_button_guide
  let button_start = sdl_controller_button_start
  let button_left_stick = sdl_controller_button_leftstick
  let button_right_stick = sdl_controller_button_rightstick
  let button_left_shoulder = sdl_controller_button_leftshoulder
  let button_right_shoulder = sdl_controller_button_rightshoulder
  let button_dpad_up = sdl_controller_button_dpad_up
  let button_dpad_down = sdl_controller_button_dpad_down
  let button_dpad_left = sdl_controller_button_dpad_left
  let button_dpad_right = sdl_controller_button_dpad_right
  let button_max = sdl_controller_button_max

  type button_bind = _button_bind structure 
  let bind_type v = getf v button_bind_bind_type 
  let bind_button_value v = getf v button_bind_value1
  let bind_axis_value v = getf v button_bind_value1
  let bind_hat_value v = getf v button_bind_value1, getf v button_bind_value2 
end

let game_controller_add_mapping = 
  foreign "SDL_GameControllerAddMapping" (string @-> returning bool_to_ok)

(* SDL 2.0.2 
let game_controller_add_mapping_from_file = 
  foreign "SDL_GameControllerAddMappingsFromFile" 
    (string @-> returning nat_to_ok) *)

let game_controller_close = 
  foreign "SDL_GameControllerClose" (game_controller @-> returning void)

let game_controller_event_state = 
  foreign "SDL_GameControllerEventState" (int @-> returning nat_to_ok)

let game_controller_get_event_state () = 
  game_controller_event_state sdl_query 

let game_controller_set_event_state t = 
  game_controller_event_state t

let game_controller_get_attached = 
  foreign "SDL_GameControllerGetAttached" (game_controller @-> returning bool)

let game_controller_get_axis = 
  foreign "SDL_GameControllerGetAxis" 
    (game_controller @-> int @-> returning int16_t)

let game_controller_get_axis_from_string = 
  foreign "SDL_GameControllerGetAxisFromString" 
    (string @-> returning int)

let game_controller_get_bind_for_axis = 
  foreign "SDL_GameControllerGetBindForAxis"
    (game_controller @-> int @-> returning button_bind)

let game_controller_get_bind_for_button = 
  foreign "SDL_GameControllerGetBindForButton"
    (game_controller @-> int @-> returning button_bind)

let game_controller_get_button = 
  foreign "SDL_GameControllerGetButton" 
    (game_controller @-> int @-> returning int_as_uint8_t)

let game_controller_get_button_from_string = 
  foreign "SDL_GameControllerGetButtonFromString" (string @-> returning int)

let game_controller_get_joystick = 
  foreign "SDL_GameControllerGetJoystick"
    (game_controller @-> returning (some_to_ok joystick_opt))

let game_controller_get_string_for_axis = 
  foreign "SDL_GameControllerGetStringForAxis" (int @-> returning string_opt)

let game_controller_get_string_for_button = 
  foreign "SDL_GameControllerGetStringForButton" (int @-> returning string_opt)

let game_controller_mapping = 
  foreign "SDL_GameControllerMapping" 
    (game_controller @-> returning (some_to_ok string_opt))

let game_controller_mapping_for_guid = 
  foreign "SDL_GameControllerMappingForGUID"
    (joystick_guid @-> returning (some_to_ok string_opt))

let game_controller_name = 
  foreign "SDL_GameControllerName"
    (game_controller @-> returning (some_to_ok string_opt))

let game_controller_name_for_index = 
  foreign "SDL_GameControllerNameForIndex"
    (int @-> returning (some_to_ok string_opt))
  
let game_controller_open = 
  foreign "SDL_GameControllerOpen" 
    (int @-> returning (some_to_ok game_controller_opt))

let game_controller_update = 
  foreign "SDL_GameControllerUpdate" (void @-> returning void)

let is_game_controller = 
  foreign "SDL_IsGameController" (int @-> returning bool)

(* Events *)

type event_type = int
let event_type : event_type typ = int_as_uint32_t

module Event = struct

  (* Event structures *)

  module Common = struct
    type t
    let t : t structure typ = structure "SDL_CommonEvent"
    let typ = field t "type" int_as_uint32_t
    let timestamp = field t "timestamp" int32_as_uint32_t
    let () = seal t
  end

  module Controller_axis_event = struct
    type t
    let t : t structure typ = structure "SDL_ControllerAxisEvent"
    let _ = field t "type" int_as_uint32_t
    let _ = field t "timestamp" int32_as_uint32_t
    let which = field t "which" joystick_id 
    let axis = field t "axis" int_as_uint8_t
    let _ = field t "padding1" uint8_t
    let _ = field t "padding2" uint8_t
    let _ = field t "padding3" uint8_t
    let value = field t "value" int16_t
    let _ = field t "padding4" uint16_t
    let () = seal t
  end

  module Controller_button_event = struct
    type t
    let t : t structure typ = structure "SDL_ControllerButtonEvent"
    let _ = field t "type" int_as_uint32_t
    let _ = field t "timestamp" int32_as_uint32_t
    let which = field t "which" joystick_id 
    let button = field t "button" int_as_uint8_t     
    let state = field t "state" int_as_uint8_t
    let _ = field t "padding1" uint8_t
    let _ = field t "padding2" uint8_t
    let () = seal t
  end

  module Controller_device_event = struct
    type t
    let t : t structure typ = structure "SDL_ControllerDeviceEvent"
    let _ = field t "type" int_as_uint32_t
    let _ = field t "timestamp" int32_as_uint32_t
    let which = field t "which" joystick_id 
    let () = seal t
  end

  module Dollar_gesture_event = struct
    type t
    let t : t structure typ = structure "SDL_DollarGestureEvent"
    let _ = field t "type" int_as_uint32_t
    let _ = field t "timestamp" int32_as_uint32_t
    let touch_id = field t "touchId" touch_id     
    let gesture_id = field t "gestureId" gesture_id
    let num_fingers = field t "numFingers" int_as_uint32_t
    let error = field t "error" float
    let x = field t "x" float
    let y = field t "y" float
    let () = seal t
  end

  module Drop_event = struct
    type t
    let t : t structure typ = structure "SDL_DropEvent"
    let _ = field t "type" int_as_uint32_t
    let _ = field t "timestamp" int32_as_uint32_t    
    let file = field t "file" (ptr char)
    let () = seal t
  end

  module Keyboard_event = struct 
    type t
    let t : t structure typ = structure "SDL_KeyboardEvent"
    let _ = field t "type" int_as_uint32_t
    let _ = field t "timestamp" int32_as_uint32_t
    let window_id = field t "windowID" int_as_uint32_t
    let state = field t "state" int_as_uint8_t
    let repeat = field t "repeat" int_as_uint8_t
    let padding2 = field t "padding2" uint8_t
    let padding3 = field t "padding3" uint8_t     
    (* We inline the definition of SDL_Keysym *)
    let scancode = field t "scancode" scancode    
    let keycode = field t "sym" keycode
    let keymod = field t "mod" keymod
    let unused = field t "unused" uint32_t
    let () = seal t
  end

  module Joy_axis_event = struct
    type t
    let t : t structure typ = structure "SDL_JoyAxisEvent"
    let _ = field t "type" int_as_uint32_t
    let _ = field t "timestamp" int32_as_uint32_t
    let which = field t "which" joystick_id
    let axis = field t "axis" int_as_uint8_t
    let _ = field t "padding1" uint8_t
    let _ = field t "padding2" uint8_t
    let _ = field t "padding3" uint8_t
    let value = field t "value" int16_t
    let _ = field t "padding4" uint16_t
    let () = seal t
  end

  module Joy_ball_event = struct
    type t
    let t : t structure typ = structure "SDL_JoyBallEvent"
    let _ = field t "type" int_as_uint32_t
    let _ = field t "timestamp" int32_as_uint32_t
    let which = field t "which" joystick_id
    let ball = field t "ball" int_as_uint8_t
    let _ = field t "padding1" uint8_t
    let _ = field t "padding2" uint8_t
    let _ = field t "padding3" uint8_t
    let xrel = field t "xrel" int16_t
    let yrel = field t "yrel" int16_t
    let () = seal t
  end

  module Joy_button_event = struct
    type t
    let t : t structure typ = structure "SDL_JoyButtonEvent"
    let _ = field t "type" int_as_uint32_t
    let _ = field t "timestamp" int32_as_uint32_t
    let which = field t "which" joystick_id
    let button = field t "button" int_as_uint8_t   
    let state = field t "state" int_as_uint8_t
    let _ = field t "padding1" uint8_t
    let _ = field t "padding2" uint8_t
    let () = seal t
  end

  module Joy_device_event = struct
    type t
    let t : t structure typ = structure "SDL_JoyDeviceEvent"
    let _ = field t "type" int_as_uint32_t
    let _ = field t "timestamp" int32_as_uint32_t
    let which = field t "which" joystick_id
    let () = seal t
  end

  module Joy_hat_event = struct
    type t
    let t : t structure typ = structure "SDL_JoyHatEvent"
    let _ = field t "type" int_as_uint32_t
    let _ = field t "timestamp" int32_as_uint32_t
    let which = field t "which" joystick_id
    let hat = field t "hat" int_as_uint8_t    
    let value = field t "value" int_as_uint8_t
    let _ = field t "padding1" uint8_t
    let _ = field t "padding2" uint8_t
    let () = seal t
  end

  module Mouse_button_event = struct
    type t
    let t : t structure typ = structure "SDL_MouseButtonEvent"
    let _ = field t "type" int_as_uint32_t
    let _ = field t "timestamp" int32_as_uint32_t
    let window_id = field t "windowID" int_as_uint32_t
    let which = field t "which" int32_as_uint32_t
    let button = field t "button" int_as_uint8_t
    let state = field t "state" int_as_uint8_t
    let _ = field t "padding1" int_as_uint8_t
    let _ = field t "padding2" int_as_uint8_t
    let x = field t "x" int_as_int32_t
    let y = field t "y" int_as_int32_t
    let () = seal t
  end

  module Mouse_motion_event = struct
    type t
    let t : t structure typ = structure "SDL_MouseMotionEvent"
    let _ = field t "type" int_as_uint32_t
    let _ = field t "timestamp" int32_as_uint32_t
    let window_id = field t "windowID" int_as_uint32_t
    let which = field t "which" int32_as_uint32_t
    let state = field t "state" int32_as_uint32_t
    let x = field t "x" int_as_int32_t
    let y = field t "y" int_as_int32_t
    let xrel = field t "xrel" int_as_int32_t
    let yrel = field t "yrel" int_as_int32_t
    let () = seal t
  end

  module Mouse_wheel_event = struct
    type t
    let t : t structure typ = structure "SDL_MouseWheelEvent"
    let _ = field t "type" int_as_uint32_t
    let _ = field t "timestamp" int32_as_uint32_t
    let window_id = field t "windowID" int_as_uint32_t
    let which = field t "which" int32_as_uint32_t
    let x = field t "x" int_as_int32_t
    let y = field t "y" int_as_int32_t
    let () = seal t
  end

  module Multi_gesture_event = struct
    type t
    let t : t structure typ = structure "SDL_MultiGestureEvent"
    let _ = field t "type" int_as_uint32_t
    let _ = field t "timestamp" int32_as_uint32_t
    let touch_id = field t "touchId" touch_id 
    let dtheta = field t "dTheta" float 
    let ddist = field t "ddist" float 
    let x = field t "x" float 
    let y = field t "y" float 
    let num_fingers = field t "numFingers" int_as_uint16_t
    let _ = field t "padding" uint16_t
    let () = seal t
  end

  module Quit_event = struct
    type t
    let t : t structure typ = structure "SDL_QuitEvent"
    let _ = field t "type" int_as_uint32_t
    let _ = field t "timestamp" int32_as_uint32_t
    let () = seal t
  end

  module Sys_wm_event = struct
    type t
    let t : t structure typ = structure "SDL_SysWMEvent"
    let _ = field t "type" int_as_uint32_t
    let _ = field t "timestamp" int32_as_uint32_t    
    let _ = field t "msg" (ptr void)
    let () = seal t
  end

  module Text_editing_event = struct
    type t
    let t : t structure typ = structure "SDL_TextEditingEvent"
    let _ = field t "type" int_as_uint32_t
    let _ = field t "timestamp" int32_as_uint32_t
    let window_id = field t "windowID" int_as_uint32_t
    let text = field t "text" (string_as_char_array 
                                 sdl_texteditingevent_text_size)
    let start = field t "start" int_as_int32_t
    let length = field t "end" int_as_int32_t
    let () = seal t
  end

  module Text_input_event = struct
    type t
    let t : t structure typ = structure "SDL_TextIfmtsnputEvent"
    let _ = field t "type" int_as_uint32_t
    let _ = field t "timestamp" int32_as_uint32_t
    let window_id = field t "windowID" int_as_uint32_t
    let text = field t "text" (string_as_char_array 
                                 sdl_textinputevent_text_size)
    let () = seal t
  end

  module Touch_finger_event = struct
    type t
    let t : t structure typ = structure "SDL_TouchFingerEvent"
    let _ = field t "type" int_as_uint32_t
    let _ = field t "timestamp" int32_as_uint32_t
    let touch_id = field t "touchId" touch_id 
    let finger_id = field t "fingerId" finger_id 
    let x = field t "x" float
    let y = field t "y" float
    let dx = field t "dx" float    
    let dy = field t "dy" float
    let pressure = field t "pressure" float
    let () = seal t
  end

  module User_event = struct
    type t
    let t : t structure typ = structure "SDL_UserEvent"
    let _ = field t "type" int_as_uint32_t
    let _ = field t "timestamp" int32_as_uint32_t
    let window_id = field t "windowID" int_as_uint32_t
    let code = field t "code" int_as_int32_t
    let _ = field t "data1" (ptr void)
    let _ = field t "data2" (ptr void)
    let () = seal t
  end

  module Window_event = struct 
    type t
    let t : t structure typ = structure "SDL_WindowEvent"
    let _ = field t "type" int_as_uint32_t
    let _ = field t "timestamp" int32_as_uint32_t
    let window_id = field t "windowID" int_as_uint32_t
    let event = field t "event" int_as_uint8_t
    let padding1 = field t "padding1" uint8_t
    let padding2 = field t "padding2" uint8_t
    let padding3 = field t "padding3" uint8_t
    let data1 = field t "data1" int32_t
    let data2 = field t "data2" int32_t
    let () = seal t
  end

  type t
  let t : t union typ = union "SDL_Event" 
  let typ = field t "type" int_as_uint32_t
  let common = field t "common" Common.t
  let controller_axis_event = field t "caxis" Controller_axis_event.t
  let controller_button_event = field t "cbutton" Controller_button_event.t
  let controller_device_event = field t "cdevice" Controller_device_event.t
  let dollar_gesture_event = field t "dgesture" Dollar_gesture_event.t
  let drop_event = field t "drop" Drop_event.t
  let joy_axis_event = field t "jaxis" Joy_axis_event.t
  let joy_ball_event = field t "jball" Joy_ball_event.t
  let joy_button_event = field t "jbutton" Joy_button_event.t
  let joy_device_event = field t "jdevice" Joy_device_event.t
  let joy_hat_event = field t "jhat" Joy_hat_event.t
  let keyboard_event = field t "key" Keyboard_event.t
  let mouse_button_event = field t "button" Mouse_button_event.t
  let mouse_motion_event = field t "motion" Mouse_motion_event.t
  let mouse_wheel_event = field t "wheel" Mouse_wheel_event.t
  let multi_gesture_event = field t "mgesture" Multi_gesture_event.t
  let quit_event = field t "quit" Quit_event.t
  let sys_wm_event = field t "syswm" Sys_wm_event.t
  let text_editing_event = field t "edit" Text_editing_event.t
  let text_input_event = field t "text" Text_input_event.t
  let touch_finger_event = field t "tfinger" Touch_finger_event.t
  let user_event = field t "user" User_event.t
  let window_event = field t "window" Window_event.t
  let padding = field t "padding" (abstract "padding" tsdl_sdl_event_size 1)
  let () = seal t

  let create () = make t
  let opt_addr = function
  | None -> coerce (ptr void) (ptr t) null
  | Some v -> addr v  

  type _ field = 
      F : (* existential to hide the 'a structure *)
        (('a structure, t union) Ctypes.field * 
         ('b, 'a structure) Ctypes.field) -> 'b field

  let get e (F (s, f)) = getf (getf e s) f
  let set e (F (s, f)) v = setf (getf e s) f v

  (* Aliases *)

  let first_event = sdl_firstevent
  let last_event = sdl_lastevent
      
  (* Common *)
  
  let typ  = F (common, Common.typ)
  let timestamp = F (common, Common.timestamp) 

  (* Application events. *)

  let app_terminating = sdl_app_terminating
  let app_low_memory = sdl_app_lowmemory
  let app_will_enter_background = sdl_app_willenterbackground
  let app_did_enter_background = sdl_app_didenterbackground
  let app_will_enter_foreground = sdl_app_willenterforeground
  let app_did_enter_foreground = sdl_app_didenterforeground
    
  (* Clipboard events *)

  let clipboard_update = sdl_clipboardupdate

  (* Controller events *)

  let controller_axis_motion = sdl_controlleraxismotion
  let controller_button_down = sdl_controllerbuttondown
  let controller_button_up = sdl_controllerbuttonup
  let controller_device_added = sdl_controllerdeviceadded
  let controller_device_remapped = sdl_controllerdeviceremapped
  let controller_device_removed = sdl_controllerdeviceremoved

  let controller_axis_which = 
    F (controller_axis_event, Controller_axis_event.which)
  let controller_axis_axis = 
    F (controller_axis_event, Controller_axis_event.axis)
  let controller_axis_value = 
    F (controller_axis_event, Controller_axis_event.value)

  let controller_button_which = 
    F (controller_button_event, Controller_button_event.which)
  let controller_button_button = 
    F (controller_button_event, Controller_button_event.button)
  let controller_button_state = 
    F (controller_button_event, Controller_button_event.state)

  let controller_device_which = 
    F (controller_device_event, Controller_device_event.which)

  (* Dollar gesture events *)

  let dollar_gesture = sdl_dollargesture
  let dollar_record = sdl_dollarrecord

  let dollar_gesture_touch_id = 
    F (dollar_gesture_event, Dollar_gesture_event.touch_id)
  let dollar_gesture_gesture_id = 
    F (dollar_gesture_event, Dollar_gesture_event.gesture_id)
  let dollar_gesture_num_fingers = 
    F (dollar_gesture_event, Dollar_gesture_event.num_fingers)
  let dollar_gesture_error = 
    F (dollar_gesture_event, Dollar_gesture_event.error)
  let dollar_gesture_x = F (dollar_gesture_event, Dollar_gesture_event.x)
  let dollar_gesture_y = F (dollar_gesture_event, Dollar_gesture_event.y)

  (* Drop file event *)

  let drop_file = sdl_dropfile
  let drop_file_file = F (drop_event, Drop_event.file)

  let drop_file_free e = 
    sdl_free (to_voidp (get e drop_file_file))

  let drop_file_file e = 
    let sp = get e drop_file_file in
    if ptr_compare (to_voidp sp) null = 0 then invalid_arg err_drop_file else
    coerce (ptr char) string (get e drop_file_file)

  (* Touch events *)

  let finger_down = sdl_fingerdown
  let finger_motion = sdl_fingermotion
  let finger_up = sdl_fingerup

  let touch_finger_touch_id = F (touch_finger_event,Touch_finger_event.touch_id)
  let touch_finger_finger_id = 
    F (touch_finger_event, Touch_finger_event.finger_id)
  let touch_finger_x = F (touch_finger_event, Touch_finger_event.x)
  let touch_finger_y = F (touch_finger_event, Touch_finger_event.y)
  let touch_finger_dx = F (touch_finger_event, Touch_finger_event.dx)
  let touch_finger_dy = F (touch_finger_event, Touch_finger_event.dy)
  let touch_finger_pressure = 
    F (touch_finger_event, Touch_finger_event.pressure)

  (* Joystick events. *)

  let joy_axis_motion = sdl_joyaxismotion
  let joy_ball_motion = sdl_joyballmotion
  let joy_button_down = sdl_joybuttondown
  let joy_button_up = sdl_joybuttonup
  let joy_device_added = sdl_joydeviceadded
  let joy_device_removed = sdl_joydeviceremoved
  let joy_hat_motion = sdl_joyhatmotion

  let joy_axis_which = F (joy_axis_event, Joy_axis_event.which)
  let joy_axis_axis = F (joy_axis_event, Joy_axis_event.axis)
  let joy_axis_value = F (joy_axis_event, Joy_axis_event.value)

  let joy_ball_which = F (joy_ball_event, Joy_ball_event.which)
  let joy_ball_ball = F (joy_ball_event, Joy_ball_event.ball)
  let joy_ball_xrel = F (joy_ball_event, Joy_ball_event.xrel)
  let joy_ball_yrel = F (joy_ball_event, Joy_ball_event.yrel)

  let joy_button_which = F (joy_button_event, Joy_button_event.which)
  let joy_button_button = F (joy_button_event, Joy_button_event.button)
  let joy_button_state = F (joy_button_event, Joy_button_event.state)

  let joy_device_which = F (joy_device_event, Joy_device_event.which)

  let joy_hat_which = F (joy_hat_event, Joy_hat_event.which)
  let joy_hat_hat = F (joy_hat_event, Joy_hat_event.hat)
  let joy_hat_value = F (joy_hat_event, Joy_hat_event.value)

  (* Keyboard events *)

  let key_down = sdl_keydown
  let key_up = sdl_keyup
      
  let keyboard_window_id = F (keyboard_event, Keyboard_event.window_id) 
  let keyboard_repeat = F (keyboard_event, Keyboard_event.repeat) 
  let keyboard_state = F (keyboard_event, Keyboard_event.state)
  let keyboard_scancode = F (keyboard_event, Keyboard_event.scancode) 
  let keyboard_keycode = F (keyboard_event, Keyboard_event.keycode) 
  let keyboard_keymod = F (keyboard_event, Keyboard_event.keymod)

  (* Mouse events *)

  let mouse_button_down = sdl_mousebuttondown
  let mouse_button_up = sdl_mousebuttonup
  let mouse_motion = sdl_mousemotion
  let mouse_wheel = sdl_mousewheel

  let mouse_button_window_id = 
    F (mouse_button_event, Mouse_button_event.window_id)
  let mouse_button_which = F (mouse_button_event, Mouse_button_event.which)
  let mouse_button_state = F (mouse_button_event, Mouse_button_event.state)
  let mouse_button_button = F (mouse_button_event, Mouse_button_event.button)
  let mouse_button_x = F (mouse_button_event, Mouse_button_event.x)
  let mouse_button_y = F (mouse_button_event, Mouse_button_event.y)

  let mouse_motion_window_id = 
    F (mouse_motion_event, Mouse_motion_event.window_id)
  let mouse_motion_which = F (mouse_motion_event, Mouse_motion_event.which)
  let mouse_motion_state = F (mouse_motion_event, Mouse_motion_event.state)
  let mouse_motion_x = F (mouse_motion_event, Mouse_motion_event.x)
  let mouse_motion_y = F (mouse_motion_event, Mouse_motion_event.y)
  let mouse_motion_xrel = F (mouse_motion_event, Mouse_motion_event.xrel)
  let mouse_motion_yrel = F (mouse_motion_event, Mouse_motion_event.yrel)

  let mouse_wheel_window_id = F (mouse_wheel_event, Mouse_wheel_event.window_id)
  let mouse_wheel_which = F (mouse_wheel_event, Mouse_wheel_event.which)
  let mouse_wheel_x = F (mouse_wheel_event, Mouse_wheel_event.x)
  let mouse_wheel_y = F (mouse_wheel_event, Mouse_wheel_event.y)

  (* Multi gesture events *)

  let multi_gesture = sdl_multigesture

  let multi_gesture_touch_id = 
    F (multi_gesture_event, Multi_gesture_event.touch_id)
  let multi_gesture_dtheta = F (multi_gesture_event, Multi_gesture_event.dtheta)
  let multi_gesture_ddist = F (multi_gesture_event, Multi_gesture_event.ddist)
  let multi_gesture_x = F (multi_gesture_event, Multi_gesture_event.x)
  let multi_gesture_y = F (multi_gesture_event, Multi_gesture_event.y)  
  let multi_gesture_num_fingers = 
    F (multi_gesture_event, Multi_gesture_event.num_fingers)

  (* Quit events *)

  let quit = sdl_quit

  (* System window manager events *)

  let sys_wm_event = sdl_syswmevent

  (* Text events *)

  let text_editing = sdl_textediting
  let text_input = sdl_textinput

  let text_editing_window_id = 
    F (text_editing_event, Text_editing_event.window_id)
  let text_editing_text = F (text_editing_event, Text_editing_event.text)
  let text_editing_start = F (text_editing_event, Text_editing_event.start)
  let text_editing_length = F (text_editing_event, Text_editing_event.length)

  let text_input_window_id = F (text_input_event, Text_input_event.window_id)
  let text_input_text = F (text_input_event, Text_input_event.text)

  (* User events *)

  let user_window_id = F (user_event, User_event.window_id)
  let user_code = F (user_event, User_event.code)
  let user_event = sdl_userevent

  (* Window events *)

  type window_event_id = int
  let window_event_shown = sdl_windowevent_shown
  let window_event_hidden = sdl_windowevent_hidden
  let window_event_exposed = sdl_windowevent_exposed
  let window_event_moved = sdl_windowevent_moved
  let window_event_resized = sdl_windowevent_resized
  let window_event_size_changed = sdl_windowevent_size_changed
  let window_event_minimized = sdl_windowevent_minimized
  let window_event_maximized = sdl_windowevent_maximized
  let window_event_restored = sdl_windowevent_restored
  let window_event_enter = sdl_windowevent_enter
  let window_event_leave = sdl_windowevent_leave
  let window_event_focus_gained = sdl_windowevent_focus_gained
  let window_event_focus_lost = sdl_windowevent_focus_lost
  let window_event_close = sdl_windowevent_close

  let window_window_id = F (window_event, Window_event.window_id)
  let window_event_id = F (window_event, Window_event.event)
  let window_data1 = F (window_event, Window_event.data1) 
  let window_data2 = F (window_event, Window_event.data2)
  
  let window_event = sdl_windowevent

  (* Window event id enum *) 

  let enum_of_window_event_id = 
    let add acc (k, v) = Imap.add k v acc in
    let enums = [ 
      window_event_shown, `Shown;
      window_event_hidden, `Hidden;
      window_event_exposed, `Exposed;
      window_event_moved, `Moved;
      window_event_resized, `Resized;
      window_event_size_changed, `Size_changed;
      window_event_minimized, `Minimized;
      window_event_maximized, `Maximized;
      window_event_restored, `Restored;
      window_event_enter, `Enter;
      window_event_leave, `Leave;
      window_event_focus_gained, `Focus_gained;
      window_event_focus_lost, `Focus_lost;
      window_event_close, `Close; ]
    in
    List.fold_left add Imap.empty enums
    
  let window_event_enum id = 
    try Imap.find id enum_of_window_event_id with Not_found -> assert false

  (* Event type enum *) 

  let enum_of_event_type = 
    let add acc (k, v) = Imap.add k v acc in
    let enums = [ app_terminating, `App_terminating;
                  app_low_memory, `App_low_memory;
                  app_will_enter_background, `App_will_enter_background;
                  app_did_enter_background, `App_did_enter_background;
                  app_will_enter_foreground, `App_will_enter_foreground;
                  app_did_enter_foreground, `App_did_enter_foreground;
                  clipboard_update, `Clipboard_update;
                  controller_axis_motion, `Controller_axis_motion;
                  controller_button_down, `Controller_button_down;
                  controller_button_up, `Controller_button_up;
                  controller_device_added, `Controller_device_added;
                  controller_device_remapped, `Controller_device_remapped;
                  controller_device_removed, `Controller_device_removed;
                  dollar_gesture, `Dollar_gesture;
                  dollar_record, `Dollar_record;
                  drop_file, `Drop_file;
                  finger_down, `Finger_down;
                  finger_motion, `Finger_motion;
                  finger_up, `Finger_up;
                  joy_axis_motion, `Joy_axis_motion;
                  joy_ball_motion, `Joy_ball_motion;
                  joy_button_down, `Joy_button_down;
                  joy_button_up, `Joy_button_up;
                  joy_device_added, `Joy_device_added;
                  joy_device_removed, `Joy_device_removed;
                  joy_hat_motion, `Joy_hat_motion;
                  key_down, `Key_down;
                  key_up, `Key_up;
                  mouse_button_down, `Mouse_button_down;
                  mouse_button_up, `Mouse_button_up;
                  mouse_motion, `Mouse_motion;
                  mouse_wheel, `Mouse_wheel;
                  multi_gesture, `Multi_gesture;
                  sys_wm_event, `Sys_wm_event;
                  text_editing, `Text_editing;
                  text_input, `Text_input;
                  user_event, `User_event;
                  quit, `Quit;
                  window_event, `Window_event; ]
    in
    List.fold_left add Imap.empty enums
    
  let enum t = try Imap.find t enum_of_event_type with Not_found -> `Unknown

end

type event = Event.t union

let event_state = 
  foreign "SDL_EventState" (event_type @-> int @-> returning int_as_uint8_t)

let get_event_state e = 
  event_state e sdl_query 

let set_event_state e s = 
  ignore (event_state e s)

let flush_event = 
  foreign "SDL_FlushEvent" (event_type @-> returning void)

let flush_events = 
  foreign "SDL_FlushEvents" (event_type @-> event_type @-> returning void)

let has_event = 
  foreign "SDL_HasEvent" (event_type @-> returning bool)

let has_events = 
  foreign "SDL_HasEvents" (event_type @-> event_type @-> returning bool)

let poll_event = 
  foreign "SDL_PollEvent" (ptr Event.t @-> returning bool)

let poll_event e = 
  poll_event (Event.opt_addr e)

let pump_events = 
  foreign "SDL_PumpEvents" (void @-> returning void)

let push_event = 
  foreign "SDL_PushEvent" (ptr Event.t @-> returning bool_to_ok)

let push_event e = 
  push_event (addr e)

let register_events = 
  foreign "SDL_RegisterEvents" (int @-> returning uint32_t)

let register_event () = match Unsigned.UInt32.to_int32 (register_events 1) with 
| -1l -> None | t -> Some (Int32.to_int t)

let wait_event = 
  foreign "SDL_WaitEvent" (ptr Event.t @-> returning int)

let wait_event e = match wait_event (Event.opt_addr e) with 
| 1 -> `Ok () | _ -> error () 
  
let wait_event_timeout = 
  foreign "SDL_WaitEventTimeout" 
    (ptr Event.t @-> int @-> returning bool)
 
let wait_event_timeout e t = 
  wait_event_timeout (Event.opt_addr e) t

(* Force feedback *)

type haptic = unit ptr
let haptic : haptic typ = ptr void
let haptic_opt : haptic option typ = ptr_opt void
    
module Haptic = struct
  let infinity = -1l

  (* Features *)
  
  type feature = int 
  let gain = sdl_haptic_gain
  let autocenter = sdl_haptic_autocenter
  let status = sdl_haptic_status
  let pause = sdl_haptic_pause

  (* Directions *)

  type direction_type = int
  let polar = sdl_haptic_polar
  let cartesian = sdl_haptic_cartesian
  let spherical = sdl_haptic_spherical  

  module Direction = struct
    type _t 
    type t = _t structure
    let t : _t structure typ = structure "SDL_HapticDirection"
    let typ = field t "type" int_as_uint8_t
    let dir_0 = field t "dir0" int32_t
    let dir_1 = field t "dir1" int32_t
    let dir_2 = field t "dir2" int32_t
    let () = seal t

    let create typv d0 d1 d2 = 
      let d = make t in 
      setf d typ typv;
      setf d dir_0 d0;
      setf d dir_1 d1;
      setf d dir_2 d2;
      d
      
    let typ d = getf d typ
    let dir_0 d = getf d dir_0
    let dir_1 d = getf d dir_1
    let dir_2 d = getf d dir_2
  end

  (* Effects *)

  module Constant = struct
    type t
    let t : t structure typ = structure "SDL_HapticConstant"
    let typ = field t "type" int_as_uint16_t
    let direction = field t "direction" Direction.t
    let length = field t "length" int32_as_uint32_t
    let delay = field t "delay" int_as_uint16_t
    let button = field t "button" int_as_uint16_t
    let interval = field t "interval" int_as_uint16_t

    let level = field t "level" int16_t
    let attack_length = field t "attack_length" int_as_uint16_t
    let attack_level = field t "attack_level" int_as_uint16_t
    let fade_length = field t "fade_length" int_as_uint16_t
    let fade_level = field t "fade_level" int_as_uint16_t
    let () = seal t
  end

  module Periodic = struct
    type t
    let t : t structure typ = structure "SDL_HapticPeriodic"
    let typ = field t "type" int_as_uint16_t
    let direction = field t "direction" Direction.t
    let length = field t "length" int32_as_uint32_t
    let delay = field t "delay" int_as_uint16_t
    let button = field t "button" int_as_uint16_t
    let interval = field t "interval" int_as_uint16_t

    let period = field t "period" int_as_uint16_t
    let magnitude = field t "magnitude" int16_t
    let offset = field t "offset" int16_t
    let phase = field t "phase" int_as_uint16_t
    let attack_length = field t "attack_length" int_as_uint16_t
    let attack_level = field t "attack_level" int_as_uint16_t
    let fade_length = field t "fade_length" int_as_uint16_t
    let fade_level = field t "fade_level" int_as_uint16_t
    let () = seal t
  end

  module Condition = struct 
    type t
    let t : t structure typ = structure "SDL_HapticCondition"
    let typ = field t "type" int_as_uint16_t
    let direction = field t "direction" Direction.t
    let length = field t "length" int32_as_uint32_t
    let delay = field t "delay" int_as_uint16_t
    let button = field t "button" int_as_uint16_t
    let interval = field t "interval" int_as_uint16_t

    let right_sat_0 = field t "right_sat[0]" int_as_uint16_t
    let right_sat_1 = field t "right_sat[1]" int_as_uint16_t    
    let right_sat_2 = field t "right_sat[2]" int_as_uint16_t
    let left_sat_0 = field t "left_sat[0]" int_as_uint16_t
    let left_sat_1 = field t "left_sat[1]" int_as_uint16_t
    let left_sat_2 = field t "left_sat[2]" int_as_uint16_t
    let right_coeff_0 = field t "right_coeff[0]" int16_t
    let right_coeff_1 = field t "right_coeff[1]" int16_t
    let right_coeff_2 = field t "right_coeff[2]" int16_t
    let left_coeff_0 = field t "left_coeff[0]" int16_t
    let left_coeff_1 = field t "left_coeff[1]" int16_t
    let left_coeff_2 = field t "left_coeff[2]" int16_t
    let deadband_0 = field t "deadband[0]" int_as_uint16_t
    let deadband_1 = field t "deadband[1]" int_as_uint16_t
    let deadband_2 = field t "deadband[2]" int_as_uint16_t
    let center_0 = field t "center[0]" int16_t
    let center_1 = field t "center[1]" int16_t
    let center_2 = field t "center[2]" int16_t
    let () = seal t
  end
  
  module Ramp = struct 
    type t
    let t : t structure typ = structure "SDL_HapticRamp"
    let typ = field t "type" int_as_uint16_t
    let direction = field t "direction" Direction.t
    let length = field t "length" int32_as_uint32_t
    let delay = field t "delay" int_as_uint16_t
    let button = field t "button" int_as_uint16_t
    let interval = field t "interval" int_as_uint16_t
    
    let start = field t "start" int16_t
    let end_ = field t "end" int16_t
    let attack_length = field t "attack_length" int_as_uint16_t
    let attack_level = field t "attack_level" int_as_uint16_t
    let fade_length = field t "fade_length" int_as_uint16_t
    let fade_level = field t "fade_level" int_as_uint16_t
    let () = seal t
  end

  module Left_right = struct 
    type t
    let t : t structure typ = structure "SDL_HapticLeftRight"
    let typ = field t "type" int_as_uint16_t
    let direction = field t "direction" Direction.t
    let length = field t "length" int32_as_uint32_t
     
    let large_magnitude = field t "large_magnitude" int_as_uint16_t 
    let small_magnitude = field t "small_magnitude" int_as_uint16_t 
    let () = seal t
  end

  module Custom = struct 
    let int_list_as_uint16_t_ptr = 
      let read _ = invalid_arg err_read_field in
      let write l = 
        let l = List.map Unsigned.UInt16.of_int l in
        let a = Array.of_list uint16_t l in 
        Array.start a
      in
      view ~read ~write (ptr uint16_t)
      
    type t
    let t : t structure typ = structure "SDL_HapticCustom"
    let typ = field t "type" int_as_uint16_t
    let direction = field t "direction" Direction.t
    let length = field t "length" int32_as_uint32_t
    let delay = field t "delay" int_as_uint16_t
    let button = field t "button" int_as_uint16_t
    let interval = field t "interval" int_as_uint16_t

    let channels = field t "channels" int_as_uint8_t 
    let period = field t "period" int_as_uint16_t
    let samples = field t "samples" int_as_uint16_t
    let data = field t "data" int_list_as_uint16_t_ptr
    let attack_length = field t "attack_length" int_as_uint16_t
    let attack_level = field t "attack_level" int_as_uint16_t
    let fade_length = field t "fade_length" int_as_uint16_t
    let fade_level = field t "fade_level" int_as_uint16_t
    let () = seal t
  end

  module Effect = struct
    type t
    let t : t union typ = union "SDL_HapticEffect"
    let typ = field t "type" int_as_uint16_t 
    let constant = field t "constant" Constant.t
    let periodic = field t "periodic" Periodic.t
    let condition = field t "condition" Condition.t
    let ramp = field t "ramp" Ramp.t
    let left_right = field t "condition" Left_right.t
    let custom = field t "custom" Custom.t
    let () = seal t
  end

  type effect_type = int 

  let create_effect () = make Effect.t
  let opt_addr = function
  | None -> coerce (ptr void) (ptr Effect.t) null
  | Some v -> addr v  

  type _ field = 
      F : (* existential to hide the 'a structure *)
        (('a structure, Effect.t union) Ctypes.field * 
         ('b, 'a structure) Ctypes.field) -> 'b field

  let get e (F (s, f)) = getf (getf e s) f
  let set e (F (s, f)) v = setf (getf e s) f v
  let typ = F (Effect.constant, Constant.typ) (* same in each enum *)

  (* Constant *)
  let constant = sdl_haptic_constant

  let constant_type = F (Effect.constant, Constant.typ)
  let constant_direction = F (Effect.constant, Constant.direction)
  let constant_length = F (Effect.constant, Constant.length)
  let constant_delay = F (Effect.constant, Constant.delay)
  let constant_button = F (Effect.constant, Constant.button)
  let constant_interval = F (Effect.constant, Constant.interval)
  let constant_level = F (Effect.constant, Constant.level)
  let constant_attack_length = F (Effect.constant, Constant.attack_length)
  let constant_attack_level = F (Effect.constant, Constant.attack_level)
  let constant_fade_length = F (Effect.constant, Constant.fade_length)
  let constant_fade_level = F (Effect.constant, Constant.fade_level)

  (* Periodic *)

  let sine = sdl_haptic_sine
  let left_right = sdl_haptic_leftright
  let triangle = sdl_haptic_triangle
  let sawtooth_up = sdl_haptic_sawtoothup
  let sawtooth_down = sdl_haptic_sawtoothdown

  let periodic_type = F (Effect.periodic, Periodic.typ)
  let periodic_direction = F (Effect.periodic, Periodic.direction)
  let periodic_length = F (Effect.periodic, Periodic.length)
  let periodic_delay = F (Effect.periodic, Periodic.delay)
  let periodic_button = F (Effect.periodic, Periodic.button)
  let periodic_interval = F (Effect.periodic, Periodic.interval)
  let periodic_period = F (Effect.periodic, Periodic.period)
  let periodic_magnitude = F (Effect.periodic, Periodic.magnitude)
  let periodic_offset = F (Effect.periodic, Periodic.offset)
  let periodic_phase = F (Effect.periodic, Periodic.phase)
  let periodic_attack_length = F (Effect.periodic, Periodic.attack_length)
  let periodic_attack_level = F (Effect.periodic, Periodic.attack_level)
  let periodic_fade_length = F (Effect.periodic, Periodic.fade_length)
  let periodic_fade_level = F (Effect.periodic, Periodic.fade_level)

  (* Condition *)

  let spring = sdl_haptic_spring
  let damper = sdl_haptic_damper
  let inertia = sdl_haptic_inertia
  let friction = sdl_haptic_friction

  let condition_type = F (Effect.condition, Condition.typ)
  let condition_direction = F (Effect.condition, Condition.direction)
  let condition_length = F (Effect.condition, Condition.length)
  let condition_delay = F (Effect.condition, Condition.delay)
  let condition_button = F (Effect.condition, Condition.button)
  let condition_interval = F (Effect.condition, Condition.interval)
  let condition_right_sat_0 = F (Effect.condition, Condition.right_sat_0)
  let condition_right_sat_1 = F (Effect.condition, Condition.right_sat_1)
  let condition_right_sat_2 = F (Effect.condition, Condition.right_sat_2)
  let condition_left_sat_0 = F (Effect.condition, Condition.left_sat_0)
  let condition_left_sat_1 = F (Effect.condition, Condition.left_sat_1)
  let condition_left_sat_2 = F (Effect.condition, Condition.left_sat_2)
  let condition_right_coeff_0 = F (Effect.condition, Condition.right_coeff_0)
  let condition_right_coeff_1 = F (Effect.condition, Condition.right_coeff_1)
  let condition_right_coeff_2 = F (Effect.condition, Condition.right_coeff_2)
  let condition_left_coeff_0 = F (Effect.condition, Condition.left_coeff_0)
  let condition_left_coeff_1 = F (Effect.condition, Condition.left_coeff_1)
  let condition_left_coeff_2 = F (Effect.condition, Condition.left_coeff_2)
  let condition_deadband_0 = F (Effect.condition, Condition.deadband_0)
  let condition_deadband_1 = F (Effect.condition, Condition.deadband_1)
  let condition_deadband_2 = F (Effect.condition, Condition.deadband_2)
  let condition_center_0 = F (Effect.condition, Condition.center_0)
  let condition_center_1 = F (Effect.condition, Condition.center_1)
  let condition_center_2 = F (Effect.condition, Condition.center_2)

  (* Ramp *)

  let ramp = sdl_haptic_ramp

  let ramp_type = F (Effect.ramp, Ramp.typ)
  let ramp_direction = F (Effect.ramp, Ramp.direction)
  let ramp_length = F (Effect.ramp, Ramp.length)
  let ramp_delay = F (Effect.ramp, Ramp.delay)
  let ramp_button = F (Effect.ramp, Ramp.button)
  let ramp_interval = F (Effect.ramp, Ramp.interval)
  let ramp_start = F (Effect.ramp, Ramp.start)
  let ramp_end = F (Effect.ramp, Ramp.end_)
  let ramp_attack_length = F (Effect.ramp, Ramp.attack_length)
  let ramp_attack_level = F (Effect.ramp, Ramp.attack_level)
  let ramp_fade_length = F (Effect.ramp, Ramp.fade_length)
  let ramp_fade_level = F (Effect.ramp, Ramp.fade_level)

  (* Left right *)

  let left_right_type = F (Effect.left_right, Left_right.typ)
  let left_right_length = F (Effect.left_right, Left_right.length)
  let left_right_large_magnitude = 
    F (Effect.left_right, Left_right.large_magnitude)
  let left_right_small_magnitude = 
    F (Effect.left_right, Left_right.small_magnitude)

  (* Custom *) 

  let custom = sdl_haptic_custom

  let custom_type = F (Effect.custom, Custom.typ)
  let custom_direction = F (Effect.custom, Custom.direction)
  let custom_length = F (Effect.custom, Custom.length)
  let custom_delay = F (Effect.custom, Custom.delay)
  let custom_button = F (Effect.custom, Custom.button)
  let custom_interval = F (Effect.custom, Custom.interval)
  let custom_channels = F (Effect.custom, Custom.channels)
  let custom_period = F (Effect.custom, Custom.period)
  let custom_samples = F (Effect.custom, Custom.samples)
  let custom_data = F (Effect.custom, Custom.data)
  let custom_attack_length = F (Effect.custom, Custom.attack_length)
  let custom_attack_level = F (Effect.custom, Custom.attack_level)
  let custom_fade_length = F (Effect.custom, Custom.fade_length)
  let custom_fade_level = F (Effect.custom, Custom.fade_level)
end

type haptic_effect = Haptic.Effect.t union

type haptic_effect_id = int
let haptic_effect_id : int typ = int 

let haptic_close = 
  foreign "SDL_HapticClose" (haptic @-> returning void)

let haptic_destroy_effect = 
  foreign "SDL_HapticDestroyEffect" 
    (haptic @-> int @-> returning void)

let haptic_effect_supported = 
  foreign "SDL_HapticEffectSupported" 
    (haptic @-> ptr Haptic.Effect.t @-> returning bool_to_ok)

let haptic_effect_supported h e = 
  haptic_effect_supported h (addr e)

let haptic_get_effect_status = 
  foreign "SDL_HapticGetEffectStatus" 
    (haptic @-> haptic_effect_id @-> returning bool_to_ok)

let haptic_index = 
  foreign "SDL_HapticIndex" (haptic @-> returning nat_to_ok)

let haptic_name =
  foreign "SDL_HapticName" (int @-> returning (some_to_ok string_opt))

let haptic_new_effect = 
  foreign "SDL_HapticNewEffect" 
    (haptic @-> ptr Haptic.Effect.t @-> returning nat_to_ok)

let haptic_new_effect h e = 
  haptic_new_effect h (addr e)

let haptic_num_axes = 
  foreign "SDL_HapticNumAxes" (haptic @-> returning nat_to_ok)

let haptic_num_effects = 
  foreign "SDL_HapticNumEffects" (haptic @-> returning nat_to_ok)

let haptic_num_effects_playing = 
  foreign "SDL_HapticNumEffectsPlaying" (haptic @-> returning nat_to_ok)

let haptic_open = 
  foreign "SDL_HapticOpen" (int @-> returning (some_to_ok haptic_opt))

let haptic_open_from_joystick = 
  foreign "SDL_HapticOpenFromJoystick" 
  (joystick @-> returning (some_to_ok haptic_opt))

let haptic_open_from_mouse = 
  foreign "SDL_HapticOpenFromMouse" 
    (void @-> returning (some_to_ok haptic_opt))

let haptic_opened = 
  foreign "SDL_HapticOpened" (int @-> returning int)

let haptic_opened i = match haptic_opened i with 
| 0 -> false | 1 -> true | _ -> assert false

let haptic_pause = 
  foreign "SDL_HapticPause" (haptic @-> returning zero_to_ok) 

let haptic_query = 
  foreign "SDL_HapticQuery" (haptic @-> returning int)

let haptic_rumble_init = 
  foreign "SDL_HapticRumbleInit" (haptic @-> returning zero_to_ok)

let haptic_rumble_play = 
  foreign "SDL_HapticRumblePlay" 
    (haptic @-> float @-> int32_t @-> returning zero_to_ok)

let haptic_rumble_stop = 
  foreign "SDL_HapticRumbleStop" (haptic @-> returning zero_to_ok)

let haptic_rumble_supported = 
  foreign "SDL_HapticRumbleSupported" (haptic @-> returning bool_to_ok)

let haptic_run_effect = 
  foreign "SDL_HapticRunEffect" 
    (haptic @-> haptic_effect_id  @-> int32_t @-> returning zero_to_ok)
  
let haptic_set_autocenter = 
  foreign "SDL_HapticSetAutocenter" (haptic @-> int @-> returning zero_to_ok)

let haptic_set_gain = 
  foreign "SDL_HapticSetGain" (haptic @-> int @-> returning zero_to_ok)
    
let haptic_stop_all = 
  foreign "SDL_HapticStopAll" (haptic @-> returning zero_to_ok)
    
let haptic_stop_effect =
  foreign "SDL_HapticStopEffect"
    (haptic @-> haptic_effect_id @-> returning zero_to_ok)
    
let haptic_unpause = 
  foreign "SDL_HapticUnpause" (haptic @-> returning zero_to_ok)
    
let haptic_update_effect =
  foreign "SDL_HapticUpdateEffect"
    (haptic @-> haptic_effect_id @-> ptr Haptic.Effect.t @-> 
     returning zero_to_ok)

let haptic_update_effect h id e =
  haptic_update_effect h id (addr e)

let joystick_is_haptic = 
  foreign "SDL_JoystickIsHaptic" 
    (joystick @-> returning bool_to_ok)

let mouse_is_haptic = 
  foreign "SDL_MouseIsHaptic" (void @-> returning bool_to_ok)
    
let num_haptics = 
  foreign "SDL_NumHaptics" (void @-> returning nat_to_ok)

(* Audio *)

(* Audio drivers *)

let audio_init = 
  foreign "SDL_AudioInit" (string_opt @-> returning zero_to_ok)

let audio_quit = 
  foreign "SDL_AudioQuit" (void @-> returning void)

let get_audio_driver = 
  foreign "SDL_GetAudioDriver" 
    (int @-> returning (some_to_ok string_opt))

let get_current_audio_driver = 
  foreign "SDL_GetCurrentAudioDriver" (void @-> returning string_opt)
  
let get_num_audio_drivers =
  foreign "SDL_GetNumAudioDrivers" (void @-> returning nat_to_ok)

(* Audio devices *) 

module Audio = struct
  type status = int
  let stopped = sdl_audio_stopped
  let playing = sdl_audio_playing
  let paused = sdl_audio_paused

  type format = int
  let format = int_as_uint16_t
  let s8 = audio_s8
  let u8 = audio_u8
  let s16_lsb = audio_s16lsb
  let s16_msb = audio_s16msb
  let s16_sys = audio_s16sys
  let s16 = audio_s16
  let s16_lsb = audio_s16lsb
  let u16_lsb = audio_u16lsb
  let u16_msb = audio_u16msb
  let u16_sys = audio_u16sys
  let u16 = audio_u16
  let u16_lsb = audio_u16lsb
  let s32_lsb = audio_s32lsb
  let s32_msb = audio_s32msb
  let s32_sys = audio_s32sys
  let s32 = audio_s32
  let s32_lsb = audio_s32lsb
  let f32_lsb = audio_f32lsb
  let f32_msb = audio_f32msb
  let f32_sys = audio_f32sys
  let f32 = audio_f32

  type allow = int
  let allow = int
  let allow_frequency_change = sdl_audio_allow_frequency_change
  let allow_format_change = sdl_audio_allow_format_change
  let allow_channels_change = sdl_audio_allow_channels_change
  let allow_any_change = sdl_audio_allow_any_change
end

type audio_device_id = Unsigned.uint32
let audio_device_id = uint32_t

type ('a, 'b) audio_spec = 
  { as_freq : int; 
    as_format : Audio.format;
    as_channels : uint8; 
    as_silence : uint8;
    as_samples : uint8;
    as_size : uint32;
    as_ba_kind : ('a, 'b) Bigarray.kind;
    as_callback : (('a, 'b) bigarray -> unit) option; }

let audio_callback = 
  (ptr void @-> ptr uint8_t @-> int @-> returning void)

type _audio_spec 
let audio_spec : _audio_spec structure typ = structure "SDL_AudioSpec"
let as_freq = field audio_spec "freq" int 
let as_format = field audio_spec "format" Audio.format
let as_channels = field audio_spec "channels" int_as_uint8_t
let as_silence = field audio_spec "silence" int_as_uint8_t
let as_samples = field audio_spec "samples" int_as_uint16_t
let _ = field audio_spec "padding" uint16_t 
let as_size = field audio_spec "size" int32_as_uint32_t
let as_callback = field audio_spec "callback" (funptr_opt audio_callback)
(* let as_callback = field audio_spec "callback" (ptr void) *)
let as_userdata = field audio_spec "userdata" (ptr void)
let () = seal audio_spec 

let audio_spec_of_c c as_ba_kind = 
  let as_freq = getf c as_freq in 
  let as_format = getf c as_format in 
  let as_channels = getf c as_channels in 
  let as_silence = getf c as_silence in
  let as_samples = getf c as_samples in
  let as_size = getf c as_size in
  let as_callback = None in
  { as_freq; as_format; as_channels; as_silence; as_samples; as_size; 
    as_ba_kind; as_callback; }

let audio_spec_to_c a = 
  let wrap_cb = match a.as_callback with 
  | None -> None
  | Some cb ->
      let kind_bytes = ba_kind_byte_size a.as_ba_kind in
      let ba_ptr_typ = access_ptr_typ_of_ba_kind a.as_ba_kind in
      Some begin fun _ p len ->
        let p = coerce (ptr uint8_t) ba_ptr_typ p in
        let len = len / kind_bytes in
        cb (bigarray_of_ptr array1 len a.as_ba_kind p)
      end
  in
  let c = make audio_spec in
  setf c as_freq a.as_freq; 
  setf c as_format a.as_format;
  setf c as_channels a.as_channels;
  setf c as_silence a.as_silence; (* irrelevant *)
  setf c as_samples a.as_samples;
  setf c as_size a.as_size;       (* irrelevant *) 
  setf c as_callback wrap_cb; (* FIXME: this will run on another thread 
                                 (=> acquire runtime lock) and may move
                                  does ctypes handle that ? *)
  setf c as_userdata null;
  c

let close_audio_device = 
  foreign "SDL_CloseAudioDevice" (audio_device_id @-> returning void)

let free_wav = 
  foreign "SDL_FreeWAV" (ptr void @-> returning void)

let free_wav ba = 
  free_wav (to_voidp (bigarray_start array1 ba))

let get_audio_device_name = 
  foreign "SDL_GetAudioDeviceName" 
    (int @-> bool @-> returning (some_to_ok string_opt))

let get_audio_device_status = 
  foreign "SDL_GetAudioDeviceStatus" (audio_device_id @-> returning int)

let get_num_audio_devices = 
  foreign "SDL_GetNumAudioDevices" (bool @-> returning nat_to_ok)

let load_wav_rw = 
  foreign "SDL_LoadWAV_RW" 
    (rw_ops @-> ptr audio_spec @-> ptr (ptr void) @-> ptr uint32_t @-> 
     returning (some_to_ok (ptr_opt audio_spec)))
       
let load_wav_rw ops spec = 
  let d = allocate (ptr void) null in
  let len = allocate uint32_t Unsigned.UInt32.zero in  
  match load_wav_rw ops (addr (audio_spec_to_c spec)) d len with 
  | `Error _ as e -> e
  | `Ok r ->
      let rspec = audio_spec_of_c (!@ r) spec.as_ba_kind in
      let kind_size = ba_kind_byte_size spec.as_ba_kind in
      let len = Unsigned.UInt32.to_int (!@ len) in
      if len mod kind_size <> 0 
      then invalid_arg (err_bigarray_data len kind_size)
      else
      let ba_size = len / kind_size in 
      let ba_ptr = access_ptr_typ_of_ba_kind spec.as_ba_kind in
      let d = coerce (ptr void)  ba_ptr (!@ d) in
      `Ok (rspec, bigarray_of_ptr array1 ba_size spec.as_ba_kind d)

let lock_audio_device = 
  foreign "SDL_LockAudioDevice" (audio_device_id @-> returning void)

let open_audio_device = 
  foreign "SDL_OpenAudioDevice" 
    (string_opt @-> bool @-> ptr audio_spec @-> ptr audio_spec @-> 
     Audio.allow @-> returning uint32_t)

let open_audio_device dev capture desired allow = 
  let desiredc = audio_spec_to_c desired in 
  let obtained = make audio_spec in 
  match open_audio_device dev capture (addr desiredc) (addr obtained) allow 
  with 
  | id when id = Unsigned.UInt32.zero -> error () 
  | id -> `Ok (id,  audio_spec_of_c obtained desired.as_ba_kind)

let pause_audio_device = 
  foreign "SDL_PauseAudioDevice" (audio_device_id @-> bool @-> returning void)

let unlock_audio_device = 
  foreign "SDL_UnlockAudioDevice" (audio_device_id @-> returning void)

(* Timer *)

let delay = 
  foreign "SDL_Delay" (int32_t @-> returning void)

let get_ticks = 
  foreign "SDL_GetTicks" (void @-> returning int32_t)

let get_performance_counter = 
  foreign "SDL_GetPerformanceCounter" (void @-> returning int64_t)

let get_performance_frequency = 
  foreign "SDL_GetPerformanceFrequency" (void @-> returning int64_t)
  
(* Platform and CPU information *)

let get_platform = 
  foreign "SDL_GetPlatform" (void @-> returning string)

let get_cpu_cache_line_size = 
  foreign "SDL_GetCPUCacheLineSize" (void @-> returning nat_to_ok)

let get_cpu_count = 
  foreign "SDL_GetCPUCount" (void @-> returning int)

let get_system_ram = 
  foreign "SDL_GetSystemRAM" (void @-> returning int)

let has_3d_now = 
  foreign "SDL_Has3DNow" (void @-> returning bool)

let has_altivec = 
  foreign "SDL_HasAltiVec" (void @-> returning bool)

let has_mmx = 
  foreign "SDL_HasMMX" (void @-> returning bool)

let has_rdtsc = 
  foreign "SDL_HasRDTSC" (void @-> returning bool)

let has_sse = 
  foreign "SDL_HasSSE" (void @-> returning bool)

let has_sse2 = 
  foreign "SDL_HasSSE2" (void @-> returning bool)

let has_sse3 = 
  foreign "SDL_HasSSE3" (void @-> returning bool)

let has_sse41 = 
  foreign "SDL_HasSSE41" (void @-> returning bool)

let has_sse42 = 
  foreign "SDL_HasSSE42" (void @-> returning bool)

(* Power management *)
    
type power_state = 
  [ `Unknown | `On_battery | `No_battery | `Charging | `Charged ] 
  
let power_state =
  [ sdl_powerstate_unknown, `Unknown; 
    sdl_powerstate_on_battery, `On_battery;
    sdl_powerstate_no_battery, `No_battery;
    sdl_powerstate_charging, `Charging;
    sdl_powerstate_charged, `Charged; ]
  
type power_info = 
  { pi_state : power_state; 
    pi_secs : int option; 
    pi_pct : int option; } 
  
let get_power_info = 
  foreign "SDL_GetPowerInfo" ((ptr int) @-> (ptr int) @-> returning int)
    
let get_power_info () =
  let secs = allocate int 0 in 
  let pct = allocate int 0 in
  let s = get_power_info secs pct in 
  let pi_state = try List.assoc s power_state with Not_found -> assert false in
  let pi_secs = match !@ secs with -1 -> None | secs -> Some secs in
  let pi_pct = match !@ pct with -1 -> None | pct -> Some pct in 
  { pi_state; pi_secs; pi_pct }

end
 
(*---------------------------------------------------------------------------
   Copyright (c) 2013 Daniel C. Bünzli.
   All rights reserved.

   Redistribution and use in source and binary forms, with or without
   modification, are permitted provided that the following conditions
   are met:
     
   1. Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

   2. Redistributions in binary form must reproduce the above
      copyright notice, this list of conditions and the following
      disclaimer in the documentation and/or other materials provided
      with the distribution.

   3. Neither the name of Daniel C. Bünzli nor the names of
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  ---------------------------------------------------------------------------*)