+++ /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