clutter-ocaml / src / clutter.ml

(* Initialization *)
external init : string array -> unit = "ml_clutter_init"
let finalize () = ()
    
let _ =
  init Sys.argv;
  at_exit finalize

external boom : unit -> 'a = "ml_abort"

type 'a obj = 'a Gobject.obj
type +'a event

(* opaque abstract types*)
type coords
type coglhandle
type units
type angle

let (+~) (a:units) (b:units) : units =
  Obj.magic ((Obj.magic a) + (Obj.magic b))
let (-~) (a:units) (b:units) : units =
  Obj.magic ((Obj.magic a) - (Obj.magic b))
let (>>~) (a:units) (b:int) : units =
  Obj.magic ((Obj.magic a) lsr (Obj.magic b))
let (<<~) (a:units) (b:int) : units =
  Obj.magic ((Obj.magic a) lsl b)
  
type vertex = {vx:units; vy:units; vz:units}
type actorbox = {x1:units; y1:units; x2:units; y2:units}
(*type knot = {x:int; y:int}*)
type knot = int*int
type geometry = {left:int; top:int; width:int; height:int}

type actor =     [`actor]
type container = [`container]
type behaviour = [`behaviour]
type score     = [`score]
type rectangle = [`rectangle|`actor]
type cairo_actor = [`cairo|`actor]
type cairo = cairo_actor
type texture =   [`texture|`actor]
type clone_texture = [`clonetexture|`actor]
type label =     [`label|`actor]
type entry =     [`entry|`actor]
  
type alpha =     [`alpha] 
type stage =     [`container|`stage|`actor|`group] 
type group =     [`container|`group|`actor] 
    
type behaviour_ellipse =   [`behaviour|`behaviourellipse]
type behaviour_opacity =   [`behaviour|`behaviouropacity]
type behaviour_bspline =   [`behaviour|`behaviourbspline]
type behaviour_path    =   [`behaviour|`behaviourpath]
type behaviour_depth   =   [`behaviour|`behaviourdepth]
type behaviour_scale   =   [`behaviour|`behaviourscale]
type behaviour_rotate   =   [`behaviour|`behaviourrotate]
type behaviour_alpha   =   [`behaviour|`behaviouralpha]    
	
type timeline =  [`timeline] 
type pixbuf =    GdkPixbuf.pixbuf

type coglbox = [`coglbox|`actor]

type alpha_fun_callback = alpha obj -> int
let max_alpha = 0xffff
type alpha_fun = [
  `RAMP_INC
| `RAMP_DEC
| `RAMP
| `SINE
| `SINE_INC
| `SINE_DEC
| `SINE_HALF
| `SQUARE
| `SMOOTHSTEP_INC
| `SMOOTHSTEP_DEC
| `EXP_INC
| `EXP_DEC
| `CUSTOM of alpha_fun_callback]
    
(** top level clutter routines *)
external clutter_main : unit -> unit = "clutter_main"
external clutter_quit : unit -> unit = "clutter_main_quit"
let main = clutter_main
let quit = clutter_quit
let main_quit = clutter_quit
  
external level : unit -> int = "clutter_main_level"
external get_debug_enabled : unit -> bool = "clutter_get_debug_enabled"
external get_show_fps : unit -> bool = "clutter_get_show_fps"
external get_timestamp : unit -> int = "clutter_get_timestamp"
external get_actor_by_gid : int -> actor obj = "clutter_get_actor_by_gid"
external set_default_frame_rate : int -> unit
  = "clutter_set_default_frame_rate"
external get_default_frame_rate : unit -> int
  = "clutter_get_default_frame_rate"
external set_motion_events_enabled : bool -> unit
  = "clutter_set_motion_events_enabled"
external get_motion_events_enabled : unit -> bool
  = "clutter_get_motion_events_enabled"
external set_motion_events_frequency : int -> unit
  = "clutter_set_motion_events_frequency"
external get_motion_events_frequency : unit -> int
  = "clutter_get_motion_events_frequency"
external set_use_mipmapped_text : bool -> unit
  = "clutter_set_use_mipmapped_text"
external get_use_mipmapped_text : unit -> bool
  = "clutter_get_use_mipmapped_text"
    (* thread function: init, enter, leave, idle, timeout... *)
external get_keyboard_grab : unit -> actor obj = "clutter_get_keyboard_grab"
external get_pointer_grab : unit -> actor obj = "clutter_get_pointer_grab"
external grab_keyboard : actor obj -> unit = "clutter_grab_keyboard"
external grab_pointer : actor obj -> unit = "clutter_grab_pointer"
external ungrab_keyboard : unit -> unit = "clutter_ungrab_keyboard"
external ungrab_pointer : unit -> unit = "clutter_ungrab_pointer"
    (* grab/ungrab pointer_for_device *)
(*external do_event : Event.event -> unit = "clutter_do_event"*)

(** Additional general glib functions *)

(** unit conversion *)
external units_to_int : units -> int = "ml_clutter_units_to_int"
external int_to_units : int -> units = "ml_clutter_int_to_units"
external units_to_float : units -> float = "ml_clutter_units_to_float"
external float_to_units : float -> units = "ml_clutter_float_to_units"
external angle_from_deg : float -> angle = "ml_clutter_angle_from_deg"
external angle_to_deg : angle -> float = "ml_clutter_angle_to_deg"
external angle_from_degx : units -> angle = "ml_clutter_angle_from_degx"
external angle_to_degx : angle -> units = "ml_clutter_angle_to_degx"
let units_from_float = float_to_units
let units_from_int = int_to_units
let to_device = units_to_int
let from_device = int_to_units
external from_stage_width_percentage : int -> units
  = "ml_clutter_from_stage_width_percentage"
external from_stage_height_percentage : int -> units
  = "ml_clutter_from_stage_height_percentage"
external from_parent_width_percentage : actor obj -> int -> units
  = "ml_clutter_from_parent_width_percentage"
external from_parent_height_percentage : actor obj -> int -> units
  = "ml_clutter_from_parent_height_percentage"

(** fixed points routines and constants *)
external sini : angle -> units = "ml_clutter_sini"
external cosi : angle -> units = "ml_clutter_cosi"
external cfx_qdiv : units -> units -> units = "ml_clutter_cfx_qdiv"
external cfx_one : unit -> units = "ml_clutter_cfx_one"
external cfx_qmul : units -> units -> units = "ml_clutter_cfx_qmul"
  
(* FIXME: put some correct enforcement here *)
external as_stage : 'a obj -> stage obj = "ml_clutter_as_container"
external as_container : 'a obj -> container obj = "ml_clutter_as_container"
external is_container : 'a obj -> bool = "ml_clutter_is_a_container"
exception TypeError
exception GError of string
let as_stage a =
  if Gobject.is_a a "ClutterStage" then Gobject.unsafe_cast a
  else raise TypeError
let as_actor a =
  if Gobject.is_a a "ClutterActor" then Gobject.unsafe_cast a
  else raise TypeError
let as_behaviour a =
  if Gobject.is_a a "ClutterBehaviour" then Gobject.unsafe_cast a
  else raise TypeError
let as_container c =
  if is_container c then Gobject.unsafe_cast c
  else raise TypeError


(* FIXME: use gobject.connect instead of gtksignal.connect ? *)
class ['a] gobject_signals obj = object
  val obj : 'a obj = obj
  val after = false
  method after = {< after = true >}
  method private connect : 'b. ('a,'b) GtkSignal.t -> callback:'b -> _ =
    fun sgn ~callback -> GtkSignal.connect obj ~sgn ~after ~callback
end

module CoglBox = struct
  external create : (actor obj -> unit) -> coglbox obj
    = "ml_caml_coglbox_new"
end
  
(**
   ClutterActorBox wrapper object
*)
module ActorBox = struct
  type t = Gpointer.boxed
  external x1 : t -> units = "ml_clutter_actorbox_get_x1"
  external y1 : t -> units = "ml_clutter_actorbox_get_y1"
  external x2 : t -> units = "ml_clutter_actorbox_get_x2"
  external y2 : t -> units = "ml_clutter_actorbox_get_y2"
  external create : x1:units -> y1:units -> x2:units -> y2:units -> t
    = "ml_clutter_actorbox_new"

  let wrap k = {x1 = x1 k; y1 = y1 k; x2 = x2 k; y2 = y2 k; }
  let unwrap k = create ~x1:k.x1 ~y1:k.y1 ~x2:k.x2 ~y2:k.y2
    
  let conv =
    { Gobject.kind = `POINTER;
      proj = (function `POINTER (Some k) -> wrap k
		| `POINTER None -> raise Gpointer.Null
		| _ -> failwith "GObj.get_object");
      inj = (fun k -> `POINTER (Some (unwrap k))) }

  let debug name b =
    Printf.printf "%s: {x1=%d y1=%d x2=%d y2=%d}\n%!" name
      (to_device b.x1) (to_device b.y1) (to_device b.x2) (to_device b.y2);
end;;

(** ClutterVertex object *)
module Vertex = struct
  type t
  external x : t -> units = "ml_clutter_vertex_get_x"
  external y : t -> units = "ml_clutter_vertex_get_y"
  external z : t -> units = "ml_clutter_vertex_get_z"
  external set_x : t -> units -> unit = "ml_clutter_vertex_set_x"
  external set_y : t -> units -> unit = "ml_clutter_vertex_set_y"
  external set_z : t -> units -> unit = "ml_clutter_vertex_set_z"
  external create : x:units -> y:units -> z:units -> t = "ml_clutter_vertex_new"

  class vertex_class obj = object
    method as_vertex : t = obj
    method x = x obj
    method y = y obj
    method z = z obj    
    method set_x = set_x obj
    method set_y = set_y obj
    method set_z = set_z obj
  end

  let vertex ~x ~y ~z =
    let k = create ~x ~y ~z in
    new vertex_class k

  let debug name v =
    Printf.printf "%s {x=%d y=%d z=%d}\n%!" name
      (to_device v.vx) (to_device v.vy) (to_device v.vz)
end

(**
   ClutterColor wrapper object
*)
module Color = struct
  type t = Gpointer.boxed
  external red : t -> int = "ml_clutter_color_get_red"
  external green : t -> int = "ml_clutter_color_get_green"
  external blue : t -> int = "ml_clutter_color_get_blue"
  external alpha : t -> int = "ml_clutter_color_get_alpha"
  external set_red : t -> int -> unit = "ml_clutter_color_set_red"
  external set_green : t -> int -> unit = "ml_clutter_color_set_green"
  external set_blue : t -> int -> unit = "ml_clutter_color_set_blue"
  external set_alpha : t -> int -> unit = "ml_clutter_color_set_alpha"
  external parse : name:string -> t = "ml_clutter_color_parse"
  external to_pixel : t -> int = "ml_clutter_color_to_pixel"
  external to_string : t -> string = "ml_clutter_color_to_string"
  external from_hls : int -> int -> int -> t = "ml_clutter_color_from_hls"
  external add : t -> t -> t = "ml_clutter_color_add"
  external subtract : t -> t -> t = "ml_clutter_color_subtract"
  external lighten : t -> t = "ml_clutter_color_lighten"
  external darken : t -> t = "ml_clutter_color_darken"
  external shade : t -> float -> t = "ml_clutter_color_shade"
  external to_hls : t -> (float*float*float) = "ml_clutter_color_to_hls"
  external create : red:int -> green:int -> blue:int -> alpha:int -> t
    = "ml_clutter_color_new"

  class color obj = object
    method as_color : t = obj
    method obj : t = obj
    method set_alpha = set_alpha obj
  end
    
  let rgba (red,green,blue,alpha) =
    new color (create ~red ~green ~blue ~alpha)
  let rgb (red,green,blue) =
    new color (create ~red ~green ~blue ~alpha:0xff)
  let parse name = new color (parse name)

  let as_color (c : color) = c#as_color
  let wrap_color w = new color w
  let unwrap_color w = w#as_color
  (*let conv_color_option =
    { kind = `POINTER;
      proj = (function `POINTER c -> may_map ~f:wrap_color c
		| _ -> failwith "GObj.get_object");
      inj = (fun c -> `POINTER (may_map ~f:unwrap_color c)) }*)
  let conv_color =
    { Gobject.kind = `POINTER;
      proj = (function `POINTER (Some c) -> wrap_color c
		| `POINTER None -> raise Gpointer.Null
		| _ -> failwith "GObj.get_object");
      inj = (fun c -> `POINTER (Some (unwrap_color c))) }
      
end;;
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.