--- /dev/null
+
+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
projects / helm.git / blobdiff