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=0000000000000000000000000000000000000000;hb=c7514aaa249a96c5fdd39b1123fbdb38d92f20b6;hp=291eec9d98d52d54d960521d6b3e4a39c73e7dc9;hpb=1c7fb836e2af4f2f3d18afd0396701f2094265ff;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 deleted file mode 100644 index 291eec9d9..000000000 --- a/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/applications/radtest/tiPack.ml +++ /dev/null @@ -1,300 +0,0 @@ - -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