1. Reid van Melle
  2. clutter-ocaml

Commits

Reid van Melle  committed 253e9d2

Got the test-project working properly

  • Participants
  • Parent commits 6da23a0
  • Branches default

Comments (0)

Files changed (17)

File TODO

View file
  • Ignore whitespace
+- check out the "Make_Val_final_pointer" ---> what is that all about
+- ensure that we are OK with using Val_int for the  ClutterUnit which are guint32
+- MEMORY MEMORY MEMORY
+- check out when to use copy_int32
 - implement struct types for points, colors, vertices, knots
+- figure out why I have all these pango errors
 - inherit container interface methods
 - inherit actor methods
 - switch to more vanilla ocaml makefile
    - will generate/clean auto-generated files
 
 - way to autogenerate struct code and classes
+- autogenerate property testing
 - replace with shared GTK code, types, modules when possible
 - add strategic named arguments
 - convert to object-oriented interface

File clutter/_tags

View file
  • Ignore whitespace
 <*>: use_clutter
 <clutterEnums.*> or <clutterProps.*> or <oclutterProps.*>: use_gtk
 <pangolibEnums.*>: use_gtk
-<clutterEllipse.*> or <clutterTimeline.*> or <clutterData.*>: use_gtk
+<clutterActor.*> or <clutterEllipse.*> or <clutterTimeline.*> or <clutterData.*>: use_gtk
 <clutter.*> or <structs.*>: use_gtk
 <ml_clutter.*>: use_gtk2
 <ml_texture.*>: use_gtk2

File clutter/clutter.ml

View file
  • Ignore whitespace
 	
 type timeline =  [`timeline] 
 type pixbuf =    GdkPixbuf.pixbuf
-
-module Event = struct
-  type t
-  type any
-end;;
     
 (** top level clutter routines *)
 external main : unit -> unit = "clutter_main"
 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.t -> unit = "clutter_do_event"
+(*external do_event : Event.event -> unit = "clutter_do_event"*)
 
 (** Additional general glib functions *)
 
-module Fixed = struct
-  external to_int : int -> int = "clutter_fixed_to_int"
-  external from_int : int -> int = "clutter_int_to_fixed"
-  external to_float : int -> float = "clutter_fixed_to_float"
+module Units = struct
+  external to_int : int -> int = "ml_clutter_fixed_to_int"
+  external from_int : int -> int = "ml_clutter_int_to_fixed"
+  external to_float : int -> float = "ml_clutter_fixed_to_float"
+  external from_float : float -> int = "ml_clutter_float_to_fixed"
+  let to_device = to_int
+  let from_device = from_int
+  external from_stage_width_percentage : int -> int
+    = "ml_clutter_from_stage_width_percentage"
+  external from_stage_height_percentage : int -> int
+    = "ml_clutter_from_stage_height_percentage"
+  external from_parent_width_percentage : actor obj -> int -> int
+    = "ml_clutter_from_parent_width_percentage"
+  external from_parent_height_percentage : actor obj -> int -> int
+    = "ml_clutter_from_parent_height_percentage"
 end
   
 (* FIXME: put some correct enforcement here *)
   method private connect : 'b. ('a,'b) GtkSignal.t -> callback:'b -> _ =
     fun sgn ~callback -> GtkSignal.connect obj ~sgn ~after ~callback
 end
+
+
+(**
+   ClutterActorBox wrapper object
+*)
+module ActorBox = struct
+  type t = Gpointer.boxed
+  external x1 : t -> int = "ml_clutter_actorbox_get_x1"
+  external y1 : t -> int = "ml_clutter_actorbox_get_y1"
+  external x2 : t -> int = "ml_clutter_actorbox_get_x2"
+  external y2 : t -> int = "ml_clutter_actorbox_get_y2"
+  external create : x1:int -> y1:int -> x2:int -> y2:int -> 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))) }
+end;;
 
 (**
    ClutterColor wrapper object

File clutter/clutter.props

View file
  • Ignore whitespace
   ClutterUnit "int"
   ClutterKnot "Structs.conv_knot"
   ClutterColor "Clutter.Color.conv_color"
+  ClutterActorBox "Clutter.ActorBox.conv"
 }
 
 boxed {
-  ClutterEvent "Clutter.Event.any"
+  ClutterEvent "Event.any"
   ClutterVertex "Clutter.vertex"
   ClutterGeometry "Clutter.geometry"
   (*ClutterColor "Clutter.Color.t"*)
   (*ClutterKnot "Clutter.knot"*)
-  ClutterActorBox "Clutter.actorbox"
+  (*ClutterActorBox "Clutter.actorbox"*)
 }
 
 classes {
   (* query_coords *)
   method event : "'a Clutter.event -> bool -> bool"
   method pick : "Clutter.Color.t -> unit"
+  method allocate : "Clutter.ActorBox.t -> bool -> unit"
+  method get_allocation_box : "Clutter.ActorBox.t"
   method should_pick_paint : "bool"
   method set_geometry : "Clutter.geometry -> unit"
   method get_geometry : "Clutter.geometry"
   method get_stage : "Clutter.actor"
   method set_scale : "xscale:float -> yscale:float -> unit"
   method is_scaled : "bool"
-  method apply_transform_to_point : "Clutter.vertex -> Clutter.vertex -> unit"
+  method apply_transform_to_point : "Clutter.vertex -> Clutter.vertex"
   method transform_stage_point : "x:int -> y:int -> (int*int)"
   method apply_relative_transform_to_point : "ancestor:Clutter.actor -> point:Clutter.vertex -> vertex:Clutter.vertex -> unit"
   method get_transformed_position : "int*int"
   signal fullscreen : ClutterStage 
   signal unfullscreen : ClutterStage 
   method get_default : "Clutter.stage"
-  method get_actor_at_pos : "Clutter.stage -> int -> int -> Clutter.actor"
-  method snapshot : "Clutter.stage -> int -> int -> int -> int -> GdkPixbuf.pixbuf"
-  method event : "Clutter.stage -> [> `ANY] Clutter.event -> bool"
-  method set_key_focus : "Clutter.stage -> Clutter.actor"
-  method get_key_focus : "Clutter.stage -> Clutter.actor"
-  method get_resolution : "Clutter.stage -> float"
-  method set_perspective : "Clutter.stage -> float -> float -> float -> float -> unit"
-  (* method get_perspective : "Clutter.stage -> ... *)
-  method set_fog : "Clutter.stage -> float -> float -> float -> unit"
+  method get_actor_at_pos : "x:int -> y:int -> Clutter.actor obj"
+  method snapshot : "int -> int -> int -> int -> GdkPixbuf.pixbuf"
+  method event : "[> `ANY] Clutter.event -> bool"
+  method set_key_focus : "Clutter.actor"
+  method get_key_focus : "Clutter.actor"
+  method get_resolution : "float"
+  method set_perspective : "float -> float -> float -> float -> unit"
+  (* method get_perspective : "... *)
+  method set_fog : "float -> float -> float -> unit"
   (* method get_fog: *)
 }
 

File clutter/clutterActor.ml

View file
  • Ignore whitespace
   method as_actor : [< Clutter.actor] obj
 end
 
+class actor_signals_impl obj = object
+  inherit ['a] gobject_signals obj
+  inherit actor_sigs
+end
+	    
 class virtual actor_skel (obj : actor obj) = object(self)
   inherit actor_props
   method set_anchor_point_from_gravity =
     Actor.set_anchor_point_from_gravity obj
+  method id = Gobject.get_oid obj
   method as_actor = obj
+  method allocate box = Actor.allocate obj (ActorBox.unwrap box)
+  method get_allocation_box = ActorBox.wrap (Actor.get_allocation_box obj)
   method apply_transform_to_point = Actor.apply_transform_to_point obj
   method get_abs_allocation_vertices = Actor.get_abs_allocation_vertices obj
+  method move_by = Actor.move_by obj
   method raise_top = Actor.raise_top obj
   method show = Actor.show obj
   method show_all = Actor.show_all obj
   method set_size = Actor.set_size obj
   method realize = Actor.realize obj
 end
+
+class actor obj = object
+  inherit actor_skel (obj : [> `actor] Clutter.obj)
+  method obj = obj
+  method connect = new actor_signals_impl obj
+end

File clutter/clutterProps.ml

View file
  • Ignore whitespace
   let cast w : Clutter.actor obj = try_cast w "ClutterActor"
   module P = struct
     let allocation : ([>`actor],_) property =
-      {name="allocation"; conv=(unsafe_pointer : Clutter.actorbox data_conv)}
+      {name="allocation"; conv=Clutter.ActorBox.conv}
     let anchor_x : ([>`actor],_) property = {name="anchor-x"; conv=int}
     let anchor_y : ([>`actor],_) property = {name="anchor-y"; conv=int}
     let clip : ([>`actor],_) property =
     open ClutterData
     let button_press_event =
       {name="button_press_event"; classe=`actor; marshaller=fun f ->
-       marshal1_ret ~ret:boolean
-         (unsafe_pointer : Clutter.Event.any data_conv)
+       marshal1_ret ~ret:boolean (unsafe_pointer : Event.any data_conv)
          "ClutterActor::button_press_event" f}
     let button_release_event =
       {name="button_release_event"; classe=`actor; marshaller=fun f ->
-       marshal1_ret ~ret:boolean
-         (unsafe_pointer : Clutter.Event.any data_conv)
+       marshal1_ret ~ret:boolean (unsafe_pointer : Event.any data_conv)
          "ClutterActor::button_release_event" f}
     let captured_event =
       {name="captured_event"; classe=`actor; marshaller=fun f ->
-       marshal1_ret ~ret:boolean
-         (unsafe_pointer : Clutter.Event.any data_conv)
+       marshal1_ret ~ret:boolean (unsafe_pointer : Event.any data_conv)
          "ClutterActor::captured_event" f}
     let destroy = {name="destroy"; classe=`actor; marshaller=marshal_unit}
     let enter_event =
       {name="enter_event"; classe=`actor; marshaller=fun f ->
-       marshal1_ret ~ret:boolean
-         (unsafe_pointer : Clutter.Event.any data_conv)
+       marshal1_ret ~ret:boolean (unsafe_pointer : Event.any data_conv)
          "ClutterActor::enter_event" f}
     let event =
       {name="event"; classe=`actor; marshaller=fun f ->
-       marshal1_ret ~ret:boolean
-         (unsafe_pointer : Clutter.Event.any data_conv)
+       marshal1_ret ~ret:boolean (unsafe_pointer : Event.any data_conv)
          "ClutterActor::event" f}
     let focus_in =
       {name="focus_in"; classe=`actor; marshaller=fun f ->
          "ClutterActor::hide" f}
     let key_press_event =
       {name="key_press_event"; classe=`actor; marshaller=fun f ->
-       marshal1_ret ~ret:boolean
-         (unsafe_pointer : Clutter.Event.any data_conv)
+       marshal1_ret ~ret:boolean (unsafe_pointer : Event.any data_conv)
          "ClutterActor::key_press_event" f}
     let key_release_event =
       {name="key_release_event"; classe=`actor; marshaller=fun f ->
-       marshal1_ret ~ret:boolean
-         (unsafe_pointer : Clutter.Event.any data_conv)
+       marshal1_ret ~ret:boolean (unsafe_pointer : Event.any data_conv)
          "ClutterActor::key_release_event" f}
     let leave_event =
       {name="leave_event"; classe=`actor; marshaller=fun f ->
-       marshal1_ret ~ret:boolean
-         (unsafe_pointer : Clutter.Event.any data_conv)
+       marshal1_ret ~ret:boolean (unsafe_pointer : Event.any data_conv)
          "ClutterActor::leave_event" f}
     let motion_event =
       {name="motion_event"; classe=`actor; marshaller=fun f ->
-       marshal1_ret ~ret:boolean
-         (unsafe_pointer : Clutter.Event.any data_conv)
+       marshal1_ret ~ret:boolean (unsafe_pointer : Event.any data_conv)
          "ClutterActor::motion_event" f}
     let parent_set =
       {name="parent_set"; classe=`actor; marshaller=fun f ->
          "ClutterActor::parent_set" f}
     let scroll_event =
       {name="scroll_event"; classe=`actor; marshaller=fun f ->
-       marshal1 (unsafe_pointer : Clutter.Event.any data_conv)
+       marshal1 (unsafe_pointer : Event.any data_conv)
          "ClutterActor::scroll_event" f}
     let show =
       {name="show"; classe=`actor; marshaller=fun f ->
     = "ml_clutter_actor_event"
   external pick : [>`actor] obj -> Clutter.Color.t -> unit
     = "ml_clutter_actor_pick"
+  external allocate : [>`actor] obj -> Clutter.ActorBox.t -> bool -> unit
+    = "ml_clutter_actor_allocate"
+  external get_allocation_box : [>`actor] obj -> Clutter.ActorBox.t
+    = "ml_clutter_actor_get_allocation_box"
   external should_pick_paint : [>`actor] obj -> bool
     = "ml_clutter_actor_should_pick_paint"
   external set_geometry : [>`actor] obj -> Clutter.geometry -> unit
     = "ml_clutter_actor_set_scale"
   external is_scaled : [>`actor] obj -> bool = "ml_clutter_actor_is_scaled"
   external apply_transform_to_point :
-    [>`actor] obj -> Clutter.vertex -> Clutter.vertex -> unit
+    [>`actor] obj -> Clutter.vertex -> Clutter.vertex
     = "ml_clutter_actor_apply_transform_to_point"
   external transform_stage_point :
     [>`actor] obj -> x:int -> y:int -> (int*int)
   external get_default : [>`stage] obj -> Clutter.stage
     = "ml_clutter_stage_get_default"
   external get_actor_at_pos :
-    [>`stage] obj -> Clutter.stage -> int -> int -> Clutter.actor
+    [>`stage] obj -> x:int -> y:int -> Clutter.actor obj
     = "ml_clutter_stage_get_actor_at_pos"
   external snapshot :
-    [>`stage] obj ->
-    Clutter.stage -> int -> int -> int -> int -> GdkPixbuf.pixbuf
-    = "ml_clutter_stage_snapshot_bc" "ml_clutter_stage_snapshot"
-  external event :
-    [>`stage] obj -> Clutter.stage -> [> `ANY] Clutter.event -> bool
+    [>`stage] obj -> int -> int -> int -> int -> GdkPixbuf.pixbuf
+    = "ml_clutter_stage_snapshot"
+  external event : [>`stage] obj -> [> `ANY] Clutter.event -> bool
     = "ml_clutter_stage_event"
-  external set_key_focus : [>`stage] obj -> Clutter.stage -> Clutter.actor
+  external set_key_focus : [>`stage] obj -> Clutter.actor
     = "ml_clutter_stage_set_key_focus"
-  external get_key_focus : [>`stage] obj -> Clutter.stage -> Clutter.actor
+  external get_key_focus : [>`stage] obj -> Clutter.actor
     = "ml_clutter_stage_get_key_focus"
-  external get_resolution : [>`stage] obj -> Clutter.stage -> float
+  external get_resolution : [>`stage] obj -> float
     = "ml_clutter_stage_get_resolution"
   external set_perspective :
-    [>`stage] obj ->
-    Clutter.stage -> float -> float -> float -> float -> unit
-    = "ml_clutter_stage_set_perspective_bc" "ml_clutter_stage_set_perspective"
-  external set_fog :
-    [>`stage] obj -> Clutter.stage -> float -> float -> float -> unit
+    [>`stage] obj -> float -> float -> float -> float -> unit
+    = "ml_clutter_stage_set_perspective"
+  external set_fog : [>`stage] obj -> float -> float -> float -> unit
     = "ml_clutter_stage_set_fog"
   let make_params ~cont pl ?color ?cursor_visible ?fullscreen ?offscreen
       ?title ?use_fog ?user_resizable =

File clutter/clutterStage.ml

View file
  • Ignore whitespace
   inherit ClutterContainer.container_skel (as_container obj)
   inherit ClutterActor.actor_skel (as_actor obj)
   method obj : stage Clutter.obj = obj
+  method get_actor_at_pos ~x ~y =
+    new ClutterActor.actor (Stage.get_actor_at_pos obj ~x ~y)
 end
 
 class stage_signals_impl obj = object

File clutter/event.ml

View file
  • Ignore whitespace
+open ClutterEnums
+
+type +'a event
+type any = clutter_event_type event
+
+external create : ([< clutter_event_type] as 'a) -> 'a event
+  = "ml_clutter_event_new"
+external get_type : 'a event -> 'a = "ml_clutter_event_get_type"
+external unsafe_cast :
+  [< clutter_event_type] event -> [< clutter_event_type] event = "%identity"
+    
+let cast ~(kind : ([< clutter_event_type] as 'a) list) (ev : any) : 'a event =
+  if List.mem (Obj.magic (get_type ev) : [> ]) kind then unsafe_cast ev
+  else invalid_arg "ClutterEvent.cast"
+
+external get_coords : 'a event -> (int*int) = "ml_clutter_event_get_coords"
+external get_state : 'a event -> modifier_type = "ml_clutter_event_get_stage"
+external get_time : 'a event -> int = "ml_clutter_event_get_time"
+external get_source : 'a event -> Clutter.actor = "ml_clutter_event_get_source"
+external get_stage : 'a event -> Clutter.stage = "ml_clutter_event_get_stage"
+    
+module Button = struct
+  type types = [`BUTTON_PRESS | `BUTTON_RELEASE]
+  type t = types event
+
+  external x : t -> int = "ml_ClutterEventButton_y"
+  external y : t -> int = "ml_ClutterEventButton_y"
+end
+
+module Key = struct
+  type types = [`KEY_PRESS | `KEY_RELEASE]
+  type t = types event
+end
+
+module Motion = struct
+  type types = [`MOTION] event
+end
+
+module Scroll = struct
+  type t = [`SCROLL] event
+end
+
+module StageState = struct
+  type t = [`STAGE_STATE] event
+end
+
+module Crossing = struct
+  type types = [`ENTER | `LEAVE] event
+  type t = types event
+end

File clutter/ml_actor.c

View file
  • Ignore whitespace
 #include "clutter_tags.h"
 #include "ml_actor.h"
 
+
+// ClutterActorBox
+#define ClutterActorBox_val(val) ((ClutterActorBox *)Pointer_val(val))
+#define Val_ClutterActorBox(val) (Val_pointer(val))
+//Make_Val_final_pointer(ClutterActorBox, Ignore, free, 1);
+Make_Extractor (clutter_actorbox_get, ClutterActorBox_val, x1, Val_long)
+Make_Extractor (clutter_actorbox_get, ClutterActorBox_val, y1, Val_long)
+Make_Extractor (clutter_actorbox_get, ClutterActorBox_val, x2, Val_long)
+Make_Extractor (clutter_actorbox_get, ClutterActorBox_val, y2, Val_long)
+CAMLprim value ml_clutter_actorbox_new(value x1, value y1, value x2, value y2) {
+  CAMLparam4(x1,y1,x2,y2);
+  ClutterActorBox *b = malloc(sizeof(ClutterActorBox));
+  b->x1 = Int_val(x1);
+  b->y1 = Int_val(y1);
+  b->x2 = Int_val(x2);
+  b->y2 = Int_val(y2);
+  CAMLreturn(Val_ClutterActorBox(b));
+}
+
+// Actor
+// FIXME: deal with this stupic ompare thing
+static int ml_custom_compare_actor(value v1, value v2) \
+{ return v1 == v2 ? 0 : 1; }
+
 static struct custom_operations ml_clutter_actor_ops = {
   "ClutterActor",
   custom_finalize_default,
-  custom_compare_default,
+  ml_custom_compare_actor,
   custom_hash_default,
   custom_serialize_default,
   custom_deserialize_default
   return ret; 
 }
 
-#define ClutterActor_val(val)       (check_cast(CLUTTER_ACTOR, val))
-
 void ml_clutter_actor_callback (ClutterActor *a, gpointer data)
 {
     value val, *clos = (value*)data;
   CAMLreturn(result);
 }
 
-CAMLprim value ml_clutter_actor_apply_transform_to_point(value _a, value _point, value _vertex) {
-  CAMLparam3(_a, _point, _vertex);
+CAMLprim value ml_clutter_actor_apply_transform_to_point(value _a, value _point) {
+  CAMLparam2(_a, _point);
+  CAMLlocal1(result);
   ClutterActor* a = ClutterActor_val(_a);
   ClutterVertex point = { Triple(_point, Int_val, Int_val, Int_val) };
-  ClutterVertex vertex = { Triple(_vertex, Int_val, Int_val, Int_val) };
+  ClutterVertex vertex;
   clutter_actor_apply_transform_to_point(a, &point, &vertex);
-  CAMLreturn(Val_unit);
+  result = caml_alloc(3,0);
+  Store_field(result, 0, Val_int(vertex.x));
+  Store_field(result, 1, Val_int(vertex.y));
+  Store_field(result, 2, Val_int(vertex.z));
+  CAMLreturn(result);
 }
 
-ML_1(clutter_actor_raise_top, ClutterActor_val, Unit);
-ML_1(clutter_actor_show_all, ClutterActor_val, Unit);
-ML_1(clutter_actor_show, ClutterActor_val, Unit);
+CAMLprim value ml_clutter_actor_get_allocation_box(value _a) {
+  CAMLparam1(_a);
+  CAMLlocal1(result);
+  ClutterActor* a = ClutterActor_val(_a);
+  ClutterActorBox* b = malloc(sizeof(ClutterActorBox));
+  clutter_actor_get_allocation_box(a, b);
+  CAMLreturn(Val_ClutterActorBox(b));
+}
+
+ML_1(clutter_actor_raise_top, ClutterActor_val, Unit)
+ML_1(clutter_actor_show_all, ClutterActor_val, Unit)
+ML_1(clutter_actor_show, ClutterActor_val, Unit)
+ML_3(clutter_actor_allocate, ClutterActor_val, ClutterActorBox_val, Bool_val, Unit)
+ML_3(clutter_actor_move_by, ClutterActor_val, Int_val, Int_val, Unit)
+
 ML_1(clutter_actor_get_width, ClutterActor_val, Val_int);
 ML_1(clutter_actor_get_height, ClutterActor_val, Val_int);
 ML_2(clutter_actor_set_anchor_point_from_gravity,  ClutterActor_val,

File clutter/ml_clutter.c

View file
  • Ignore whitespace
 #include "pango_tags.h"
 #include "pango_tags.c"
 #include "ml_clutter.h"
+#include "ml_actor.h"
 
 #define GObject_val(val) ((GObject*)Pointer_val(val))
 ML_1 (g_object_ref, GObject_val, Unit)
 
-// FIXED
-
+// FIXED module operations
 double clutter_fixed_to_float(int x) { return CLUTTER_FIXED_TO_FLOAT(x); }
+int clutter_float_to_fixed(double x) { return CLUTTER_FLOAT_TO_FIXED(x); }
 int clutter_fixed_to_int(int x) { return CLUTTER_FIXED_TO_INT(x); }
 int clutter_int_to_fixed(int x) { return CLUTTER_INT_TO_FIXED(x); }
 ML_1(clutter_fixed_to_float, Int_val, copy_double);
+ML_1(clutter_float_to_fixed, Double_val, Val_int);
 ML_1(clutter_fixed_to_int, Int_val, Val_int);
 ML_1(clutter_int_to_fixed, Int_val, Val_int);
 
 }
 
 // Events
+Make_Val_final_pointer (ClutterEvent, Ignore, clutter_event_free, 1)
+
+CAMLprim value ml_clutter_event_new (value event_type)
+{
+  ClutterEvent *event = clutter_event_new(Clutter_event_type_val(event_type));
+  return Val_ClutterEvent(event);
+}
+
+CAMLprim value ml_clutter_event_get_coords(value _event)
+{
+  CAMLparam1(_event);
+  CAMLlocal1(result);
+  ClutterEvent *event = ClutterEvent_val(_event);
+  gint x,y;
+  clutter_event_get_coords(event, &x, &y);
+  result = caml_alloc(2,0);
+  Store_field(result, 0, Val_int(x));
+  Store_field(result, 1, Val_int(y));
+  CAMLreturn(result);
+}
+
+CAMLprim value ml_clutter_event_get_type(value _event)
+{
+  CAMLparam1(_event);
+  CAMLlocal1(result);
+  ClutterEvent *event = ClutterEvent_val(_event);
+  ClutterEventType t = clutter_event_type(event);
+  CAMLreturn(Val_clutter_event_type(t));
+}
+
+// FIXME: ML_1 (clutter_event_get_stage, ClutterEvent_val, Val_modifier_type);
+ML_1 (clutter_event_get_source, ClutterEvent_val, Val_ClutterActor);
+// FIXME: get_stage is supposed to return a clutterstage
+//ML_1 (clutter_event_get_stage, ClutterEvent_val, Val_ClutterActor);
+ML_1 (clutter_event_get_time, ClutterEvent_val, copy_int32)
+#define ClutterEvent_arg(type) (Clutter##type##Event*)ClutterEvent_val
+
+//Make_Extractor (ClutterEvent, ClutterEvent_arg(Any), type, Val_clutter_event_type)
+
+Make_Extractor (ClutterEventMotion, ClutterEvent_arg(Motion), x, Val_int)
+Make_Extractor (ClutterEventMotion, ClutterEvent_arg(Motion), y, Val_int)
+
+
+Make_Extractor (ClutterButtonEvent, ClutterEvent_arg(Button), x, Val_int)
+Make_Extractor (ClutterButtonEvent, ClutterEvent_arg(Button), y, Val_int)
+Make_Extractor (ClutterButtonEvent, ClutterEvent_arg(Button), button, Val_int)
+
+Make_Extractor (ClutterScrollEvent, ClutterEvent_arg(Scroll), x, Val_int)
+Make_Extractor (ClutterScrollEvent, ClutterEvent_arg(Scroll), y, Val_int)
+Make_Extractor (ClutterScrollEvent, ClutterEvent_arg(Scroll),
+                direction, Val_scroll_direction_type)
+
 //Make_Flags_val (Event_mask_val)

File clutter/ml_stage.c

View file
  • Ignore whitespace
 #include "wrappers.h"
 #include "ml_actor.h"
+#include "ml_stage.h"
 
+static struct custom_operations ml_clutter_stage_ops = {
+  "ClutterStage",
+  custom_finalize_default,
+  custom_compare_default,
+  custom_hash_default,
+  custom_serialize_default,
+  custom_deserialize_default
+};
+
+value Val_ClutterStage_ (ClutterStage *t, gboolean ref)
+{ 
+  ClutterStage **p;
+  value ret; 
+  if (t == NULL) ml_raise_null_pointer(); 
+  ret = alloc_custom (&ml_clutter_stage_ops, sizeof t, 
+		      100, 1000);
+  p = Data_custom_val (ret);
+  *p = ref ? g_object_ref (t) : t;
+  return ret; 
+}
+
+// FIXME: should this really return an actor or a stage?
 CAMLprim value ml_clutter_stage_get_default()
 {
   ClutterActor *t = clutter_stage_get_default();
   return Val_ClutterActor(t);
 }
+
+ML_3(clutter_stage_get_actor_at_pos, ClutterStage_val, Int_val, Int_val, Val_ClutterActor)

File clutter/ml_stage.h

View file
  • Ignore whitespace
+#define ClutterStage_val(val)       (check_cast(CLUTTER_STAGE, val))
+value Val_ClutterStage_ (ClutterStage *, gboolean);
+#define Val_ClutterStage(p)         Val_ClutterStage_(p, TRUE)
+#define Val_ClutterStage_new(p)     Val_ClutterStage_(p, FALSE)

File clutter/structs.ml

View file
  • Ignore whitespace
+open Gobject
+
+module Geometry = struct
+  type t
+end;;
+
+(** ClutterVertex object *)
+module Vertex = struct
+  type t
+  external x : t -> int = "ml_clutter_vertex_get_x"
+  external y : t -> int = "ml_clutter_vertex_get_y"
+  external z : t -> int = "ml_clutter_vertex_get_z"
+  external set_x : t -> int -> unit = "ml_clutter_vertex_set_x"
+  external set_y : t -> int -> unit = "ml_clutter_vertex_set_y"
+  external set_z : t -> int -> unit = "ml_clutter_vertex_set_z"
+  external create : x:int -> y:int -> z:int -> t = "ml_clutter_vertex_new"
+end;;
+
+class vertex_class obj = object
+  method as_vertex : Vertex.t = obj
+  method x = Vertex.x obj
+  method y = Vertex.y obj
+  method z = Vertex.z obj    
+  method set_x = Vertex.set_x obj
+  method set_y = Vertex.set_y obj
+  method set_z = Vertex.set_z obj
+end
+
+let vertex ~x ~y ~z =
+  let k = Vertex.create ~x ~y ~z in
+  new vertex_class k
+
+(** ClutterActorBox object *)
+module ActorBox = struct
+  type t
+end;;
+    
+(**
+   ClutterKnot wrapper object
+*)
+module Knot = struct
+  type t = Gpointer.boxed
+  external x : t -> int = "ml_clutter_knot_get_x"
+  external y : t -> int = "ml_clutter_knot_get_y"
+  external set_x : t -> int -> unit = "ml_clutter_knot_set_x"
+  external set_y : t -> int -> unit = "ml_clutter_knot_set_y"
+  external create : x:int -> y:int -> t = "ml_clutter_knot_new"
+end;;
+
+class knot obj = object
+  method obj : Knot.t = obj
+  method x = Knot.x obj
+  method y = Knot.y obj
+  method set_x = Knot.set_x obj
+  method set_y = Knot.set_y obj
+end
+
+let knot ~x ~y =
+  let k = Knot.create ~x ~y in
+  new knot k
+
+let wrap_knot k = {
+  Clutter.x = Knot.x k;
+  Clutter.y = Knot.y k; }
+let unwrap_knot k = Knot.create ~x:k.Clutter.x ~y:k.Clutter.y
+  
+let conv_knot =
+  { kind = `POINTER;
+    proj = (function `POINTER (Some k) -> wrap_knot k
+	      | `POINTER None -> raise Gpointer.Null
+	      | _ -> failwith "GObj.get_object");
+    inj = (fun k -> `POINTER (Some (unwrap_knot k))) }

File examples/actor1.ml

View file
  • Ignore whitespace
 
 open Printf
 open Clutter
+
+(* Compare floats up to a given relative error *)
+let cmp_float ?(epsilon = 0.00001) a b =
+  abs_float (a -. b) <= epsilon *. (abs_float a) ||
+    abs_float (a -. b) <= epsilon *. (abs_float b)
+
+let test_fixed () =
+  let v1 = 4 in
+  let a = Units.from_int v1 in
+  let b = Units.to_int a in
+  assert (v1 = b);
+  let v2 = 33.4 in
+  let c = Units.from_float v2 in
+  let d = Units.to_float c in
+  assert (cmp_float v2 d)
   
 let _ =
+  test_fixed ();
   let stage = ClutterStage.get_default () in
   stage#set_size ~width:800 ~height:600;
   let actor = ClutterTexture.texture ~filename:"./examples/ohpowers.png" () in

File examples/simple.c

View file
  • Ignore whitespace
+#include <clutter/clutter.h>
+
+static ClutterColor bg_color;
+
+int main (int   argc, char *argv[])
+{
+  ClutterActor *stage, *instructions, *icon;
+  ClutterTimeline *main_timeline;
+  GError *error = NULL;
+
+  clutter_init (&argc, &argv);
+
+  stage = clutter_stage_get_default ();
+  clutter_actor_set_size (stage, 800, 600);
+
+  clutter_color_parse ("Red", &bg_color);
+
+  icon = clutter_texture_new_from_file ("./examples/ohpowers.png", &error);
+  clutter_actor_set_position(icon, 400, 200);
+  if (error)
+    g_error ("Unable to load 'redhand.png': %s", error->message);
+
+  clutter_container_add_actor (CLUTTER_CONTAINER (stage), icon);
+
+  // THESE LINES NEED TO BE UNCOMMENTED TO AVOID A BUS ERROR
+  //ClutterActor *b = clutter_rectangle_new();
+  //clutter_container_add_actor( CLUTTER_CONTAINER (stage), b);
+  
+  clutter_actor_show (stage);
+
+  clutter_main ();
+
+  return 0;
+}

File examples/simple.prog

View file
  • Ignore whitespace
+simple.o

File tests/test-project.ml

View file
  • Ignore whitespace
       
 end
 
+open Printf
 let g_debug = Format.printf
 
 let init_handles group rect =
        let r = ClutterRectangle.rectangle ~color:blue ~width:5 ~height:5
 	 ~x:0 ~y:0 () in
        group#add r#as_actor;
-       r#set_position ~x:((Fixed.to_int v.vx) - r#width / 2)
-	 ~y:((Fixed.to_int v.vy) - r#height / 2);
+       r#set_position ~x:((Units.to_int v.vx) - r#width / 2)
+	 ~y:((Units.to_int v.vy) - r#height / 2);
        r#raise_top;
        r#show;
        r
     ) [v1;v2;v3;v4] in
-  let v1 = { vx = (Fixed.from_int (rect#width / 2));
-	     vy = (Fixed.from_int (rect#height / 2));
+  let v1 = { vx = (Units.from_int (rect#width / 2));
+	     vy = (Units.from_int (rect#height / 2));
 	     vz = 0 } in
 
-  rect#apply_transform_to_point v1 v2;
+  let v2 = rect#apply_transform_to_point v1 in
   let r = ClutterRectangle.rectangle ~color:blue ~width:5 ~height:5 ~x:0
     ~y:0 () in
   group#add r#as_actor;
-  r#set_position ~x:((Fixed.to_int v2.vx) - r#width / 2)
-    ~y:((Fixed.to_int v2.vy) - r#height / 2);
+  r#set_position ~x:((Units.to_int v2.vx) - r#width / 2)
+    ~y:((Units.to_int v2.vy) - r#height / 2);
   r#raise_top;
   r#show;
   Array.of_list (List.append points [r])
   Array.iteri
     (fun i v ->
        let r = points.(i) in
-       r#set_position ~x:((Fixed.to_int v.vx) - r#width / 2)
-	 ~y:((Fixed.to_int v.vy) - r#height / 2)
+       r#set_position ~x:((Units.to_int v.vx) - r#width / 2)
+	 ~y:((Units.to_int v.vy) - r#height / 2)
     ) vertices;
-  let v1 = { vx = (Fixed.from_int (rect#width / 2));
-	     vy = (Fixed.from_int (rect#height / 2));
+  let v1 = { vx = (Units.from_int (rect#width / 2));
+	     vy = (Units.from_int (rect#height / 2));
 	     vz = 0 } in
-  rect#apply_transform_to_point v1 v2;
+  let v2 = rect#apply_transform_to_point v1 in
   let r = points.(4) in
-  points.(4)#set_position ~x:((Fixed.to_int v2.vx) - r#width / 2)
-    ~y:((Fixed.to_int v2.vy) - r#height / 2)
+  points.(4)#set_position ~x:((Units.to_int v2.vx) - r#width / 2)
+    ~y:((Units.to_int v2.vy) - r#height / 2)
   
 let on_event rect points stage =
   let dragging = ref None in
-  function
-      `BUTTON_PRESS evt ->
-	let x,y = evt#get_coords in
-	let actor = stage#get_actor_at_pos x y in
-	if (actor != stage#as_actor) && (actor != rect) then
-	  dragging := Some actor
+  fun evt -> match Event.get_type evt with
+      `BUTTON_PRESS ->
+	let x,y = Event.get_coords evt in
+	printf "button_press: x=%d y=%d\n%!" x y;
+	let actor = stage#get_actor_at_pos ~x ~y in
+	if (actor#id != stage#id) && (actor#id != rect#id) then
+	  dragging := Some actor;
+	true
 
-    | `MOTION evt -> begin match !dragging with
+    | `MOTION -> begin match !dragging with
 	  Some dragging -> begin
 	    try
-	      let idx = Array.findi (fun x -> x = dragging) points in
-	      let x,y = evt#get_coords in
-	      let box1 = dragging#get_allocation_box
-	      and box2 = rect#get_allocation_box in
-	      let xp = Fixed.from_int ((x-3) - box1#x1)
-	      and yp = Fixed.from_int ((y-3) - box1#y1) in
+	      let idx = Array.findi (fun x -> x#id = dragging#id) points in
+	      let x,y = Event.get_coords evt in
+	      let box1 : actorbox = dragging#get_allocation_box
+	      and box2 : actorbox = rect#get_allocation_box in
+	      let xp = (Units.from_int (x-3)) - box1.x1
+	      and yp = (Units.from_int (y-3)) - box1.y1 in
 	      if (idx = 4) then begin
-		g_debug "moving box by %g,%g" (Fixed.to_float xp)
-		  (Fixed.to_float yp);
-		rect#move_by ~x:(Fixed.to_int xp) ~y:(Fixed.to_int yp);
+		g_debug "moving box by %g,%g\n%!" (Units.to_float xp)
+		  (Units.to_float yp);
+		rect#move_by ~dx:(Units.to_int xp) ~dy:(Units.to_int yp);
 	      end else begin
-		g_debug "moving box by %g,%g, handle %d"
-		  (Fixed.to_float xp) (Fixed.to_float yp) idx;
-		let () = match idx with
+		g_debug "adjusting box by %g,%g, handle %d\n%!"
+		  (Units.to_float xp) (Units.to_float yp) idx;
+		let box2 = match idx with
 		    0 ->
-		      box2#set_x1 (box2#x1 + xp);
-		      box2#set_y1 (box2#y1 + yp);
+		      {box2 with x1 = (box2.x1 + xp); y1 = (box2.y1 + yp);}
 		  | 1 ->
-		      box2#set_x2 (box2#x2 + xp);
-		      box2#set_y1 (box2#y1 + yp);
+		      {box2 with x2 = (box2.x2 + xp); y1 = (box2.y1 + yp);}
 		  | 2 ->
-		      box2#set_x1 (box2#x1 + xp);
-		      box2#set_y2 (box2#y2 + yp);
+		      {box2 with x1 = (box2.x1 + xp); y2 = (box2.y2 + yp);}
 		  | 3 ->
-		      box2#set_x2 (box2#x2 + xp);
-		      box2#set_y2 (box2#y2 + yp)
+		      {box2 with x2 = (box2.x2 + xp); y2 = (box2.y2 + yp);}
+		  | _ -> failwith "impossible"
 		in
-		rect#allocate box2 true
-	      end
-	    with Not_found -> () end
-	| _ -> () end
+		rect#allocate box2 true;
+	      end;
+	      place_handles rect points;
+	      true
+	    with Not_found -> true; end
+	| _ -> true end
 
-    | `RELEASE evt ->
-	dragging := None
+    | `BUTTON_RELEASE ->
+	dragging := None;
+	true
     | _ ->
-	g_debug "received irrelevant event"
+	g_debug "received irrelevant event";
+	true
 	  
   
 let _ =
   
   let rect = ClutterRectangle.rectangle ~color:white
     ~width:320 ~height:240 ~x:180 ~y:120 () in
+  
+  
   rect#set_rotation `Y_AXIS ~angle:60. ~x:0 ~y:0 ~z:0;
   main_stage#add_actor rect#as_actor;
 
 
   main_stage#show_all;
 
+  let box1 = rect#get_allocation_box in
+  printf "box1: x1=%d y1=%d x2=%d y2=%d\n%!" box1.x1 box1.y1
+    box1.x2 box1.y2;
+  
   let points = init_handles main_stage rect in
   
-
+  let _ = main_stage#connect#event (on_event rect points main_stage) in
   (*Clutt
   g_signal_connect (main_stage, "event", G_CALLBACK (on_event), NULL);
   init_handles ();*)