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

   1 open Gtk
   2
   3 open Utils
   4 open Property
   5
   6 open TiContainer
   7
   8 class tiframe ~(widget : GBin.frame) ~name ~parent_tree ~pos
   9     ?(insert_evbox=true) parent_window =
  10 object
  11   val frame = widget
  12   inherit ticontainer ~name ~widget ~parent_tree ~pos
  13       ~insert_evbox parent_window as container
  14
  15   method private class_name = "GBin.frame"
  16
  17   method private get_mandatory_props = [ "label" ]
  18
  19   initializer
  20     classe <- "frame";
  21     frame#set_label name;
  22     proplist <- proplist @
  23       [ "label",
  24         new prop_string ~name:"label" ~init:name ~set:(ftrue frame#set_label);
  25        "label_xalign",
  26         new prop_float ~name:"label_xalign" ~init:"0.0" ~min:0. ~max:1.
  27             ~set:(fun x -> frame#set_label_align ~x (); true);
  28        "shadow_type",
  29         new prop_shadow ~name:"shadow_type" ~init:"ETCHED_IN"
  30           ~set:(ftrue frame#set_shadow_type) ]
  31 end
  32
  33 let new_tiframe ~name ?(listprop = []) =
  34   new tiframe ~widget:(GBin.frame ()) ~name
  35
  36
  37
  38
  39 class tiaspect_frame ~(widget : GBin.aspect_frame) ~name ~parent_tree ~pos
  40     ?(insert_evbox=true) parent_window =
  41 object
  42   val aspect_frame = widget
  43   inherit tiframe ~name ~widget:(widget :> GBin.frame) ~parent_tree ~pos
  44       ~insert_evbox parent_window
  45
  46   method private class_name = "GBin.aspect_frame"
  47
  48   initializer
  49     classe <- "aspect_frame";
  50     frame#set_label name;
  51     proplist <- proplist @
  52       [ "obey_child",
  53         new prop_bool ~name:"obey_child" ~init:"true"
  54           ~set:(ftrue aspect_frame#set_obey_child);
  55        "ratio",
  56         new prop_float ~name:"ratio" ~init:"1.0" ~min:0. ~max:1.
  57             ~set:(ftrue aspect_frame#set_ratio)
  58       ]
  59 end
  60
  61 let new_tiaspect_frame ~name ?(listprop = []) =
  62   new tiaspect_frame ~widget:(GBin.aspect_frame ()) ~name
  63
  64
  65
  66
  67 class tievent_box ~(widget : GBin.event_box) ~name ~parent_tree ~pos
  68     ?(insert_evbox=true) parent_window =
  69 object
  70   val event_box = widget
  71   inherit ticontainer ~name ~widget ~parent_tree ~pos
  72       ~insert_evbox parent_window
  73
  74   method private class_name = "GBin.event_box"
  75   initializer
  76     classe <- "event_box"
  77 end
  78
  79 let new_event_box ~name ?(listprop = []) =
  80   new tievent_box ~widget:(GBin.event_box ()) ~name
  81
  82
  83
  84
  85 class tihandle_box ~(widget : GBin.handle_box) ~name ~parent_tree ~pos
  86     ?(insert_evbox=true) parent_window =
  87 object
  88   val handle_box = widget
  89   inherit ticontainer ~name ~widget ~parent_tree ~pos
  90       ~insert_evbox parent_window
  91
  92   method private class_name = "GBin.handle_box"
  93
  94   initializer
  95     classe <- "handle_box";
  96     proplist <- proplist @
  97       [ "shadow_type",
  98         new prop_shadow ~name:"shadow_type" ~init:"OUT"
  99           ~set:(ftrue handle_box#set_shadow_type);
 100         "handle_position",
 101         new prop_position ~name:"handle_position" ~init:"LEFT"
 102           ~set:(ftrue handle_box#set_handle_position);
 103         "snap_edge",
 104         new prop_position ~name:"snap_edge" ~init:"TOP"
 105           ~set:(ftrue handle_box#set_snap_edge)
 106       ]
 107 end
 108
 109 let new_handle_box ~name ?(listprop = []) =
 110   new tihandle_box ~widget:(GBin.handle_box ()) ~name
 111
 112
 113
 114
 115
 116 class tiviewport ~(widget : GBin.handle_box) ~name ~parent_tree ~pos
 117     ?(insert_evbox=true) parent_window =
 118 object
 119   val viewport = widget
 120   inherit ticontainer ~name ~widget ~parent_tree ~pos
 121       ~insert_evbox parent_window
 122
 123   method private class_name = "GBin.viewport"
 124
 125   initializer
 126     classe <- "viewport";
 127     proplist <- proplist @
 128       [ "shadow_type",
 129         new prop_shadow ~name:"shadow_type" ~init:"OUT"
 130           ~set:(ftrue viewport#set_shadow_type)
 131       ]
 132 end
 133
 134 let new_viewport ~name ?(listprop = []) =
 135   new tiviewport ~widget:(GBin.handle_box ()) ~name
 136
 137
 138
 139
 140
 141 class tiscrolled_window ~(widget : GBin.scrolled_window)
 142     ~name ~parent_tree ~pos ?(insert_evbox=true) parent_window =
 143   object(self)
 144     val scrolled_window = widget
 145     inherit ticontainer ~name ~insert_evbox
 146         ~parent_tree ~pos ~widget parent_window
 147
 148     method private class_name = "GBin.scrolled_window"
 149     method private name_of_add_method = "#add_with_viewport"
 150
 151     method private add rw ~pos =
 152       scrolled_window#add_with_viewport (rw#base);
 153       children <- [ rw, `START];
 154       self#set_full_menu false;
 155       tree_item#drag#dest_unset ()
 156
 157 (* we must remove the child from the viewport,
 158    not from the scrolled_window;
 159    it is not mandatory to remove the viewport
 160    from the scrolled_window *)
 161     method remove child =
 162       let viewport = (new GContainer.container (GtkBase.Container.cast (List.hd scrolled_window#children)#as_widget)) in
 163       viewport#remove child#base;
 164 (*      scrolled_window#remove (List.hd scrolled_window#children); *)
 165       children <- [ ];
 166       self#set_full_menu true;
 167       tree_item#drag#dest_set ~actions:[`COPY]
 168         [ { target = "STRING"; flags = []; info = 0} ]
 169
 170
 171     initializer
 172       classe <- "scrolled_window";
 173       proplist <- proplist @
 174         [ "hscrollbar_policy",
 175           new prop_policy ~name:"hscrollbar_policy" ~init:"ALWAYS"
 176             ~set:(ftrue scrolled_window#set_hpolicy);
 177           "vscrollbar_policy",
 178           new prop_policy ~name:"vscrollbar_policy" ~init:"ALWAYS"
 179             ~set:(ftrue scrolled_window#set_vpolicy) ]
 180 end
 181
 182 let new_tiscrolled_window ~name ?(listprop = []) =
 183   new tiscrolled_window ~widget:(GBin.scrolled_window ()) ~name
 184
 185