helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/applications/radtest/tiPack.ml

   1
   2 open Utils
   3 open Property
   4
   5 open TiContainer
   6
   7 class tibox ~(dir : Gtk.Tags.orientation) ~(widget : GPack.box)
   8     ~name ~parent_tree ~pos ?(insert_evbox=true) parent_window =
   9   let class_name =
  10     match dir with `VERTICAL -> "GPack.vbox" | _ -> "GPack.hbox" in
  11 object(self)
  12   val box = widget
  13   inherit ticontainer ~name ~widget ~parent_tree ~pos ~insert_evbox
  14       parent_window as container
  15
  16   method private class_name = class_name
  17
  18   method private name_of_add_method = "#pack"
  19
  20 (* removes the ::expand ::fill ::padding in the proplist of a box
  21    assumes that these are the only properties with a :: in the name *)
  22   method private save_clean_proplist =
  23     List.filter container#save_clean_proplist
  24       ~f:(fun (n,p) ->
  25         try
  26           let i = String.index n ':' in
  27           i = String.length n || n.[i+1] <> ':'
  28         with Not_found -> true)
  29
  30   method private emit_clean_proplist =
  31     List.filter container#emit_clean_proplist
  32       ~f:(fun (n,p) ->
  33         try
  34           let i = String.index n ':' in
  35           i = String.length n || n.[i+1] <> ':'
  36         with Not_found -> true)
  37
  38   method change_name_in_proplist oldn newn =
  39     proplist <- List.fold_left ~init:proplist ~f:
  40         (fun pl propname ->
  41           change_property_name (oldn ^ propname) (newn ^ propname) pl)
  42         [ "::expand"; "::fill"; "::padding" ];
  43     Propwin.update self false
  44
  45   method child_up child =
  46     let pos = list_pos ~item:child (List.map ~f:fst children) in
  47     if pos > 0 then begin
  48       box#reorder_child child#base ~pos:(pos-1);
  49       children <- list_reorder_up children ~pos;
  50       stree#item_up ~pos
  51     end
  52
  53   method child_down child =
  54     let pos = list_pos ~item:child (List.map ~f:fst children) in
  55     if pos < (List.length children - 1) then begin
  56       box#reorder_child child#base ~pos:(pos+1);
  57       children <- list_reorder_down children ~pos;
  58       stree#item_up ~pos:(pos+1)
  59     end
  60
  61   method private add child ~pos =
  62     box#pack  child#base;
  63     if pos < 0 then begin
  64       children <-  children @ [(child, `START)]
  65     end
  66     else begin
  67       children <- list_insert ~item:(child, `START) children ~pos;
  68       box#reorder_child child#base ~pos
  69     end;
  70     let n = child#name in
  71     let expand =
  72       new prop_bool ~name:"expand" ~init:"false" ~set:
  73         begin fun v ->
  74           box#set_child_packing (child#base) ~expand:v;
  75           Propwin.update child false;
  76           Propwin.update self false; true
  77         end
  78     and fill =
  79       new prop_bool ~name:"fill" ~init:"true" ~set:
  80         begin fun v ->
  81           box#set_child_packing (child#base) ~fill:v;
  82           Propwin.update child false;
  83           Propwin.update self false; true
  84         end
  85     and padding =
  86       new prop_int ~name:"padding" ~init:"0" ~set:
  87         begin fun v ->
  88           box#set_child_packing (child#base) ~padding:v;
  89           Propwin.update child false;
  90           Propwin.update self false; true
  91         end
  92     in
  93     proplist <-  proplist @
  94       [ (n ^ "::expand"),  expand;
  95         (n ^ "::fill"),    fill;
  96         (n ^ "::padding"), padding ];
  97     child#add_to_proplist
  98       [ "expand", expand; "fill", fill; "padding", padding ];
  99     Propwin.update self true
 100
 101
 102   method remove child =
 103     box#remove (child#base);
 104     children <- list_remove ~f:(fun (ch, _) -> ch = child) children;
 105     let n = child#name in
 106     proplist <-  List.fold_left ~init:proplist
 107         ~f:(fun acc n -> List.remove_assoc n acc)
 108         [ (n ^ "::expand"); (n ^ "::fill"); (n ^ "::padding") ];
 109     Propwin.update self true
 110
 111   initializer
 112     classe <- (match dir with `VERTICAL -> "vbox" | _ -> "hbox");
 113     proplist <-  proplist @
 114       [ "homogeneous",
 115         new prop_bool ~name:"homogeneous" ~init:"false"
 116           ~set:(ftrue box#set_homogeneous);
 117         "spacing",
 118         new prop_int ~name:"spacing" ~init:"0"
 119           ~set:(ftrue box#set_spacing)
 120       ]
 121 end
 122
 123 class tihbox = tibox ~dir:`HORIZONTAL
 124 class tivbox = tibox ~dir:`VERTICAL
 125
 126 let new_tihbox ~name ?(listprop = []) = new tihbox ~widget:(GPack.hbox ()) ~name
 127 let new_tivbox ~name ?(listprop = []) = new tivbox ~widget:(GPack.vbox ()) ~name
 128
 129
 130
 131
 132 class tibbox ~(dir : Gtk.Tags.orientation) ~(widget : GPack.button_box)
 133     ~name ~parent_tree ~pos ?(insert_evbox=true) parent_window =
 134   let class_name =
 135     match dir with `VERTICAL -> "GPack.button_box `VERTICAL"
 136     | _ -> "GPack.button_box `HORIZONTAL" in
 137 object(self)
 138   val bbox = widget
 139   inherit tibox ~dir ~widget:(widget :> GPack.box)
 140     ~name ~parent_tree ~pos ~insert_evbox parent_window
 141
 142   method private class_name = class_name
 143
 144 initializer
 145     classe <- (match dir with `VERTICAL -> "vbutton_box" | _ -> "hbutton_box");
 146     proplist <-  proplist @
 147       [ "layout",
 148         new prop_button_box_style ~name:"layout" ~init:"DEFAULT_STYLE"
 149           ~set:(ftrue bbox#set_layout);
 150         "spacing",
 151         new prop_int ~name:"spacing"
 152           ~init:(match dir with `VERTICAL -> "10" | _ -> "30")
 153 (*  donne -1 (defaut)
 154 (GtkPack.BBox.get_spacing bbox#as_button_box) *)
 155           ~set:(fun v -> bbox#set_spacing v;
 156             GtkBase.Widget.queue_resize bbox#as_widget; true);
 157         "child_width",
 158         new prop_int ~name:"child_width" ~init:"85"
 159           ~set:(fun v ->
 160             bbox#set_child_size ~width:v
 161               ~height:(int_of_string (self#get_property "child_height")) ();
 162             GtkBase.Widget.queue_resize bbox#as_widget; true);
 163         "child_height",
 164         new prop_int ~name:"child_height" ~init:"27"
 165           ~set:(fun v ->
 166             bbox#set_child_size ~height:v
 167               ~width:(int_of_string (self#get_property "child_width")) ();
 168             GtkBase.Widget.queue_resize bbox#as_widget; true);
 169         "child_ipad_x",
 170         new prop_int ~name:"child_ipad_x" ~init:"7"
 171           ~set:(fun v ->
 172             bbox#set_child_ipadding ~x:v
 173               ~y:(int_of_string (self#get_property "child_ipad_y")) ();
 174             GtkBase.Widget.queue_resize bbox#as_widget; true);
 175         "child_ipad_y",
 176         new prop_int ~name:"child_ipad_y" ~init:"0"
 177           ~set:(fun v ->
 178             bbox#set_child_ipadding ~y:v
 179               ~x:(int_of_string (self#get_property "child_ipad_x")) ();
 180             GtkBase.Widget.queue_resize bbox#as_widget; true);
 181       ]
 182 end
 183
 184
 185 (* TODO:  pour proplist/spacing il faudrait implementer
 186           les fonctions get_spacing ... (voir dans gtkPack) *)
 187
 188 class tihbutton_box = tibbox ~dir:`HORIZONTAL
 189 class tivbutton_box = tibbox ~dir:`VERTICAL
 190
 191 let new_tihbutton_box ~name ?(listprop = []) =
 192   new tihbutton_box ~widget:(GPack.button_box `HORIZONTAL ()) ~name
 193
 194 let new_tivbutton_box ~name ?(listprop = []) =
 195   new tivbutton_box ~widget:(GPack.button_box `VERTICAL ()) ~name
 196
 197
 198
 199
 200 let get_fixed_pos () =
 201   let rx = ref 0 and ry = ref 0 in
 202   let w  = GWindow.window ~modal:true () in
 203   let v  = GPack.vbox  ~packing:w#add () in
 204   let l  = GMisc.label ~text:"Enter position for child" ~packing:v#pack () in
 205   let h1 = GPack.hbox ~packing:v#pack () in
 206   let l1 = GMisc.label ~text:"x:" ~packing:h1#pack () in
 207   let e1 = GEdit.entry ~text:"0" ~packing:h1#pack () in
 208   let h2 = GPack.hbox ~packing:v#pack () in
 209   let l2 = GMisc.label ~text:"y" ~packing:h2#pack () in
 210   let e2 = GEdit.entry ~text:"0" ~packing:h2#pack () in
 211   let h7 = GPack.hbox ~packing:v#pack () in
 212   let b1 = GButton.button ~label:"OK" ~packing:h7#pack () in
 213   let b2 = GButton.button ~label:"Cancel" ~packing:h7#pack () in
 214   w#show ();
 215   b1#connect#clicked
 216     ~callback:(fun () ->
 217       begin
 218         try rx  := int_of_string e1#text with _ -> () end;
 219       begin
 220         try ry  := int_of_string e2#text with _ -> () end;
 221       w#destroy ());
 222   b2#connect#clicked ~callback:w#destroy;
 223   w#connect#destroy ~callback:GMain.Main.quit;
 224   GMain.Main.main ();
 225   !rx, !ry
 226
 227
 228 class tifixed ~(widget : GPack.fixed)
 229     ~name ~parent_tree ~pos ?(insert_evbox=true) parent_window =
 230 object(self)
 231   val fixed = widget
 232   inherit ticontainer ~widget
 233     ~name ~parent_tree ~pos ~insert_evbox parent_window
 234
 235   method private class_name = "GPack.fixed"
 236
 237   method private add child ~pos =
 238     let x, y = get_fixed_pos () in
 239     fixed#put child#base ~x ~y;
 240     children <-  children @ [(child, `START)]
 241   initializer
 242     classe <- "fixed"
 243 end
 244
 245 let new_tifixed ~name ?(listprop = []) =
 246   new tifixed ~widget:(GPack.fixed ()) ~name
 247
 248
 249
 250
 251
 252 class tinotebook ~(widget : GPack.notebook) ~name ~parent_tree ~pos
 253     ?(insert_evbox=true) parent_window =
 254 object(self)
 255   val notebook = widget
 256   inherit ticontainer ~name ~widget ~insert_evbox
 257       ~parent_tree ~pos parent_window as widget
 258
 259   method private class_name = "GPack.notebook"
 260
 261   method private add child ~pos =
 262     children <- children @ [child, `START];
 263     notebook#insert_page child#base ~pos;
 264     child#add_to_proplist
 265       [ "tab_label",
 266         new prop_string ~name:"tab_label" ~init:""
 267           ~set:(fun v -> notebook#set_page
 268               ~tab_label:((GMisc.label ~text:v())#coerce) child#base; true)
 269       ]
 270
 271
 272   initializer
 273     classe <- "notebook";
 274     proplist <-  proplist @
 275       [ "tab_pos",
 276         new prop_position ~name:"tab_ pos" ~init:"TOP"
 277           ~set:(ftrue notebook#set_tab_pos);
 278         "show_tabs",
 279         new prop_bool ~name:"show_tabs" ~init:"true"
 280           ~set:(ftrue notebook#set_show_tabs);
 281         "homogeneous_tabs",
 282         new prop_bool ~name:"homogeneous_tabs" ~init:"true"
 283           ~set:(ftrue notebook#set_homogeneous_tabs);
 284         "show_border",
 285         new prop_bool ~name:"show_border" ~init:"true"
 286           ~set:(ftrue notebook#set_show_border);
 287         "scrollable",
 288         new prop_bool ~name:"scrollable" ~init:"false"
 289           ~set:(ftrue notebook#set_scrollable);
 290         "tab_border",
 291         new prop_int ~name:"tab_border" ~init:"2"
 292           ~set:(ftrue notebook#set_tab_border);
 293         "popup_enable",
 294         new prop_bool ~name:"popup_enable" ~init:"false"
 295           ~set:(ftrue notebook#set_popup)
 296       ]
 297 end
 298
 299 let new_tinotebook ~name ?(listprop = []) =
 300   new tinotebook ~widget:(GPack.notebook ()) ~name