Source file tsdl.ml

(*---------------------------------------------------------------------------
   Copyright (c) 2013 The tsdl programmers. All rights reserved.
   SPDX-License-Identifier: ISC
  ---------------------------------------------------------------------------*)

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_read_field = "cannot read field"
let err_bigarray_pitch pitch ba_el_size =
  str "invalid bigarray kind: pitch (%d bytes) not a multiple of bigarray \
       element byte size (%d)" pitch ba_el_size

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

let err_array_to_short ~exp ~fnd =
  str "array too short exp:%d bytes found:%d bytes" exp fnd

(* 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 = CArray.length a in
    let b = Buffer.create len in
    try
      for i = 0 to len - 1 do
        let c = CArray.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 = CArray.make char n in
    let len = min (CArray.length a) (String.length s) in
    for i = 0 to len - 1 do CArray.set a i (s.[i]) done;
    a
  in
  view ~read ~write n_array

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

(* SDL results *)

type nonrec 'a result = ( 'a, [ `Msg of string ] ) result

let error () = Error (`Msg (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 ()

let stub = true


(* 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 ( - ) f f' = Unsigned.UInt32.(logand f (lognot f'))
  let test f m = Unsigned.UInt32.(compare (logand f m) zero <> 0)
  let eq f f' = Unsigned.UInt32.(compare f f' = 0)
  let nothing = i 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 audio_resampling_mode = sdl_hint_audio_resampling_mode
  let framebuffer_acceleration = sdl_hint_framebuffer_acceleration
  let idle_timer_disabled = sdl_hint_idle_timer_disabled
  let orientations = sdl_hint_orientations
  let mouse_focus_clickthrough = sdl_hint_mouse_focus_clickthrough
  let mouse_normal_speed_scale = sdl_hint_mouse_normal_speed_scale
  let mouse_relative_speed_scale = sdl_hint_mouse_relative_speed_scale
  let render_driver = sdl_hint_render_driver
  let render_logical_size_mode = sdl_hint_render_logical_size_mode
  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
  let no_signal_handlers = sdl_hint_no_signal_handlers
  let thread_stack_size = sdl_hint_thread_stack_size
  let touch_mouse_events = sdl_hint_touch_mouse_events
  let mouse_touch_events = sdl_hint_mouse_touch_events
  let window_frame_usable_while_cursor_hidden =
    sdl_hint_window_frame_usable_while_cursor_hidden

  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 get_hint_boolean =
  foreign "SDL_GetHintBoolean" (string @-> bool @-> returning bool)

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

external log_message : int -> int -> string -> unit = "ocaml_tsdl_log_message"
let log_message c p fmt = kpp (fun s -> log_message c p s) fmt

let log fmt = log_message Log.category_application Log.priority_info fmt
let log_critical c fmt = log_message c Log.priority_critical fmt
let log_debug c fmt = log_message c Log.priority_debug fmt
let log_info c fmt = log_message c Log.priority_info fmt
let log_error c fmt = log_message c Log.priority_error fmt
let log_verbose c fmt = log_message c Log.priority_verbose fmt
let log_warn c fmt = log_message c Log.priority_warn fmt

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

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 load_file_rw =
  foreign "SDL_LoadFile_RW"
    (rw_ops @-> ptr int @-> bool @-> returning (some_to_ok string_opt))

let load_file_rw rw_ops close =
  load_file_rw rw_ops (coerce (ptr void) (ptr int) null) close

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

let rw_from_const_mem =
  foreign "SDL_RWFromConstMem"
    (ocaml_string @-> int @-> returning (some_to_ok rw_ops_opt))

let rw_from_const_mem str = rw_from_const_mem
  (ocaml_string_start str) (String.length str)

let rw_from_mem =
  foreign "SDL_RWFromMem"
    (ocaml_bytes @-> int @-> returning (some_to_ok rw_ops_opt))

let rw_from_mem b = rw_from_mem (ocaml_bytes_start b) (Bytes.length b)

let load_file filename = (* defined as a macro in SDL_rwops.h *)
  match rw_from_file filename "rb" with
  | Error _ as e -> e
  | Ok rw -> load_file_rw rw true

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

let unsafe_rw_ops_of_ptr addr : rw_ops =
  from_voidp rw_ops_struct (ptr_of_raw_address addr)
let unsafe_ptr_of_rw_ops rw_ops =
  raw_address_of_ptr (to_voidp rw_ops)

(* 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

let unsafe_window_of_ptr addr : window =
  ptr_of_raw_address addr
let unsafe_ptr_of_window window =
  raw_address_of_ptr (to_voidp window)

(* 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)

  let set_r c r = setf c color_r (Unsigned.UInt8.of_int r)
  let set_g c g = setf c color_g (Unsigned.UInt8.of_int g)
  let set_b c b = setf c color_b (Unsigned.UInt8.of_int b)
  let set_a c a = setf c color_a (Unsigned.UInt8.of_int 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 set_x p x = setf p point_x x
  let set_y p y = setf p point_y y

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

(* Float Points *)

type _fpoint
type fpoint = _fpoint structure
let fpoint : fpoint typ = structure "SDL_FPoint"
let fpoint_x = field fpoint "x" float
let fpoint_y = field fpoint "y" float
let () = seal fpoint

module Fpoint = struct
  let create ~x ~y =
    let p = make fpoint in
    setf p fpoint_x x;
    setf p fpoint_y y;
    p

  let x p = getf p fpoint_x
  let y p = getf p fpoint_y

  let set_x p x = setf p fpoint_x x
  let set_y p y = setf p fpoint_y y

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

(* Vertices *)

type _vertex
type vertex = _vertex structure
let vertex : vertex typ = structure "SDL_Vertex"
let vertex_position = field vertex "position" fpoint
let vertex_color = field vertex "color" color
let vertex_tex_coord = field vertex "tex_coord" fpoint
let () = seal vertex

module Vertex = struct
  let create ~position ~color ~tex_coord =
    let v = make vertex in
    setf v vertex_position position;
    setf v vertex_color color;
    setf v vertex_tex_coord tex_coord;
    v

  let position v = getf v vertex_position
  let color v = getf v vertex_color
  let tex_coord v = getf v vertex_tex_coord

  let set_position v position = setf v vertex_position position
  let set_color v color = setf v vertex_color color
  let set_tex_coord v tex_coord = setf v vertex_tex_coord tex_coord

  let opt_addr = function
  | None -> coerce (ptr void) (ptr vertex) 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 set_x r x = setf r rect_x x
  let set_y r y = setf r rect_y y
  let set_w r w = setf r rect_w w
  let set_h r h = setf r rect_h h

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

(* Float Rectangle *)

type _frect
type frect = _frect structure
let frect : frect typ = structure "SDL_FRect"
let frect_x = field frect "x" float
let frect_y = field frect "y" float
let frect_w = field frect "w" float
let frect_h = field frect "h" float
let () = seal frect

module Frect = struct
  let create ~x ~y ~w ~h =
    let r = make frect in
    setf r frect_x x;
    setf r frect_y y;
    setf r frect_w w;
    setf r frect_h h;
    r

  let x r = getf r frect_x
  let y r = getf r frect_y
  let w r = getf r frect_w
  let h r = getf r frect_h

  let set_x r x = setf r frect_x x
  let set_y r y = setf r frect_y y
  let set_w r w = setf r frect_w w
  let set_h r h = setf r frect_h 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 a = CArray.of_list point ps in
  let ps = to_voidp (CArray.start a) in
  let res = make rect in
  if enclose_points ps (CArray.length a) (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 point_in_rect p r =
  (* SDL_FORCE_INLINE *)
  let px = Point.x p in
  let py = Point.y p in
  let rx = Rect.x r in
  let ry = Rect.y r in
  px >= rx && px < rx + Rect.w r && py >= ry && py < ry + Rect.h r

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 unsafe_palette_of_ptr addr : palette =
  from_voidp palette_struct (ptr_of_raw_address addr)
let unsafe_ptr_of_palette palette =
  raw_address_of_ptr (to_voidp palette)

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
  CArray.to_list
    (CArray.from_ptr (getf ps palette_colors) (getf ps palette_ncolors))

let get_palette_colors_ba p =
  let ps = !@ p in
  (* FIXME: ctypes should have a CArray.copy function *)
  let n = getf ps palette_ncolors in
  let ba = Bigarray.(Array1.create int8_unsigned c_layout (n * 4)) in
  let ba_ptr =
    CArray.from_ptr (coerce (ptr int) (ptr color) (bigarray_start array1 ba)) n
  in
  let ca = CArray.from_ptr (getf ps palette_colors) n in
  for i = 0 to n - 1 do CArray.set ba_ptr i (CArray.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 a = CArray.of_list color cs in
  set_palette_colors p (to_voidp (CArray.start a)) fst (CArray.length a)

(* 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

  type operation = int
  let add = sdl_blendoperation_add
  let subtract = sdl_blendoperation_subtract
  let rev_subtract = sdl_blendoperation_rev_subtract
  let minimum = sdl_blendoperation_minimum
  let maximum = sdl_blendoperation_maximum

  type factor = int
  let zero = sdl_blendfactor_zero
  let one = sdl_blendfactor_one
  let src_color = sdl_blendfactor_src_color
  let one_minus_src_color = sdl_blendfactor_one_minus_src_color
  let src_alpha = sdl_blendfactor_src_alpha
  let one_minus_src_alpha = sdl_blendfactor_one_minus_src_alpha
  let dst_color = sdl_blendfactor_dst_color
  let one_minus_dst_color = sdl_blendfactor_one_minus_dst_color
  let dst_alpha = sdl_blendfactor_dst_alpha
  let one_minus_dst_alpha = sdl_blendfactor_one_minus_dst_alpha

end

let compose_custom_blend_mode =
  foreign "SDL_ComposeCustomBlendMode"
    (int @-> int @-> int @-> int @-> int @-> int @-> returning int)

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 unsafe_pixel_format_of_ptr addr : pixel_format =
  from_voidp pixel_format_struct (ptr_of_raw_address addr)
let unsafe_ptr_of_pixel_format pixel_format =
  raw_address_of_ptr (to_voidp pixel_format)

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 unsafe_surface_of_ptr addr : surface =
  from_voidp surface_struct (ptr_of_raw_address addr)
let unsafe_ptr_of_surface surface =
  raw_address_of_ptr (to_voidp surface)

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 (Rect.opt_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 (Rect.opt_addr sr) dst (Rect.opt_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 create_rgb_surface_with_format =
  foreign "SDL_CreateRGBSurfaceWithFormat"
    (uint32_t @-> int @-> int @-> int @-> uint32_t @->
     returning (some_to_ok surface_opt))

let create_rgb_surface_with_format ~w ~h ~depth format =
  create_rgb_surface_with_format Unsigned.UInt32.zero w h depth format

let create_rgb_surface_with_format_from =
  foreign "SDL_CreateRGBSurfaceWithFormatFrom"
    (ptr void @-> int @-> int @-> int @-> int @-> uint32_t @->
     returning (some_to_ok surface_opt))

let create_rgb_surface_with_format_from p ~w ~h ~depth ~pitch format =
  (* FIXME: 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_with_format_from p w h depth pitch format

let duplicate_surface =
  foreign "SDL_DuplicateSurface" (surface @-> returning surface)

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 a = CArray.of_list rect rs in
  fill_rects s (to_voidp (CArray.start a)) (CArray.length a) 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

let unsafe_texture_of_ptr addr : texture =
  ptr_of_raw_address addr
let unsafe_ptr_of_texture texture =
  raw_address_of_ptr (to_voidp texture)

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

let unsafe_renderer_of_ptr addr : renderer =
  ptr_of_raw_address addr
let unsafe_ptr_of_renderer renderer =
  raw_address_of_ptr (to_voidp renderer)

module Renderer = struct
  type flags = Unsigned.uint32
  let i = Unsigned.UInt32.of_int
  let ( + ) = Unsigned.UInt32.logor
  let ( - ) f f' = Unsigned.UInt32.(logand f (lognot f'))
  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 := (CArray.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_line_f =
  foreign "SDL_RenderDrawLineF"
    (renderer @-> float @-> float @-> float @-> float @-> 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 a = CArray.of_list point ps in
  render_draw_lines r (to_voidp (CArray.start a)) (CArray.length a)

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 a = CArray.of_list point ps in
  render_draw_points r (to_voidp (CArray.start a)) (CArray.length a)

let render_draw_point_f =
  foreign "SDL_RenderDrawPointF"
    (renderer @-> float @-> float @-> returning zero_to_ok)

let render_draw_points_f =
  foreign "SDL_RenderDrawPointsF"
    (renderer @-> ptr void @-> int @-> returning zero_to_ok)

let render_draw_points_f_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_f r ps count

let render_draw_points_f r ps =
  let a = CArray.of_list fpoint ps in
  render_draw_points_f r (to_voidp (CArray.start a)) (CArray.length a)

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 a = CArray.of_list rect rs in
  render_draw_rects r (to_voidp (CArray.start a)) (CArray.length a)

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 a = CArray.of_list rect rs in
  render_fill_rects r (to_voidp (CArray.start a)) (CArray.length a)

let render_geometry =
  foreign "SDL_RenderGeometry"
    (renderer @-> texture @-> ptr void @-> int @-> ptr void @-> int @->
     returning zero_to_ok)

let render_geometry ?indices ?texture r vertices =
  let a1 = CArray.of_list vertex vertices in
  let t = match texture with
  | None -> null | Some texture -> texture
  in
  let a2_ptr, a2_len = match indices with
  | None -> (null, 0)
  | Some is ->
      let a2 = CArray.of_list int is in
      (to_voidp (CArray.start a2), CArray.length a2)
  in
  render_geometry
    r t (to_voidp (CArray.start a1)) (CArray.length a1) a2_ptr a2_len

let render_geometry_raw =
  foreign "SDL_RenderGeometryRaw"
    (renderer @-> texture @->
     ptr void @-> int @->
     ptr void @-> int @->
     ptr void @-> int @->
     int @-> ptr void @-> int @-> int @-> returning zero_to_ok)

let render_geometry_raw
    ?indices ?texture r ~xy ?(xy_stride = 8) ~color ?(color_stride = 4)
    ~uv ?(uv_stride = 8) ~num_vertices ()
  =
  let t = match texture with
  | None -> null | Some texture -> texture
  in
  let i_ptr, i_len = match indices with
  | None -> null, 0
  | Some is -> to_voidp (bigarray_start array1 is), Bigarray.Array1.dim is
  in
  let i_stride = 4 in (* indices are assumed to be 4-byte integers *)
  let xy_ptr = to_voidp (bigarray_start array1 xy) in
  let xy_len_bytes = Bigarray.Array1.dim xy * 4 in
  let xy_exp_bytes = num_vertices * xy_stride - (xy_stride - 8) in
  if xy_len_bytes < xy_exp_bytes then begin
    let msg = "xy " ^ err_array_to_short ~exp:xy_exp_bytes ~fnd:xy_len_bytes in
    invalid_arg msg
  end;
  let color_ptr = to_voidp (bigarray_start array1 color) in
  let color_len_bytes = Bigarray.Array1.dim color in
  let color_exp_bytes = num_vertices * color_stride - (color_stride - 4) in
  if color_len_bytes < color_exp_bytes then begin
    let msg =
      "color " ^ err_array_to_short ~exp:color_exp_bytes ~fnd:color_len_bytes
    in
    invalid_arg msg
  end;
  let uv_ptr = to_voidp (bigarray_start array1 uv) in
  let uv_len_bytes = Bigarray.Array1.dim uv * 4 in
  let uv_exp_bytes = num_vertices * uv_stride - (uv_stride - 8) in
  if uv_len_bytes < uv_exp_bytes then begin
    let msg =
      "uv " ^ err_array_to_short ~exp:uv_exp_bytes ~fnd:uv_len_bytes
    in
    invalid_arg msg
  end;
  render_geometry_raw
    r t xy_ptr xy_stride color_ptr color_stride uv_ptr uv_stride num_vertices
    i_ptr i_len i_stride

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_is_clip_enabled =
  foreign "SDL_RenderIsClipEnabled" (renderer @-> returning bool)

let render_get_integer_scale =
 foreign "SDL_RenderGetIntegerScale"
    (renderer @-> returning bool)

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 ~release_runtime_lock:true "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_integer_scale =
  foreign "SDL_RenderSetIntegerScale"
    (renderer @-> bool @-> returning zero_to_ok)

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_dpi =
  foreign "SDL_GetDisplayDPI"
    (int @-> ptr float @-> ptr float @-> ptr float @-> returning zero_to_ok)

let get_display_dpi display =
  let diagonal = allocate float 0. in
  let horizontal = allocate float 0. in
  let vertical = allocate float 0. in
  match get_display_dpi display diagonal horizontal vertical with
  | Ok () -> Ok (!@diagonal,!@horizontal,!@vertical)
  | Error _ as err -> err

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_display_usable_bounds =
  foreign "SDL_GetDisplayUsableBounds"
    (int @-> ptr rect @-> returning zero_to_ok)

let get_display_usable_bounds i =
  let r = make rect in
  match get_display_usable_bounds i (addr r) with
  | Ok () -> Ok r | 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 ( - ) f f' = Unsigned.UInt32.(logand f (lognot f'))
  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 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
  let allow_highdpi = i sdl_window_allow_highdpi
  let mouse_capture = i sdl_window_mouse_capture
  let always_on_top = i sdl_window_always_on_top
  let skip_taskbar = i sdl_window_skip_taskbar
  let utility = i sdl_window_utility
  let popup_menu = i sdl_window_popup_menu
  let vulkan = i sdl_window_vulkan
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_borders_size =
  foreign "SDL_GetWindowBordersSize"
    (window @-> ptr int @-> ptr int @-> ptr int @-> ptr int @->
     returning zero_to_ok)

let get_window_borders_size w =
  let top = allocate int 0 in
  let left = allocate int 0 in
  let bottom = allocate int 0 in
  let right = allocate int 0 in
  match get_window_borders_size w top bottom left right with
  | Ok () -> Ok (!@ top, !@ left, !@ bottom, !@ right)
  | Error _ as err -> err

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_grabbed_window =
  foreign "SDL_GetGrabbedWindow" (void @-> returning window)

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_opacity =
  foreign "SDL_GetWindowOpacity"
    (window @-> (ptr float) @-> returning zero_to_ok)

let get_window_opacity win =
  let x = allocate float 0. in
  match get_window_opacity win x with
  | Ok () -> Ok !@x
  | Error _ as e -> e

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_input_focus =
  foreign "SDL_SetWindowInputFocus" (window @-> returning zero_to_ok)

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_modal_for =
  foreign "SDL_SetWindowModalFor" ( window @-> window @-> returning zero_to_ok)

let set_window_modal_for ~modal ~parent = set_window_modal_for modal parent

let set_window_opacity =
  foreign "SDL_SetWindowOpacity" ( window @-> float @-> returning zero_to_ok)

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_resizable =
  foreign "SDL_SetWindowResizable" (window @-> bool @-> returning void)

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 a = CArray.of_list rect rs in
  let rs = to_voidp (CArray.start a) in
  update_window_surface_rects w rs (CArray.length a)

(* 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

let unsafe_gl_context_of_ptr addr : gl_context =
  ptr_of_raw_address addr
let unsafe_ptr_of_gl_context gl_context =
  raw_address_of_ptr (to_voidp gl_context)

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 context_release_behavior = sdl_gl_context_release_behavior
  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 int_to_ok =
  let read n = Ok n in
  view ~read ~write:write_never int

let gl_get_swap_interval =
  foreign "SDL_GL_GetSwapInterval" (void @-> returning int_to_ok)

let gl_make_current =
  foreign "SDL_GL_MakeCurrent"
    (window @-> gl_context @-> returning zero_to_ok)

let gl_reset_attributes =
  foreign "SDL_GL_ResetAttributes" ~stub (void @-> returning void)

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)

(* Vulkan *)

module Vulkan = struct

  type instance = unit ptr
  let instance = ptr void
  let unsafe_ptr_of_instance = raw_address_of_ptr
  let unsafe_instance_of_ptr x = ptr_of_raw_address x

  type surface = uint64
  let surface = int64_t
  let unsafe_uint64_of_surface x = x
  let unsafe_surface_of_uint64 x = x

  let load_library =
    foreign "SDL_Vulkan_LoadLibrary" (string_opt @-> returning zero_to_ok)

  let unload_library =
    foreign "SDL_Vulkan_UnloadLibrary" (void @-> returning void)

  let get_instance_extensions =
    foreign "SDL_Vulkan_GetInstanceExtensions"
      (window @-> ptr int @-> ptr string @-> returning bool)

  let get_instance_extensions window =
    let n = allocate int 0 in
    match get_instance_extensions window n
            (Ctypes.coerce (ptr void) (ptr string) null) with
    | false -> None
    | true ->
        let exts = allocate_n string ~count:(!@n) in
        match get_instance_extensions window n exts with
        | false -> None
        | true -> Some CArray.(to_list @@ from_ptr exts (!@n))

  let create_surface =
    foreign "SDL_Vulkan_CreateSurface"
      (window @-> instance @-> ptr surface @-> returning bool)

  let create_surface window instance =
    let s = allocate_n surface ~count:1 in
    if create_surface window instance s then
      Some !@s
    else
    None

  let get_drawable_size =
    foreign "SDL_Vulkan_GetDrawableSize"
      (window @-> ptr int @-> ptr int @-> returning void)

  let get_drawable_size window =
    let w = allocate int 0 in
    let h = allocate int 0 in
    get_drawable_size window w h;
    !@w, !@h
end

(* 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_no_default = i 0
  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
    CArray.start (CArray.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 = CArray.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 (ptr char))

let get_clipboard_text () =
  let p = get_clipboard_text () in
  if (to_voidp p) = null then error () else
  let b = Buffer.create 255 in
  let ptr = ref p in
  while (!@ !ptr) <> '\000' do
    Buffer.add_char b (!@ !ptr);
    ptr := !ptr +@ 1;
  done;
  sdl_free (to_voidp p);
  Ok (Buffer.contents b)

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 = int
let keycode = int

module K = struct
  let scancode_mask = sdlk_scancode_mask
  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

let unsafe_cursor_of_ptr addr : cursor =
  ptr_of_raw_address addr
let unsafe_ptr_of_cursor cursor =
  raw_address_of_ptr (to_voidp cursor)

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 left = sdl_button_left
  let right = sdl_button_right
  let middle = sdl_button_middle
  let x1 = sdl_button_x1
  let x2 = sdl_button_x2

  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 capture_mouse =
  foreign "SDL_CaptureMouse" (bool @-> returning zero_to_ok)

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_global_mouse_state =
  foreign "SDL_GetGlobalMouseState"
    (ptr int @-> ptr int @-> returning int32_as_uint32_t)

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

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

let warp_mouse_global=
  foreign "SDL_WarpMouseGlobal" (int @-> int @-> returning zero_to_ok)

let warp_mouse_global ~x ~y =
  warp_mouse_global x y

(* Touch *)

type touch_id = int64
let touch_id = int64_t
let touch_mouse_id = Int64.of_int32 (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

let unsafe_joystick_of_ptr addr : joystick =
  ptr_of_raw_address addr
let unsafe_ptr_of_joystick joystick =
  raw_address_of_ptr (to_voidp joystick)

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

module Joystick_power_level = struct
  type t = int
  let unknown = sdl_joystick_power_unknown
  let low = sdl_joystick_power_low
  let medium = sdl_joystick_power_medium
  let full = sdl_joystick_power_full
  let wired = sdl_joystick_power_wired
  let max = sdl_joystick_power_max
end

module Joystick_type = struct
  type t = int
  let unknown        = sdl_joystick_type_unknown
  let gamecontroller = sdl_joystick_type_gamecontroller
  let wheel          = sdl_joystick_type_wheel
  let arcade_stick   = sdl_joystick_type_arcade_stick
  let flight_stick   = sdl_joystick_type_flight_stick
  let dance_pad      = sdl_joystick_type_dance_pad
  let guitar         = sdl_joystick_type_guitar
  let drum_kit       = sdl_joystick_type_drum_kit
  let arcade_pad     = sdl_joystick_type_arcade_pad
  let throttle      = sdl_joystick_type_throttle
end

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

let joystick_current_power_level =
  foreign "SDL_JoystickCurrentPowerLevel"
    (joystick @-> returning int)

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

let joystick_from_instance_id =
  foreign "SDL_JoystickFromInstanceID" (joystick_id @-> returning joystick)

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_axis_initial_state =
  foreign "SDL_JoystickGetAxisInitialState"
    (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_device_product =
  foreign "SDL_JoystickGetDeviceProduct" (int @-> returning int_as_uint16_t)

let joystick_get_device_product_version =
  foreign "SDL_JoystickGetDeviceProductVersion"
    (int @-> returning int_as_uint16_t)

let joystick_get_device_type =
  foreign "SDL_JoystickGetDeviceType" (int @-> returning int)

let joystick_get_device_instance_id =
  foreign "SDL_JoystickGetDeviceInstanceID" (int @-> returning joystick_id)

let joystick_get_device_vendor =
  foreign "SDL_JoystickGetDeviceVendor" (int @-> returning int_as_uint16_t)

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 = CArray.start (CArray.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_get_product =
  foreign "SDL_JoystickGetProduct" (joystick @-> returning int_as_uint16_t)

let joystick_get_product_version =
  foreign "SDL_JoystickGetProductVersion"
    (joystick @-> returning int_as_uint16_t)

let joystick_get_type =
  foreign "SDL_JoystickGetType" (joystick @-> returning int)

let joystick_get_vendor =
  foreign "SDL_JoystickGetVendor" (joystick @-> returning int_as_uint16_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

let unsafe_game_controller_of_ptr addr : game_controller =
  ptr_of_raw_address addr
let unsafe_ptr_of_game_controller game_controller =
  raw_address_of_ptr (to_voidp game_controller)

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)

let game_controller_add_mapping_from_rw =
  foreign "SDL_GameControllerAddMappingsFromRW"
    ~stub (rw_ops @-> bool @-> 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_from_instance_id =
  foreign "SDL_GameControllerFromInstanceID"
    (joystick_id @-> returning game_controller)

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_product =
  foreign "SDL_GameControllerGetProduct"
    (game_controller @-> returning int_as_uint16_t)

let game_controller_get_product_version =
  foreign "SDL_GameControllerGetProductVersion"
    (game_controller @-> returning int_as_uint16_t)

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_get_vendor =
  foreign "SDL_GameControllerGetVendor"
    (game_controller @-> returning int_as_uint16_t)

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

let game_controller_mapping_for_index =
  foreign "SDL_GameControllerMappingForIndex"
    (int @-> 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_num_mappings =
  foreign "SDL_GameControllerNumMappings" (void @-> returning int)

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 window_id = field t "windowID" int_as_uint32_t
    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 clicks = field t "clicks" int_as_uint8_t
    let _ = field t "padding1" 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

    type mouse_wheel_direction = int
    let mouse_wheel_normal = sdl_mousewheel_normal
    let mouse_wheel_flipped = sdl_mousewheel_flipped

  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 direction = field t "direction" int_as_uint32_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 Sensor_event = struct
    type t
    let t : t structure typ = structure "SDL_SensorEvent"
    let _ = field t "type" int_as_uint32_t
    let _ = field t "timestamp" int32_as_uint32_t
    let which = field t "which" int32_as_uint32_t
    (* FIXME: No array here, see
       https://github.com/ocamllabs/ocaml-ctypes/issues/113 *)
    let data0 = field t "data0" float
    let data1 = field t "data1" float
    let data2 = field t "data2" float
    let data3 = field t "data3" float
    let data4 = field t "data4" float
    let data5 = field t "data5" float
    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

  module Display_event = struct
    type t
    let t : t structure typ = structure "SDL_DisplayEvent"
    let _ = field t "type" int_as_uint32_t
    let _ = field t "timestamp" int32_as_uint32_t
    let display = field t "display" int32_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 () = seal t
  end

  module Audio_device_event = struct
    type t
    let t : t structure typ = structure "SDL_AudioDevice"
    let _ = field t "type" int_as_uint32_t
    let timestamp = field t "timestamp" int32_as_uint32_t
    let which = field t "which" int32_as_uint32_t
    let iscapture = field t "iscapture" int_as_uint8_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 audio_device_event = field t "adevice" Audio_device_event.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 display_event = field t "display" Display_event.t
  let sensor_event = field t "sensor" Sensor_event.t
  let padding = field t "padding"
      (abstract ~name:"padding" ~size:tsdl_sdl_event_size ~alignment: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_text = sdl_droptext
  let drop_begin = sdl_dropbegin
  let drop_complete = sdl_dropcomplete

  let drop_file_file = F (drop_event, Drop_event.file)
  let drop_window_id = F (drop_event, Drop_event.window_id)

  let drop_file_free e =
    let sp = to_voidp (get e drop_file_file) in
    if is_null sp then () else sdl_free sp

  let drop_file_file e =
    let sp = get e drop_file_file in
    if is_null sp then None else Some (coerce (ptr char) string sp)

  (* 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 keymap_changed = sdl_keymapchanged

  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_clicks = F (mouse_button_event, Mouse_button_event.clicks)
  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)
  let mouse_wheel_direction = F(mouse_wheel_event, Mouse_wheel_event.direction)

  (* 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_event_take_focus = sdl_windowevent_take_focus
  let window_event_hit_test = sdl_windowevent_hit_test

  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 *)

  type window_event_enum =
    [ `Close | `Enter | `Exposed | `Focus_gained | `Focus_lost | `Hidden
    | `Hit_test | `Leave | `Maximized | `Minimized | `Moved | `Resized
    | `Restored | `Shown | `Size_changed | `Take_focus
    | `Unknown of window_event_id ]

  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;
      window_event_take_focus, `Take_focus;
      window_event_hit_test, `Hit_test; ]
    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 -> `Unknown id

  (* Display event *)

  let display_display =
    F (display_event, Display_event.display)

  let display_event_id =
    F (display_event, Display_event.event)

  let display_data1 =
    F (display_event, Display_event.data1)

  let display_event = sdl_displayevent

  (* Sensor event *)

  let sensor_which =
    F (sensor_event, Sensor_event.which)

  let sensor_data0 =
    F (sensor_event, Sensor_event.data0)

  let sensor_data1 =
    F (sensor_event, Sensor_event.data1)

  let sensor_data2 =
    F (sensor_event, Sensor_event.data2)

  let sensor_data3 =
    F (sensor_event, Sensor_event.data3)

  let sensor_data4 =
    F (sensor_event, Sensor_event.data4)

  let sensor_data5 =
    F (sensor_event, Sensor_event.data5)

  let sensor_update = sdl_sensorupdate

  (* Render events *)

  let render_targets_reset = sdl_render_targets_reset
  let render_device_reset = sdl_render_device_reset

  (* Audio device event *)

  let audio_device_added = sdl_audiodeviceadded
  let audio_device_removed = sdl_audiodeviceremoved

  let audio_device_timestamp =
    F (audio_device_event, Audio_device_event.timestamp)

  let audio_device_which =
    F (audio_device_event, Audio_device_event.which)

  let audio_device_is_capture =
    F (audio_device_event, Audio_device_event.iscapture)

  (* Event type enum *)

  type enum =
  [ `App_did_enter_background | `App_did_enter_foreground
  | `App_low_memory | `App_terminating | `App_will_enter_background
  | `App_will_enter_foreground
  | `Audio_device_added | `Audio_device_removed
  | `Clipboard_update | `Controller_axis_motion | `Controller_button_down
  | `Controller_button_up | `Controller_device_added
  | `Controller_device_remapped | `Controller_device_removed
  | `Dollar_gesture | `Dollar_record
  | `Drop_begin | `Drop_complete | `Drop_file | `Drop_text
  | `Finger_down | `Finger_motion | `Finger_up
  | `Keymap_changed
  | `Joy_axis_motion | `Joy_ball_motion
  | `Joy_button_down | `Joy_button_up | `Joy_device_added
  | `Joy_device_removed | `Joy_hat_motion | `Key_down | `Key_up
  | `Mouse_button_down | `Mouse_button_up | `Mouse_motion
  | `Mouse_wheel | `Multi_gesture | `Quit
  | `Render_targets_reset | `Render_device_reset
  | `Sys_wm_event
  | `Text_editing | `Text_input | `Unknown of int | `User_event
  | `Window_event | `Display_event | `Sensor_update ]

  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;
                  audio_device_added, `Audio_device_added;
                  audio_device_removed, `Audio_device_removed;
                  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_begin, `Drop_begin;
                  drop_complete, `Drop_complete;
                  drop_file, `Drop_file;
                  drop_text, `Drop_text;
                  finger_down, `Finger_down;
                  finger_motion, `Finger_motion;
                  finger_up, `Finger_up;
                  keymap_changed, `Keymap_changed;
                  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;
                  render_targets_reset, `Render_targets_reset;
                  render_device_reset, `Render_device_reset;
                  sys_wm_event, `Sys_wm_event;
                  text_editing, `Text_editing;
                  text_input, `Text_input;
                  user_event, `User_event;
                  quit, `Quit;
                  window_event, `Window_event;
                  display_event, `Display_event;
                  sensor_update, `Sensor_update; ]
    in
    List.fold_left add Imap.empty enums

  let enum t = try Imap.find t enum_of_event_type with Not_found -> `Unknown t

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 ~release_runtime_lock:true
    "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" ~release_runtime_lock:true
    (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

let unsafe_haptic_of_ptr addr : haptic =
  ptr_of_raw_address addr
let unsafe_ptr_of_haptic haptic =
  raw_address_of_ptr (to_voidp haptic)

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 = CArray.of_list uint16_t l in
        CArray.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 = int32
let audio_device_id = int32_as_uint32_t

type audio_callback =
  unit Ctypes_static.ptr -> Unsigned.uint8 Ctypes_static.ptr -> int -> unit

let audio_callback kind f =
  let kind_bytes = ba_kind_byte_size kind in
  let ba_ptr_typ = access_ptr_typ_of_ba_kind kind in
  fun _ p len ->
    let p = coerce (ptr uint8_t) ba_ptr_typ p in
    let len = len / kind_bytes in
    f (bigarray_of_ptr array1 len kind p)

type audio_spec =
  { as_freq : int;
    as_format : Audio.format;
    as_channels : uint8;
    as_silence : uint8;
    as_samples : uint8;
    as_size : uint32;
    as_callback : audio_callback option; }

let audio_callback kind f =
  let kind_bytes = ba_kind_byte_size kind in
  let ba_ptr_typ = access_ptr_typ_of_ba_kind kind in
  fun _ p len ->
    let p = coerce (ptr uint8_t) ba_ptr_typ p in
    let len = len / kind_bytes in
    f (bigarray_of_ptr array1 len kind p)

let as_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 ~thread_registration:true ~runtime_lock:true as_callback)

let as_userdata = field audio_spec "userdata" (ptr void)
let () = seal audio_spec

let audio_spec_of_c c =
  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_callback; }

let audio_spec_to_c a =
  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 a.as_callback;
  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 ~release_runtime_lock:true "SDL_LoadWAV_RW"
    (rw_ops @-> int @-> ptr audio_spec @-> ptr (ptr void) @-> ptr uint32_t @->
     returning (some_to_ok (ptr_opt audio_spec)))

let load_wav_rw ops spec kind =
  let d = allocate (ptr void) null in
  let len = allocate uint32_t Unsigned.UInt32.zero in
  match load_wav_rw ops 0 (addr (audio_spec_to_c spec)) d len with
  | Error _ as e -> e
  | Ok r ->
      let rspec = audio_spec_of_c (!@ r) in
      let kind_size = ba_kind_byte_size 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 kind in
      let d = coerce (ptr void)  ba_ptr (!@ d) in
      Ok (rspec, bigarray_of_ptr array1 ba_size 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 int32_as_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 = Int32.zero -> error ()
  | id -> Ok (id,  audio_spec_of_c obtained)

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)

let queue_audio =
  foreign "SDL_QueueAudio"
    (audio_device_id @-> ptr void @-> int_as_uint32_t @-> returning zero_to_ok)

let queue_audio dev ba =
  let len = Bigarray.Array1.dim ba in
  let kind_size = ba_kind_byte_size (Bigarray.Array1.kind ba) in
  queue_audio dev (to_voidp (bigarray_start array1 ba)) (len * kind_size)

let dequeue_audio =
  foreign "SDL_DequeueAudio"
    (audio_device_id @-> ptr void @-> int @-> returning int_as_uint32_t)

let dequeue_audio dev ba =
  let len = Bigarray.Array1.dim ba in
  let kind_size = ba_kind_byte_size (Bigarray.Array1.kind ba) in
  dequeue_audio dev (to_voidp (bigarray_start array1 ba)) (len * kind_size)

let get_queued_audio_size =
  foreign "SDL_GetQueuedAudioSize"
    (audio_device_id @-> returning int_as_uint32_t)

let clear_queued_audio =
  foreign "SDL_ClearQueuedAudio" (audio_device_id @-> returning void)

(* Timer *)

let delay =
  foreign ~release_runtime_lock:true "SDL_Delay" (int32_t @-> returning void)

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

let get_ticks64 =
  foreign "SDL_GetTicks64" (void @-> returning int64_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_avx =
  foreign ~stub "SDL_HasAVX" (void @-> returning bool)

let has_avx2 =
  foreign  "SDL_HasAVX2" (void @-> returning bool)

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

let has_neon =
  foreign "SDL_HasNEON" (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