X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FDEVEL%2Flablgtk%2Flablgtk_20000829-0.1.0%2Fapplications%2Fradtest%2FtiPack.ml;fp=helm%2FDEVEL%2Flablgtk%2Flablgtk_20000829-0.1.0%2Fapplications%2Fradtest%2FtiPack.ml;h=291eec9d98d52d54d960521d6b3e4a39c73e7dc9;hb=2ee84a2a641938988703e329aef9fc3c5eb5aacf;hp=0000000000000000000000000000000000000000;hpb=34d83812af9b7064cc8f735c2a78169881140010;p=helm.git

diff --git a/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/applications/radtest/tiPack.ml b/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/applications/radtest/tiPack.ml
new file mode 100644
index 000000000..291eec9d9
--- /dev/null
+++ b/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/applications/radtest/tiPack.ml
@@ -0,0 +1,300 @@
+
+open Utils
+open Property
+
+open TiContainer
+
+class tibox ~(dir : Gtk.Tags.orientation) ~(widget : GPack.box)
+    ~name ~parent_tree ~pos ?(insert_evbox=true) parent_window =
+  let class_name =
+    match dir with `VERTICAL -> "GPack.vbox" | _ -> "GPack.hbox" in
+object(self)
+  val box = widget
+  inherit ticontainer ~name ~widget ~parent_tree ~pos ~insert_evbox
+      parent_window as container
+
+  method private class_name = class_name
+
+  method private name_of_add_method = "#pack"
+
+(* removes the ::expand ::fill ::padding in the proplist of a box
+   assumes that these are the only properties with a :: in the name *)
+  method private save_clean_proplist =
+    List.filter container#save_clean_proplist
+      ~f:(fun (n,p) ->
+	try
+	  let i = String.index n ':' in
+	  i = String.length n || n.[i+1] <> ':'
+	with Not_found -> true)
+
+  method private emit_clean_proplist =
+    List.filter container#emit_clean_proplist
+      ~f:(fun (n,p) ->
+	try
+	  let i = String.index n ':' in
+	  i = String.length n || n.[i+1] <> ':'
+	with Not_found -> true)
+
+  method change_name_in_proplist oldn newn =
+    proplist <- List.fold_left ~init:proplist ~f:
+	(fun pl propname ->
+	  change_property_name (oldn ^ propname) (newn ^ propname) pl)
+	[ "::expand"; "::fill"; "::padding" ];
+    Propwin.update self false
+
+  method child_up child =
+    let pos = list_pos ~item:child (List.map ~f:fst children) in
+    if pos > 0 then begin
+      box#reorder_child child#base ~pos:(pos-1);
+      children <- list_reorder_up children ~pos;
+      stree#item_up ~pos
+    end
+	    
+  method child_down child =
+    let pos = list_pos ~item:child (List.map ~f:fst children) in
+    if pos < (List.length children - 1) then begin
+      box#reorder_child child#base ~pos:(pos+1);
+      children <- list_reorder_down children ~pos;
+      stree#item_up ~pos:(pos+1)
+    end
+	    
+  method private add child ~pos =
+    box#pack  child#base;
+    if pos < 0 then begin
+      children <-  children @ [(child, `START)]
+    end
+    else begin
+      children <- list_insert ~item:(child, `START) children ~pos;
+      box#reorder_child child#base ~pos
+    end;
+    let n = child#name in
+    let expand =
+      new prop_bool ~name:"expand" ~init:"false" ~set:
+	begin fun v ->
+	  box#set_child_packing (child#base) ~expand:v;
+	  Propwin.update child false;
+	  Propwin.update self false; true
+	end
+    and fill =
+      new prop_bool ~name:"fill" ~init:"true" ~set:
+	begin fun v ->
+	  box#set_child_packing (child#base) ~fill:v;
+	  Propwin.update child false;
+	  Propwin.update self false; true
+	end
+    and padding =
+      new prop_int ~name:"padding" ~init:"0" ~set:
+	begin fun v ->
+	  box#set_child_packing (child#base) ~padding:v;
+	  Propwin.update child false;
+	  Propwin.update self false; true
+	end
+    in
+    proplist <-  proplist @ 
+      [ (n ^ "::expand"),  expand;
+	(n ^ "::fill"),    fill;
+        (n ^ "::padding"), padding ];
+    child#add_to_proplist
+      [ "expand", expand; "fill", fill; "padding", padding ];
+    Propwin.update self true
+         
+
+  method remove child =
+    box#remove (child#base);
+    children <- list_remove ~f:(fun (ch, _) -> ch = child) children;
+    let n = child#name in
+    proplist <-  List.fold_left ~init:proplist
+	~f:(fun acc n -> List.remove_assoc n acc)
+	[ (n ^ "::expand"); (n ^ "::fill"); (n ^ "::padding") ];
+    Propwin.update self true
+
+  initializer
+    classe <- (match dir with `VERTICAL -> "vbox" | _ -> "hbox");
+    proplist <-  proplist @
+      [ "homogeneous",
+	new prop_bool ~name:"homogeneous" ~init:"false"
+	  ~set:(ftrue box#set_homogeneous);
+	"spacing",
+	new prop_int ~name:"spacing" ~init:"0"
+	  ~set:(ftrue box#set_spacing)
+      ]
+end
+
+class tihbox = tibox ~dir:`HORIZONTAL
+class tivbox = tibox ~dir:`VERTICAL
+
+let new_tihbox ~name ?(listprop = []) = new tihbox ~widget:(GPack.hbox ()) ~name
+let new_tivbox ~name ?(listprop = []) = new tivbox ~widget:(GPack.vbox ()) ~name
+
+
+
+
+class tibbox ~(dir : Gtk.Tags.orientation) ~(widget : GPack.button_box)
+    ~name ~parent_tree ~pos ?(insert_evbox=true) parent_window =
+  let class_name =
+    match dir with `VERTICAL -> "GPack.button_box `VERTICAL"
+    | _ -> "GPack.button_box `HORIZONTAL" in
+object(self)
+  val bbox = widget
+  inherit tibox ~dir ~widget:(widget :> GPack.box)
+    ~name ~parent_tree ~pos ~insert_evbox parent_window
+
+  method private class_name = class_name
+
+initializer
+    classe <- (match dir with `VERTICAL -> "vbutton_box" | _ -> "hbutton_box");
+    proplist <-  proplist @
+      [ "layout",
+	new prop_button_box_style ~name:"layout" ~init:"DEFAULT_STYLE"
+	  ~set:(ftrue bbox#set_layout);
+	"spacing",
+	new prop_int ~name:"spacing"
+	  ~init:(match dir with `VERTICAL -> "10" | _ -> "30")
+(*  donne -1 (defaut)  
+(GtkPack.BBox.get_spacing bbox#as_button_box) *)
+	  ~set:(fun v -> bbox#set_spacing v;
+	    GtkBase.Widget.queue_resize bbox#as_widget; true);
+	"child_width",
+	new prop_int ~name:"child_width" ~init:"85"
+	  ~set:(fun v ->
+	    bbox#set_child_size ~width:v
+	      ~height:(int_of_string (self#get_property "child_height")) ();
+	    GtkBase.Widget.queue_resize bbox#as_widget; true);
+	"child_height",
+	new prop_int ~name:"child_height" ~init:"27"
+	  ~set:(fun v ->
+	    bbox#set_child_size ~height:v
+	      ~width:(int_of_string (self#get_property "child_width")) (); 
+	    GtkBase.Widget.queue_resize bbox#as_widget; true);
+	"child_ipad_x",
+	new prop_int ~name:"child_ipad_x" ~init:"7"
+	  ~set:(fun v ->
+	    bbox#set_child_ipadding ~x:v
+	      ~y:(int_of_string (self#get_property "child_ipad_y")) ();
+	    GtkBase.Widget.queue_resize bbox#as_widget; true);
+	"child_ipad_y",
+	new prop_int ~name:"child_ipad_y" ~init:"0"
+	  ~set:(fun v ->
+	    bbox#set_child_ipadding ~y:v
+	      ~x:(int_of_string (self#get_property "child_ipad_x")) (); 
+	    GtkBase.Widget.queue_resize bbox#as_widget; true);
+      ]
+end
+
+
+(* TODO:  pour proplist/spacing il faudrait implementer
+          les fonctions get_spacing ... (voir dans gtkPack) *)
+
+class tihbutton_box = tibbox ~dir:`HORIZONTAL
+class tivbutton_box = tibbox ~dir:`VERTICAL
+
+let new_tihbutton_box ~name ?(listprop = []) =
+  new tihbutton_box ~widget:(GPack.button_box `HORIZONTAL ()) ~name
+
+let new_tivbutton_box ~name ?(listprop = []) =
+  new tivbutton_box ~widget:(GPack.button_box `VERTICAL ()) ~name
+
+
+
+
+let get_fixed_pos () =
+  let rx = ref 0 and ry = ref 0 in
+  let w  = GWindow.window ~modal:true () in
+  let v  = GPack.vbox  ~packing:w#add () in
+  let l  = GMisc.label ~text:"Enter position for child" ~packing:v#pack () in
+  let h1 = GPack.hbox ~packing:v#pack () in
+  let l1 = GMisc.label ~text:"x:" ~packing:h1#pack () in
+  let e1 = GEdit.entry ~text:"0" ~packing:h1#pack () in
+  let h2 = GPack.hbox ~packing:v#pack () in
+  let l2 = GMisc.label ~text:"y" ~packing:h2#pack () in
+  let e2 = GEdit.entry ~text:"0" ~packing:h2#pack () in
+  let h7 = GPack.hbox ~packing:v#pack () in
+  let b1 = GButton.button ~label:"OK" ~packing:h7#pack () in
+  let b2 = GButton.button ~label:"Cancel" ~packing:h7#pack () in
+  w#show ();
+  b1#connect#clicked
+    ~callback:(fun () ->
+      begin
+	try rx  := int_of_string e1#text with _ -> () end;
+      begin
+	try ry  := int_of_string e2#text with _ -> () end;
+      w#destroy ());
+  b2#connect#clicked ~callback:w#destroy;
+  w#connect#destroy ~callback:GMain.Main.quit;
+  GMain.Main.main ();
+  !rx, !ry
+
+
+class tifixed ~(widget : GPack.fixed)
+    ~name ~parent_tree ~pos ?(insert_evbox=true) parent_window =
+object(self)
+  val fixed = widget
+  inherit ticontainer ~widget
+    ~name ~parent_tree ~pos ~insert_evbox parent_window
+
+  method private class_name = "GPack.fixed"
+
+  method private add child ~pos =
+    let x, y = get_fixed_pos () in
+    fixed#put child#base ~x ~y;
+    children <-  children @ [(child, `START)]
+  initializer
+    classe <- "fixed"
+end
+
+let new_tifixed ~name ?(listprop = []) =
+  new tifixed ~widget:(GPack.fixed ()) ~name
+
+
+
+
+
+class tinotebook ~(widget : GPack.notebook) ~name ~parent_tree ~pos
+    ?(insert_evbox=true) parent_window =
+object(self)
+  val notebook = widget
+  inherit ticontainer ~name ~widget ~insert_evbox
+      ~parent_tree ~pos parent_window as widget
+
+  method private class_name = "GPack.notebook"
+
+  method private add child ~pos =
+    children <- children @ [child, `START];
+    notebook#insert_page child#base ~pos;
+    child#add_to_proplist
+      [ "tab_label",
+	new prop_string ~name:"tab_label" ~init:""
+	  ~set:(fun v -> notebook#set_page
+	      ~tab_label:((GMisc.label ~text:v())#coerce) child#base; true)
+      ]
+
+
+  initializer
+    classe <- "notebook";
+    proplist <-  proplist @
+      [ "tab_pos",
+	new prop_position ~name:"tab_ pos" ~init:"TOP"
+	  ~set:(ftrue notebook#set_tab_pos);
+	"show_tabs",
+	new prop_bool ~name:"show_tabs" ~init:"true"
+	  ~set:(ftrue notebook#set_show_tabs);
+	"homogeneous_tabs",
+	new prop_bool ~name:"homogeneous_tabs" ~init:"true"
+	  ~set:(ftrue notebook#set_homogeneous_tabs);
+	"show_border",
+	new prop_bool ~name:"show_border" ~init:"true"
+	  ~set:(ftrue notebook#set_show_border);
+	"scrollable",
+	new prop_bool ~name:"scrollable" ~init:"false"
+	  ~set:(ftrue notebook#set_scrollable);
+	"tab_border",
+	new prop_int ~name:"tab_border" ~init:"2"
+	  ~set:(ftrue notebook#set_tab_border);
+	"popup_enable",
+	new prop_bool ~name:"popup_enable" ~init:"false"
+	  ~set:(ftrue notebook#set_popup)
+      ]
+end
+
+let new_tinotebook ~name ?(listprop = []) =
+  new tinotebook ~widget:(GPack.notebook ()) ~name