1. Reid van Melle
  2. clutter-ocaml

Source

clutter-ocaml / tests / test-project.ml


open Clutter
module Rectangle = ClutterRectangle
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

open Printf
let g_debug = Format.printf

let init_handles (group:#ClutterContainer.container_skel) 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 = Rectangle.create ~color:blue ~width:5 ~height:5
	 ~x:0 ~y:0 () in
       group#add r;
       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 = (units_from_int (rect#width / 2));
	     vy = (units_from_int (rect#height / 2));
	     vz = (units_from_int 0) } in

  let v2 = rect#apply_transform_to_point v1 in
  let r = Rectangle.create ~color:blue ~width:5 ~height:5 ~x:0
    ~y:0 () in
  group#add r;
  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])

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:((units_to_int v.vx) - r#width / 2)
	 ~y:((units_to_int v.vy) - r#height / 2)
    ) vertices;
  let v1 = { vx = (units_from_int (rect#width / 2));
	     vy = (units_from_int (rect#height / 2));
	     vz = (units_from_int 0) } in
  let v2 = rect#apply_transform_to_point v1 in
  let r = points.(4) in
  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
  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 -> begin match !dragging with
	  Some dragging -> begin
	    try
	      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\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 "adjusting box by %g,%g, handle %d\n%!"
		  (units_to_float xp) (units_to_float yp) idx;
		let box2 = match idx with
		    0 ->
		      {box2 with x1 = (box2.x1 +~ xp); y1 = (box2.y1 +~ yp);}
		  | 1 ->
		      {box2 with x2 = (box2.x2 +~ xp); y1 = (box2.y1 +~ yp);}
		  | 2 ->
		      {box2 with x1 = (box2.x1 +~ xp); y2 = (box2.y2 +~ yp);}
		  | 3 ->
		      {box2 with x2 = (box2.x2 +~ xp); y2 = (box2.y2 +~ yp);}
		  | _ -> failwith "impossible"
		in
		rect#allocate box2 true;
	      end;
	      place_handles rect points;
	      true
	    with Not_found -> true; end
	| _ -> true end

    | `BUTTON_RELEASE ->
	dragging := None;
	true
    | `ENTER -> printf "enter\n%!"; true
    | `LEAVE -> printf "leave\n%!"; true
    | `STAGE_STATE -> printf "stage_state\n%!"; true
    | _ ->
	printf "irrelevant event\n%!"; true
	(*g_debug "received irrelevant event";
	true*)
	  
  
let _ =
  let stage_color = Color.rgba (0x0, 0x0, 0x0, 0xff)
  and white = Color.rgba (0xff, 0xff, 0xff, 0xff) in

  let main_stage = ClutterStage.get_default () in
  main_stage#set_color stage_color;
  main_stage#set_size ~width:640 ~height:480;
  
  let rect = Rectangle.create ~color:white
    ~width:320 ~height:240 ~x:180 ~y:120 () in
  
  
  rect#set_rotation `Y_AXIS ~angle:60. ~x:0 ~y:0 ~z:0;
  rect#set_reactive true;
  let _ = rect#connect#enter_event (fun _ -> printf "rect enter\n%!"; true) in
  let _ = rect#connect#leave_event (fun _ -> printf "rect leave\n%!"; true) in
  let _ = rect#connect#button_press_event
    (fun _ -> printf "rect press\n%!"; true) in
  let _ = rect#connect#button_release_event
    (fun _ -> printf "rect release\n%!"; true) in
  let _ = rect#connect#destroy ( fun () -> printf "rect destroy\n%!") in
  let _ = rect#connect#focus_in ( fun () -> printf "rect focusin\n%!") in
  let _ = rect#connect#focus_out (fun () -> printf "rect focusout\n%!") in
  let _ = rect#connect#parent_set (fun _ -> printf "rect parentset\n%!") in
  let _ = rect#connect#key_press_event
    (fun _ -> printf "rect keypress\n%!"; true) in
  let _ = rect#connect#key_release_event
    (fun _ -> printf "rect keyrelease\n%!"; true) in
  main_stage#add rect;

  let label = ClutterLabel.label ~font_name:"Mono 8pt"
    ~text:"Drag the blue rectangles" ~color:white ~x:10 ~y:10 () in
  
  main_stage#add label;

  main_stage#show_all;

  let box1 = rect#get_allocation_box in
  ActorBox.debug "box1" box1;

  let points = init_handles main_stage rect in
  
  let _ = main_stage#connect#event (on_event rect points main_stage) in
  
  main()