Skip to content

Instantly share code, notes, and snippets.

@atavener
Created January 12, 2015 22:55
Show Gist options
  • Save atavener/5ea1ec59a39dba4226eb to your computer and use it in GitHub Desktop.
Save atavener/5ea1ec59a39dba4226eb to your computer and use it in GitHub Desktop.
Safer and easier interface layer atop Tsdl.Sdl.Event
(* __ 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment