Safer and easier interface layer atop Tsdl.Sdl.Event

ev.ml

(* __ Interface-layer atop Tsdl.Sdl.Event _______________
 *
 *
 * Rationale for not using Tsdl directly for events:
 *
 *   -Tsdl events are too raw -- easily able to read incorrect fields without
 *    generating a compile-time error.
 *
 *   -Tsdl events are cumbersome to use: "Sdl.Event.(get e long_field_name)",
 *    and event container "e" must be in scope.
 *
 *
 * Rationale for object representation (versus record):
 *
 *   -avoid duplication of common fields
 *
 *   -allow discriminatory fields to be pre-fetched and cached as values, with
 *    uniform access (member function)
 *
 *)

open Tsdl

module E = Sdl.Event


(* ~~ From Tsdl.Sdl ~~~~~~~~~~~~~~~ *)

(* Expose a few things from Sdl module, here... *)
let pressed = Sdl.pressed
let released = Sdl.released
module Button = Sdl.Button
module K = Sdl.K

 

(* NOTE on when to "get" a field: on object creation, or method call?
 *  -If a field is likely to be accessed at least once, do it on creation.
 *  -If a field is expected to be accessed rarely and only when handling and
 *   consuming the event, leave access to the method call.
 *)


(* ~~ Common fields ~~~~~~~~~~~~~~~ *)

class common e = object
  method enum      = E.(enum (get e typ))
  method timestamp = E.(get e timestamp)
end


(* ~~ Keyboard event ~~~~~~~~~~~~~~ *)

class keyboard e =
  let state    = E.(get e keyboard_state) in
  let scancode = E.(get e keyboard_scancode) in
  let keycode  = E.(get e keyboard_keycode) in
  let keymod   = E.(get e keyboard_keymod) in
  object
    inherit common e
    method window_id = E.(get e joy_axis_axis)
    method repeat    = E.(get e keyboard_repeat)
    method state     = state
    method scancode  = scancode
    method keycode   = keycode
    method keymod    = keymod
  end


(* ~~ Mouse event ~~~~~~~~~~~~~~~~~ *)

class mouse e which_field window_field = object
  inherit common e
  method which : Sdl.uint32 = E.(get e which_field)
  method window_id : int    = E.(get e window_field)
end
class mouse_button e =
  let button = E.(get e mouse_button_button) in
  object
    inherit mouse e E.mouse_button_which E.mouse_button_window_id
    method button = button
    method state  = E.(get e mouse_button_state)
    method clicks = E.(get e mouse_button_clicks)
    method x      = E.(get e mouse_button_x)
    method y      = E.(get e mouse_button_y)
  end
class mouse_motion e = object
  inherit mouse e E.mouse_motion_which E.mouse_motion_window_id
  method state = E.(get e mouse_motion_state)
  method x     = E.(get e mouse_motion_x)
  method y     = E.(get e mouse_motion_y)
  method xrel  = E.(get e mouse_motion_xrel)
  method yrel  = E.(get e mouse_motion_yrel)
end
class mouse_wheel e = object
  inherit mouse e E.mouse_wheel_which E.mouse_wheel_window_id
  method x = E.(get e mouse_wheel_x)
  method y = E.(get e mouse_wheel_y)
end


(* ~~ Joystick event ~~~~~~~~~~~~~~ *)

class joystick e which_field = object
  inherit common e
  method which : Sdl.uint32 = E.(get e which_field)
end
class joy_axis e = object
  inherit joystick e E.joy_axis_which
  method axis  = E.(get e joy_axis_axis)
  method value = E.(get e joy_axis_value)
end
class joy_ball e = object
  inherit joystick e E.joy_ball_which
  method ball = E.(get e joy_ball_ball)
  method xrel = E.(get e joy_ball_xrel)
  method yrel = E.(get e joy_ball_yrel)
end
class joy_hat e = object
  inherit joystick e E.joy_hat_which
  method hat   = E.(get e joy_hat_hat)
  method value = E.(get e joy_hat_value)
end
class joy_button e =
  let button = E.(get e joy_button_button) in
  object
    inherit joystick e E.joy_button_which
    method button = button
    method state  = E.(get e joy_button_state)
  end
class joy_device e = object
  inherit joystick e E.joy_device_which
end


(* ~~ Game-controller event ~~~~~~~ *)

class controller e which_field = object
  inherit common e
  method which : Sdl.uint32 = E.(get e which_field)
end
class game_axis e = object
  inherit controller e E.controller_axis_which
  method axis  = E.(get e controller_axis_axis)
  method value = E.(get e controller_axis_value)
end
class game_button e =
  let button = E.(get e controller_button_button) in
  object
    inherit controller e E.controller_button_which
    method button = button
    method state  = E.(get e controller_button_state)
  end
class game_device e = object
  inherit controller e E.controller_device_which
end


(* ~~ Text editing/input ~~~~~~~~~~ *)

class text e window_field text_field = object
  inherit common e
  method window_id : int = E.(get e window_field)
  method text : string   = E.(get e text_field)
end
class text_input e = object
  inherit text e E.text_input_window_id E.text_input_text
end
class text_editing e = object
  inherit text e E.text_editing_window_id E.text_editing_text
  method start  = E.(get e text_editing_start)
  method length = E.(get e text_editing_length)
end


(* ~~ Touch-finger event ~~~~~~~~~~ *)

class touch e = object
  inherit common e
  method touch_id  = E.(get e touch_finger_touch_id)
  method finger_id = E.(get e touch_finger_finger_id)
  method x         = E.(get e touch_finger_x)
  method y         = E.(get e touch_finger_y)
  method dx        = E.(get e touch_finger_dx)
  method dy        = E.(get e touch_finger_dy)
  method pressure  = E.(get e touch_finger_pressure)
end


(* ~~ Dollar-gesture event ~~~~~~~~ *)

class dollar_gesture e = object
  inherit common e
  method touch_id    = E.(get e dollar_gesture_touch_id)
  method gesture_id  = E.(get e dollar_gesture_gesture_id)
  method num_fingers = E.(get e dollar_gesture_num_fingers)
  method error       = E.(get e dollar_gesture_error)
  method x           = E.(get e dollar_gesture_x)
  method y           = E.(get e dollar_gesture_y)
end


(* ~~ Multi-gesture event ~~~~~~~~~ *)

class multi_gesture e = object
  inherit common e
  method touch_id    = E.(get e multi_gesture_touch_id)
  method dtheta      = E.(get e multi_gesture_dtheta)
  method ddist       = E.(get e multi_gesture_ddist)
  method x           = E.(get e multi_gesture_x)
  method y           = E.(get e multi_gesture_y)
  method num_fingers = E.(get e multi_gesture_num_fingers)
end


(* ~~ Drop-file event ~~~~~~~~~~~~~ *)

class drop_file e =
  let file = E.drop_file_file e in
  let () = E.drop_file_free e in
  object
    inherit common e
    method file = file
  end


(* ~~ Window event ~~~~~~~~~~~~~~~~ *)

type window_event =
  | Shown
  | Hidden
  | Exposed
  | Moved of int * int
  | Resized of int * int
  | SizeChanged
  | Minimized
  | Maximized
  | Restored
  | Enter
  | Leave
  | FocusGained
  | FocusLost
  | Close

class window e = object
  inherit common e
  method window_id = E.(get e window_window_id)
  method event =
    let int_field field = Int32.to_int (E.get e field) in
    match E.(window_event_enum (get e window_event_id)) with
      | `Close        -> Close
      | `Enter        -> Enter
      | `Exposed      -> Exposed
      | `Focus_gained -> FocusGained
      | `Focus_lost   -> FocusLost
      | `Hidden       -> Hidden
      | `Leave        -> Leave
      | `Maximized    -> Maximized
      | `Minimized    -> Minimized
      | `Moved        -> Moved (int_field E.window_data1, int_field E.window_data2)
      | `Resized      -> Resized (int_field E.window_data1, int_field E.window_data2)
      | `Restored     -> Restored
      | `Shown        -> Shown
      | `Size_changed -> SizeChanged
end


(* ---------------------------------------------------------------- *)

(* __ Event types and mappings from Tsdl events _________ *)

(* If I want to handle a key event generically....
 *
 *   function KeyDown k | KeyUp k -> on_key k state (fun -> ...)
 *)

type t =
  | KeyDown of keyboard
  | KeyUp of keyboard
  | MouseMotion of mouse_motion
  | MouseButtonDown of mouse_button
  | MouseButtonUp of mouse_button
  | MouseWheel of mouse_wheel
  | JoyAxis of joy_axis
  | JoyBall of joy_ball
  | JoyHat of joy_hat
  | JoyButtonDown of joy_button
  | JoyButtonUp of joy_button
  | JoyDeviceAdded of joy_device
  | JoyDeviceRemoved of joy_device
  | GameAxis of game_axis
  | GameButtonDown of game_button
  | GameButtonUp of game_button
  | GameDeviceAdded of game_device
  | GameDeviceRemapped of game_device
  | GameDeviceRemoved of game_device
  | TextInput of text_input
  | TextEditing of text_editing
  | FingerDown of touch
  | FingerMotion of touch
  | FingerUp of touch
  | DollarGesture of dollar_gesture
  | DollarRecord
  | MultiGesture of multi_gesture
  | Window of window
  | DropFile of drop_file
  | ClipboardUpdate
  | AppDidEnterBackground
  | AppDidEnterForeground
  | AppLowMemory
  | AppTerminating
  | AppWillEnterBackground
  | AppWillEnterForeground
  | Quit
  | Unknown

let of_tsdl_event e =
  match E.(enum (get e typ)) with
  | `Key_down                   -> KeyDown (new keyboard e)
  | `Key_up                     -> KeyUp (new keyboard e)
  | `Mouse_button_down          -> MouseButtonDown (new mouse_button e)
  | `Mouse_button_up            -> MouseButtonUp (new mouse_button e)
  | `Mouse_motion               -> MouseMotion (new mouse_motion e)
  | `Mouse_wheel                -> MouseWheel (new mouse_wheel e)
  | `Joy_axis_motion            -> JoyAxis (new joy_axis e)
  | `Joy_ball_motion            -> JoyBall (new joy_ball e)
  | `Joy_hat_motion             -> JoyHat (new joy_hat e)
  | `Joy_button_down            -> JoyButtonDown (new joy_button e)
  | `Joy_button_up              -> JoyButtonUp (new joy_button e)
  | `Joy_device_added           -> JoyDeviceAdded (new joy_device e)
  | `Joy_device_removed         -> JoyDeviceRemoved (new joy_device e)
  | `Controller_axis_motion     -> GameAxis (new game_axis e)
  | `Controller_button_down     -> GameButtonDown (new game_button e)
  | `Controller_button_up       -> GameButtonUp (new game_button e)
  | `Controller_device_added    -> GameDeviceAdded (new game_device e)
  | `Controller_device_remapped -> GameDeviceRemapped (new game_device e)
  | `Controller_device_removed  -> GameDeviceRemoved (new game_device e)
  | `Text_editing               -> TextEditing (new text_editing e)
  | `Text_input                 -> TextInput (new text_input e)
  | `Finger_down                -> FingerDown (new touch e)
  | `Finger_motion              -> FingerMotion (new touch e)
  | `Finger_up                  -> FingerUp (new touch e)
  | `Dollar_gesture             -> DollarGesture (new dollar_gesture e)
  | `Dollar_record              -> DollarRecord
  | `Multi_gesture              -> MultiGesture (new multi_gesture e)
  | `Window_event               -> Window (new window e)
  | `Drop_file                  -> DropFile (new drop_file e)
  | `Clipboard_update           -> ClipboardUpdate
  | `App_did_enter_background   -> AppDidEnterBackground
  | `App_did_enter_foreground   -> AppDidEnterForeground
  | `App_low_memory             -> AppLowMemory
  | `App_terminating            -> AppTerminating
  | `App_will_enter_background  -> AppWillEnterBackground
  | `App_will_enter_foreground  -> AppWillEnterForeground
  | `Quit                       -> Quit
  | `Sys_wm_event               -> failwith "SDL SysWMEvent unsupported"
  | `User_event                 -> failwith "SDL UserEvent unsupported"
  | _                           -> Unknown

let fold ~init fn =
  let e = Sdl.Event.create () in
  let rec next a =
    if Sdl.poll_event (Some e) then next (fn a (of_tsdl_event e))
                               else a
  in next init