(*
 * OCamlSDL - An ML interface to the SDL library
 * Copyright (C) 1999  Frederic Brunel
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 *)

(* $Id: sdlevent.ml,v 1.13 2010/04/19 20:43:33 oliv__a Exp $ *)

exception Event_exn of string
let _ = 
  Callback.register_exception "sdlevent_exn" (Event_exn "")

type active_state = 
  | MOUSEFOCUS
  | INPUTFOCUS
  | APPACTIVE

external get_app_state : unit -> active_state list
    = "mlsdlevent_get_app_state"

type active_event = {
    gain     : bool ;
    ae_state : active_state list ;
  } 

type switch_state = 
  | RELEASED
  | PRESSED

type keyboard_event = {
    ke_which : int ;
    ke_state : switch_state ;
    keysym   : Sdlkey.t ;
    keymod   : Sdlkey.mod_state ;
    keycode  : char ;
    unicode  : int ;
  }

type mousemotion_event = {
    mme_which  : int ;
    mme_state  : Sdlmouse.button list ;
    mme_x    : int ;
    mme_y    : int ;
    mme_xrel : int ;
    mme_yrel : int ;
  } 

type mousebutton_event = {
    mbe_which  : int ;
    mbe_button : Sdlmouse.button ;
    mbe_state  : switch_state ;
    mbe_x : int ;
    mbe_y : int ;
  } 

type joyaxis_event = {
    jae_which : int ;
    jae_axis  : int ;
    jae_value : int ;
  } 

type joyball_event = {
    jle_which : int ;
    jle_ball  : int ;
    jle_xrel  : int ;
    jle_yrel  : int ;
  } 

type joyhat_event = {
    jhe_which : int ;
    jhe_hat   : int ;
    jhe_value : Sdljoystick.hat_value ;
  } 

type joybutton_event = {
    jbe_which  : int ;
    jbe_button : int ;
    jbe_state  : switch_state ;
  } 

type event = 
  | ACTIVE          of active_event
  | KEYDOWN         of keyboard_event
  | KEYUP           of keyboard_event
  | MOUSEMOTION     of mousemotion_event
  | MOUSEBUTTONDOWN of mousebutton_event
  | MOUSEBUTTONUP   of mousebutton_event
  | JOYAXISMOTION   of joyaxis_event
  | JOYBALLMOTION   of joyball_event
  | JOYHATMOTION    of joyhat_event
  | JOYBUTTONDOWN   of joybutton_event
  | JOYBUTTONUP     of joybutton_event
  | QUIT
  | SYSWM
  | VIDEORESIZE     of int * int
  | VIDEOEXPOSE
  | USER            of int

let string_of_event = function
  | ACTIVE _        -> "active"
  | KEYDOWN _       -> "key down"
  | KEYUP _         -> "key up"
  | MOUSEMOTION _   -> "mouse motion"
  | MOUSEBUTTONDOWN _ -> "mouse button down"
  | MOUSEBUTTONUP _ -> "mouse button up"
  | JOYAXISMOTION _ -> "joystick axis motion"
  | JOYBALLMOTION _ -> "joystick ball motion"
  | JOYHATMOTION _  -> "joystick hat motion"
  | JOYBUTTONDOWN _ -> "joystick button down"
  | JOYBUTTONUP _   -> "joystick button up"
  | QUIT            -> "quit"
  | SYSWM           -> "syswm"
  | VIDEORESIZE _   -> "resize"
  | VIDEOEXPOSE     -> "expose"
  | USER c          -> "user " ^ (string_of_int c)

type event_kind =
  | ACTIVE_EVENT 
  | KEYDOWN_EVENT 
  | KEYUP_EVENT 
  | MOUSEMOTION_EVENT 
  | MOUSEBUTTONDOWN_EVENT 
  | MOUSEBUTTONUP_EVENT 
  | JOYAXISMOTION_EVENT 
  | JOYBALL_EVENT 
  | JOYHAT_EVENT 
  | JOYBUTTONDOWN_EVENT 
  | JOYBUTTONUP_EVENT 
  | QUIT_EVENT 
  | SYSWM_EVENT 
  | RESIZE_EVENT 
  | EXPOSE_EVENT 
  | USER_EVENT

type event_mask = int

let active_mask          = 0x02
let keydown_mask         = 0x04
let keyup_mask           = 0x08
let mousemotion_mask     = 0x10
let mousebuttondown_mask = 0x20
let mousebuttonup_mask   = 0x40
let joyaxismotion_mask   = 0x80
let joyballmotion_mask   = 0x100
let joyhatmotion_mask    = 0x200
let joybuttondown_mask   = 0x400
let joybuttonup_mask     = 0x800
let quit_mask            = 0x1000
let syswmevent_mask      = 0x2000
let videoresize_mask     = 0x10000
let videoexpose_mask     = 0x20000
let userevent_mask       = 0x1000000

let keyboard_event_mask  = 0x0C
let mouse_event_mask     = 0x70
let joystick_event_mask  = 0xF80
let all_events_mask      = 0x7FFFFFFF

let make_mask = 
  List.fold_left
    (fun acc evt ->
      acc lor 
      ( match evt with
      | ACTIVE_EVENT -> active_mask
      | KEYDOWN_EVENT -> keydown_mask
      | KEYUP_EVENT -> keyup_mask
      | MOUSEMOTION_EVENT -> mousemotion_mask
      | MOUSEBUTTONDOWN_EVENT -> mousebuttondown_mask
      | MOUSEBUTTONUP_EVENT -> mousebuttonup_mask
      | JOYAXISMOTION_EVENT -> joyaxismotion_mask
      | JOYBALL_EVENT -> joyballmotion_mask
      | JOYHAT_EVENT -> joyhatmotion_mask
      | JOYBUTTONDOWN_EVENT -> joybuttondown_mask
      | JOYBUTTONUP_EVENT -> joybuttonup_mask
      | QUIT_EVENT -> quit_mask
      | SYSWM_EVENT -> syswmevent_mask
      | RESIZE_EVENT -> videoresize_mask
      | EXPOSE_EVENT -> videoexpose_mask
      | USER_EVENT-> userevent_mask ) )
    0x00

external pump : unit -> unit = "ml_SDL_PumpEvents"

external peek : ?mask:event_mask -> int -> event list = "mlsdlevent_peek"
external get  : ?mask:event_mask -> int -> event list = "mlsdlevent_get"

external add  : event list -> unit = "mlsdlevent_add"

external has_event : unit -> bool = "mlsdlevent_has_event"
external poll : unit -> event option = "mlsdlevent_poll"

external wait       : unit -> unit = "mlsdlevent_wait"
external wait_event : unit -> event = "mlsdlevent_wait_event"

(* SDL_PushEvent ? *)

(* SDL_SetEventFilter *)
(* SDL_GetEventFilter *)

external get_state : event_kind -> bool = "mlsdlevent_get_state"
external set_state : bool -> event_kind -> unit = "mlsdlevent_set_state"

external set_state_by_mask : event_mask -> bool -> unit
    = "mlsdlevent_set_state_by_mask"

let enable_events mask =
  set_state_by_mask mask true

let disable_events mask =
  set_state_by_mask mask false

external get_enabled_events : unit -> event_mask = "mlsdlevent_get_enabled"

let of_mask mask = 
  List.fold_left
    (fun acc (evt_t, m) ->
      if mask land m <> 0
      then evt_t :: acc 
      else acc )
    [] [ ( ACTIVE_EVENT, active_mask ) ;
	 ( KEYDOWN_EVENT, keydown_mask ) ;
	 ( KEYUP_EVENT, keyup_mask ) ;
	 ( MOUSEMOTION_EVENT, mousemotion_mask ) ;
	 ( MOUSEBUTTONDOWN_EVENT, mousebuttondown_mask ) ;
	 ( MOUSEBUTTONUP_EVENT, mousebuttonup_mask ) ;
	 ( JOYAXISMOTION_EVENT, joyaxismotion_mask ) ;
	 ( JOYBALL_EVENT, joyballmotion_mask ) ;
	 ( JOYHAT_EVENT, joyhatmotion_mask ) ;
	 ( JOYBUTTONDOWN_EVENT, joybuttondown_mask ) ;
	 ( JOYBUTTONUP_EVENT, joybuttonup_mask ) ;
	 ( QUIT_EVENT, quit_mask ) ;
	 ( SYSWM_EVENT, syswmevent_mask ) ;
	 ( RESIZE_EVENT, videoresize_mask ) ;
	 ( EXPOSE_EVENT, videoexpose_mask ) ;
	 ( USER_EVENT, userevent_mask ) ; ]


let link_me = 
  (* I need Sdlkey so that keysyms lookup tables are 
     initialised and registered *)
  Sdlkey.link_me

module Old = 
  struct

  type keyboard_event_func =
      Sdlkey.t -> switch_state -> int -> int -> unit
  type mouse_event_func =
      Sdlmouse.button -> switch_state -> int -> int -> unit
  type mousemotion_event_func = int -> int -> unit
  type idle_event_func = unit -> unit
  type resize_event_func = int -> int -> unit

  let keyboard_event_func = ref (fun _ _ _ _ -> ())
  let mouse_event_func = ref (fun _ _ _ _ -> ())
  let mousemotion_event_func = ref (fun _ _ -> ())
  let idle_event_func = ref ignore
  let resize_event_func = ref (fun _ _ -> ())

  let set_keyboard_event_func f = keyboard_event_func := f
  let set_mouse_event_func f = mouse_event_func := f
  let set_mousemotion_event_func f = mousemotion_event_func := f
  let set_idle_event_func f = idle_event_func := f
  let set_resize_event_func f = resize_event_func := f

  exception Quit

  let in_loop = ref false

  let exit_event_loop () = if !in_loop then raise Quit

  let start_event_loop () =
    let do_loop () =
      match poll () with
      | Some (KEYDOWN ev | KEYUP ev) ->
	  let x,y,_ = Sdlmouse.get_state () in
	  !keyboard_event_func ev.keysym ev.ke_state x y
      | Some (MOUSEBUTTONDOWN ev | MOUSEBUTTONUP ev) ->
	  let b = ev.mbe_button in
	  let x = ev.mbe_x in
	  let y = ev.mbe_y in
	  let st = ev.mbe_state in
	  !mouse_event_func b st x y
      | Some (MOUSEMOTION ev) ->
	  let x = ev.mme_x in
	  let y = ev.mme_y in
	  !mousemotion_event_func x y
      | Some (VIDEORESIZE (x,y)) -> !resize_event_func x y
      | None -> !idle_event_func ()
      | _ -> () in
    disable_events all_events_mask ;
    enable_events 
      (make_mask 
	 [ KEYDOWN_EVENT ; KEYUP_EVENT ;
	   MOUSEMOTION_EVENT ; MOUSEBUTTONUP_EVENT ;
	   MOUSEBUTTONDOWN_EVENT ; RESIZE_EVENT ; ]) ;
    try in_loop := true; while true do do_loop () done
    with Quit -> in_loop := false
end
