Commits

Reid van Melle committed 84d515f

Fixed a number of problems wrt gtkobject and casting stuff

  • Participants
  • Parent commits ae3be4c

Comments (0)

Files changed (16)

 examples/pong.native
 examples/ripples.native
 tests/test-effect.native
-tests/test-project.native
+#tests/test-project.native

File clutter/clutter.ml

 (*type color*)
 type geometry
 type coords
+type coglhandle
 
-type actor =    [`gtk|`actor]
+type actor =    [`actor]
 type container = [`container]
 type behaviour = [`behaviour]
-type rectangle = [`gtk|`rectangle|`actor]
-type texture =   [`gtk|`texture|`actor]
-type label = [`gtk|`label|`actor]
+type rectangle = [`rectangle|`actor]
+type texture =   [`texture|`actor]
+type label = [`label|`actor]
   
 type alpha =     [`alpha] 
-type stage =     [`gtk|`container|`stage|`actor|`group] 
-type group =     [`gtk|`container|`group|`actor] 
+type stage =     [`container|`stage|`actor|`group] 
+type group =     [`container|`group|`actor] 
     
-type behaviour_ellipse =   [`gtk|`behaviour|`behaviourellipse]
+type behaviour_ellipse =   [`behaviour|`behaviourellipse]
 type ellipse = behaviour_ellipse
 type opacity =   [`behaviour|`opacity] 
 type rotate =    [`behaviour|`rotate] 
 type path =      [`behaviour|`path] 
 type scale =     [`behaviour|`scale] 
 	
-type timeline =  [`gtk|`timeline] 
+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 quit : unit -> unit = "clutter_main_quit"
-    (* FIXME: put some correct enforcement here *)
-external as_actor : 'a obj -> actor obj = "ml_clutter_as_actor"
+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.t -> 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"
+end
+  
+(* FIXME: put some correct enforcement here *)
 external as_container : 'a obj -> container obj = "ml_clutter_as_container"
+external is_container : 'a obj -> bool = "ml_clutter_is_a_container"
+exception TypeError
+let as_actor a =
+  if Gobject.is_a a "ClutterActor" 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
   let k = Vertex.create ~x ~y ~z in
   new vertex k
 
+(** ClutterActorBox object *)
+module ActorBox = struct
+  type t
+end;;
+    
 (**
    ClutterKnot wrapper object
 *)
   let k = Knot.create ~x ~y in
   new knot k
 
-module Event = struct
-  type any
-end;;
-
 (**
    ClutterColor wrapper object
 *)
 module Color = struct
   type t
   external red : t -> int = "ml_clutter_color_get_red"
-  external red : t -> int = "ml_clutter_color_get_red"
-  external red : t -> int = "ml_clutter_color_get_red"
-  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_red : t -> int -> unit = "ml_clutter_color_set_red"
-  external set_red : t -> int -> unit = "ml_clutter_color_set_red"
-  external set_red : t -> int -> unit = "ml_clutter_color_set_red"
-  external create : red:int -> green:int -> blue:int -> alpha:int -> t = "ml_clutter_color_new"
+  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 create : red:int -> green:int -> blue:int -> alpha:int -> t
+    = "ml_clutter_color_new"
 
   class color obj = object
     method as_color : t = obj
   let rgba (red,green,blue,alpha) =
     let c = create ~red ~green ~blue ~alpha in
     new color c
-      
+
 end;;
 
-(*module Group = struct
-  external create : unit -> group obj = "ml_clutter_group_new"
-end;;*)
-
 module Alpha = struct
   let max_alpha = 0xffff
   type alpha_fun = alpha -> int
   end
 end;;
 
-(*module Container = struct
-  external add_actor : [> `container] obj -> [> `actor] obj -> unit
-    = "ml_clutter_container_add_actor"
-  (*let add_actor = ClutterProps.Container.add_actor*)
-  let add c actors =
-    List.iter (add_actor c) actors
 
-  module S = struct
-    open GtkSignal
-    let actor_added =
-      {name="actor-added"; classe=`container; marshaller=marshal_unit}
-       (*marshaller=fun f -> marshal0_ret ~ret:Gobject.Data.boolean f}*)
-  end
 
-end;;*)
 
 
 
 
 
 
-

File clutter/clutter.props

 open Gobject
 open Data
 open ClutterData
-(*
-- defined in lablgtk
 module Object = struct
-  let cast w : [`gtk] obj = try_cast w "GtkObject"
-  external _ref_and_sink : [>`gtk] obj -> unit
-    = "ml_gtk_object_ref_and_sink"
+  let cast w : [`gtk] obj = try_cast w "GObject"
+  external _ref : 'a obj -> unit = "ml_g_object_ref"
   let make ~classe params =
-    let obj = unsafe_create ~classe params in _ref_and_sink obj;
+    let obj = unsafe_create ~classe params in _ref obj;
     obj
-end*)
+end
 }
 
 oheader{
   method lower : "Clutter.actor -> unit"
   method raise_top: "unit"
   method lower_bottom: "unit"
+  
+  method get_stage : "Clutter.actor"
+  method set_scale : "xscale:float -> yscale:float -> unit"
+  method is_scaled : "bool"
+  method apply_transform_to_point : "Clutter.Vertex.t -> Clutter.Vertex.t -> unit"
+  method transform_stage_point : "x:int -> y:int -> (int*int)"
+  method apply_relative_transform_to_point : "ancestor:Clutter.actor -> point:Clutter.Vertex.t -> vertex:Clutter.Vertex.t -> unit"
+  method get_transformed_position : "int*int"
+  method get_transformed_size : "int*int"
+  method get_paint_opacity : "int"
+  method get_abs_allocation_vertices : "Clutter.Vertex.t * Clutter.Vertex.t * Clutter.Vertex.t * Clutter.Vertex.t"
+  method box_get_from_vertices : "Clutter.Vertex.t -> Clutter.Vertex.t -> Clutter.Vertex.t -> Clutter.Vertex.t -> Clutter.ActorBox.t"
+  method set_anchor_point : "x:int -> y:int -> unit"
+  method get_anchor_point : "int*int"
+  method set_anchor_point_from_gravity : "ClutterEnums.gravity_type -> unit"
   (* much more *)
-  method set_anchor_point_from_gravity : "ClutterEnums.gravity_type -> unit"
 }
 
 class Container abstract wrap {

File clutter/clutterActor.ml

 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 as_actor = obj
+  (*method apply_transform_to_point = Actor.apply_transform_to_point obj
+  method get_abs_allocation_vertices = Actor.get_abs_allocation_vertices obj
+  method raise_top = Actor.raise_top obj*)
   method show = Actor.show obj
   method show_all = Actor.show_all obj
   method set_position = Actor.set_position obj

File clutter/clutterContainer.ml

 class virtual container_skel (obj : container obj) = object(self)
   method add_actor (a : actor obj) =
     ClutterProps.Container.add_actor self#as_container a
+  method add (a : actor obj) =
+    ClutterProps.Container.add_actor self#as_container a
   method as_container = obj
 end

File clutter/clutterProps.ml

 open Gobject
 open Data
-module Object = GtkObject
 
 open Gtk
 open Gobject
 open Data
 open ClutterData
-(*
-- defined in lablgtk
 module Object = struct
-  let cast w : [`gtk] obj = try_cast w "GtkObject"
-  external _ref_and_sink : [>`gtk] obj -> unit
-    = "ml_gtk_object_ref_and_sink"
+  let cast w : [`gtk] obj = try_cast w "GObject"
+  external _ref : 'a obj -> unit = "ml_g_object_ref"
   let make ~classe params =
-    let obj = unsafe_create ~classe params in _ref_and_sink obj;
+    let obj = unsafe_create ~classe params in _ref obj;
     obj
-end*)
+end
 
 module PrivateProps = struct
   let alpha = {name="alpha"; conv=(gobject : Clutter.alpha obj data_conv)}
   external raise_top : [>`actor] obj -> unit = "ml_clutter_actor_raise_top"
   external lower_bottom : [>`actor] obj -> unit
     = "ml_clutter_actor_lower_bottom"
+  external get_stage : [>`actor] obj -> Clutter.actor
+    = "ml_clutter_actor_get_stage"
+  external set_scale : [>`actor] obj -> xscale:float -> yscale:float -> 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.t -> Clutter.Vertex.t -> unit
+    = "ml_clutter_actor_apply_transform_to_point"
+  external transform_stage_point :
+    [>`actor] obj -> x:int -> y:int -> (int*int)
+    = "ml_clutter_actor_transform_stage_point"
+  external apply_relative_transform_to_point :
+    [>`actor] obj ->
+    ancestor:Clutter.actor -> point:Clutter.Vertex.t -> vertex:Clutter.Vertex.t -> unit
+    = "ml_clutter_actor_apply_relative_transform_to_point"
+  external get_transformed_position : [>`actor] obj -> int*int
+    = "ml_clutter_actor_get_transformed_position"
+  external get_transformed_size : [>`actor] obj -> int*int
+    = "ml_clutter_actor_get_transformed_size"
+  external get_paint_opacity : [>`actor] obj -> int
+    = "ml_clutter_actor_get_paint_opacity"
+  external get_abs_allocation_vertices :
+    [>`actor] obj ->
+    Clutter.Vertex.t * Clutter.Vertex.t * Clutter.Vertex.t * Clutter.Vertex.t
+    = "ml_clutter_actor_get_abs_allocation_vertices"
+  external box_get_from_vertices :
+    [>`actor] obj ->
+    Clutter.Vertex.t -> Clutter.Vertex.t -> Clutter.Vertex.t -> Clutter.Vertex.t -> Clutter.ActorBox.t
+    = "ml_clutter_actor_box_get_from_vertices"
+  external set_anchor_point : [>`actor] obj -> x:int -> y:int -> unit
+    = "ml_clutter_actor_set_anchor_point"
+  external get_anchor_point : [>`actor] obj -> int*int
+    = "ml_clutter_actor_get_anchor_point"
   external set_anchor_point_from_gravity :
     [>`actor] obj -> ClutterEnums.gravity_type -> unit
     = "ml_clutter_actor_set_anchor_point_from_gravity"
     Object.make "ClutterTexture" pl
   external set_from_file : [>`texture] obj -> string -> bool
     = "ml_clutter_texture_set_from_file"
+  external get_base_size : [>`texture] obj -> (int*int)
+    = "ml_clutter_texture_get_base_size"
+  external get_max_tile_waste : [>`texture] obj -> int
+    = "ml_clutter_texture_get_max_tile_waste"
+  external set_max_tile_waste : [>`texture] obj -> int -> unit
+    = "ml_clutter_texture_set_max_tile_waste"
+  external get_cogl_texture : [>`texture] obj -> Clutter.coglhandle
+    = "ml_clutter_texture_get_cogl_texture"
+  external set_colg_texture : [>`texture] obj -> Clutter.coglhandle -> unit
+    = "ml_clutter_texture_set_colg_texture"
   let make_params ~cont pl ?filename ?keep_aspect_ratio ?repeat_x ?repeat_y
       ?sync_size =
     let pl = (

File clutter/clutterRectangle.ml

   inherit rectangle_props
   inherit ClutterActor.actor_skel (as_actor obj)
   method obj : rectangle Clutter.obj = obj
-  (*method as_actor = as_actor obj
-  method show = ClutterProps.Actor.show self#as_actor*)
-  (*method as_actor : [< `actor] Clutter.obj = obj*)
-  (*method as_actor = (obj :> Clutter.actor obj)*)
-  (*method as_actor = (obj :> actor Clutter.obj)*)
 end
 
 class rectangle_signals_impl obj = object

File clutter/clutterStage.ml

 
 class ['a] stage_skel obj = object (self)
   inherit stage_props
-  inherit actor_props
   inherit ClutterContainer.container_skel (as_container obj)
   inherit ClutterActor.actor_skel (as_actor obj)
-  method private obj : stage Clutter.obj = obj
-  method as_stage = obj
+  method obj : stage Clutter.obj = obj
 end
 
 class stage_signals_impl obj = object

File clutter/clutterTexture.ml

 
 class texture_skel obj = object (self)
   inherit texture_props
-  inherit actor_props
   inherit ClutterActor.actor_skel (as_actor obj)
   method obj : texture Clutter.obj = obj
 end

File clutter/ml_actor.c

     ml_global_root_destroy(clos);
 }
 
-CAMLprim value ml_clutter_as_actor(value c) {
-  CAMLparam1(c);
-  CAMLreturn(Val_ClutterActor(CLUTTER_ACTOR(Pointer_val(c))));
-}
-
 ML_1(clutter_actor_show_all, ClutterActor_val, Unit);
 ML_1(clutter_actor_show, ClutterActor_val, Unit);
 ML_1(clutter_actor_get_width, ClutterActor_val, Val_int);

File clutter/ml_clutter.c

 #include "pango_tags.c"
 #include "ml_clutter.h"
 
+#define GObject_val(val) ((GObject*)Pointer_val(val))
+ML_1 (g_object_ref, GObject_val, Unit)
+
 // ClutterVertex
 #define ClutterVertex_val(val) ((ClutterVertex *)Pointer_val(val))
 #define Val_ClutterVertex(val) (Val_pointer(val))

File clutter/ml_container.c

   CAMLreturn(Val_ClutterContainer(CLUTTER_CONTAINER(Pointer_val(c))));
 }
 
+CAMLprim value ml_clutter_is_a_container(value c) {
+  CAMLparam1(c);
+  CAMLreturn(Val_bool(CLUTTER_IS_CONTAINER(Pointer_val(c))));
+}
+
 ML_2(clutter_container_add_actor, ClutterContainer_val, ClutterActor_val, Unit);
 
 CAMLprim value ml_clutter_container_foreach (value w, value clos)

File clutter/ml_texture.h

+#define ClutterTexture_val(val)       (check_cast(CLUTTER_TEXTURE, val))
+value Val_ClutterTexture_ (ClutterTexture *, gboolean);
+#define Val_ClutterTexture(p)         Val_ClutterTexture_(p, TRUE)
+#define Val_ClutterTexture_new(p)     Val_ClutterTexture_(p, FALSE)
+

File clutter/propcc.ml4

   prefix := baseM;
   (* Input *)
   (* Redefining saves space in bytecode! *)
-  headers  := ["open Gobject"; "open Data";
-               "module Object = GtkObject"];
+  headers  := ["open Gobject"; "open Data";];
   oheaders := ["open GtkSignal"; "open Gobject"; "open Data";
                "let set = set"; "let get = get"; "let param = param"];
   let ic = open_in f in
 <test-effect.*>: use_gtk, use_clutter
-<test-project.*>: use_gtk, use_clutter
+<test-project.*>: use_gtk, use_clutter, use_extlib

File tests/test-project.ml

 
 open Clutter
+module Array = struct
+  include Array
+
+  exception Found of int
+  let findi test a =
+    try
+      for i=0 to pred (length a) do
+	if test a.(i) then raise (Found i)
+      done;
+      raise Not_found
+    with Found i -> i
+      
+end
+
+let g_debug = Format.printf
+
+let init_handles group rect =
+  let blue = Color.rgba (0,0,0xff,0xff) in
+  let v1,v2,v3,v4 = rect#get_abs_allocation_vertices in
+  let points = List.map
+    (fun v ->
+       let r = ClutterRectangle.rectangle ~color:blue#obj ~width:5 ~height:5
+	 ~x:0 ~y:0 () in
+       group#add r#as_actor;
+       r#set_position ~x:((Fixed.to_int v#x) - r#width / 2)
+	 ~y:((Fixed.to_int v#y) - r#height / 2);
+       r#raise_top;
+       r#show;
+       r
+    ) [v1;v2;v3;v4] in
+  v1#set_x (Fixed.from_int (rect#width / 2));
+  v1#set_y (Fixed.from_int (rect#height / 2));
+  v1#set_z 0;
+
+  rect#apply_transform_to_point v1#obj v2#obj;
+  let r = ClutterRectangle.rectangle ~color:blue#obj ~width:5 ~height:5 ~x:0
+    ~y:0 () in
+  group#add r#as_actor;
+  r#set_position ~x:((Fixed.to_int v2#x) - r#width / 2)
+    ~y:((Fixed.to_int v2#y) - r#height / 2);
+  r#raise_top;
+  r#show;
+  Array.of_list (List.append points [r])
+
+let place_handles rect points =
+  let v1,v2,v3,v4 = rect#get_abs_allocation_vertices in
+  let vertices = [|v1;v2;v3;v4|] in
+  Array.iteri
+    (fun i v ->
+       let r = points.(i) in
+       r#set_position ~x:((Fixed.to_int v#x) - r#width / 2)
+	 ~y:((Fixed.to_int v#y) - r#height / 2)
+    ) vertices;
+  v1#set_x (Fixed.from_int (rect#width / 2));
+  v1#set_y (Fixed.from_int (rect#height / 2));
+  v1#set_z 0;
+  rect#apply_transform_to_point v1#obj v2#obj;
+  let r = points.(4) in
+  points.(4)#set_position ~x:((Fixed.to_int v2#x) - r#width / 2)
+    ~y:((Fixed.to_int v2#y) - 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
+
+    | `MOTION evt -> 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
+	      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);
+	      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
+		    0 ->
+		      box2#set_x1 (box2#x1 + xp);
+		      box2#set_y1 (box2#y1 + yp);
+		  | 1 ->
+		      box2#set_x2 (box2#x2 + xp);
+		      box2#set_y1 (box2#y1 + yp);
+		  | 2 ->
+		      box2#set_x1 (box2#x1 + xp);
+		      box2#set_y2 (box2#y2 + yp);
+		  | 3 ->
+		      box2#set_x2 (box2#x2 + xp);
+		      box2#set_y2 (box2#y2 + yp)
+		in
+		rect#allocate box2 true
+	      end
+	    with Not_found -> () end
+	| _ -> () end
+
+    | `RELEASE evt ->
+	dragging := None
+    | _ ->
+	g_debug "received irrelevant event"
+	  
+  
 let _ =
   let stage_color = Color.rgba (0x0, 0x0, 0x0, 0xff)
   and white = Color.rgba (0xff, 0xff, 0xff, 0xff) in
 
   main_stage#show_all;
 
+  let points = init_handles main_stage rect in
+  
+
   (*Clutt
   g_signal_connect (main_stage, "event", G_CALLBACK (on_event), NULL);
   init_handles ();*)