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

   1
   2 open Utils
   3 open Property
   4
   5 open TiBase
   6 open TiContainer
   7
   8
   9 class tiseparator ~(dir : Gtk.Tags.orientation) ~(widget : GObj.widget_full)
  10     ~name ~parent_tree ~pos ?(insert_evbox=true) parent_window =
  11 object
  12   val separator = widget
  13   inherit tiwidget ~name ~widget ~parent_tree ~pos parent_window ~insert_evbox
  14
  15   method private class_name =
  16     match dir with `VERTICAL -> "GMisc.separator `VERTICAL"
  17     | `HORIZONTAL -> "GMisc.separator `HORIZONTAL"
  18   initializer
  19     classe <-
  20     (match dir with `VERTICAL -> "vseparator" | `HORIZONTAL -> "hseparator")
  21
  22 end
  23
  24 let new_tihseparator ~name ?(listprop = []) =
  25   new tiseparator ~dir: `HORIZONTAL ~name
  26     ~widget:(GMisc.separator `HORIZONTAL ())
  27 let new_tivseparator ~name ?(listprop = []) =
  28   new tiseparator ~dir: `VERTICAL ~name
  29     ~widget:(GMisc.separator `VERTICAL ())
  30
  31
  32
  33
  34 class tistatusbar ~(widget : GMisc.statusbar) ~name ~parent_tree ~pos
  35     ?(insert_evbox=true) parent_window =
  36 object(self)
  37   val statusbar = widget
  38   inherit ticontainer ~name ~widget ~insert_evbox
  39       ~parent_tree ~pos parent_window as widget
  40
  41   method private class_name = "GMisc.statusbar"
  42
  43   initializer
  44     classe <- "statusbar"
  45 end
  46
  47 let new_tistatusbar ~name ?(listprop = []) =
  48   new tistatusbar ~widget:(GMisc.statusbar ()) ~name
  49
  50
  51
  52 class timisc ~(widget : GMisc.misc) ~name ~parent_tree ~pos
  53     ?(insert_evbox=true) parent_window =
  54 object(self)
  55   val misc = widget
  56   inherit tiwidget ~name ~widget ~insert_evbox
  57       ~parent_tree ~pos parent_window as widget
  58
  59   method private class_name = failwith "timisc::class_name"
  60
  61   initializer
  62     proplist <- proplist @
  63       [ "x_alignment",
  64         new prop_float ~name:"x alignment" ~init:"0.5" ~min:0. ~max:1.
  65           ~set:(fun v -> misc#set_alignment ~x:v (); true);
  66         "y_alignment",
  67         new prop_float ~name:"y alignment" ~init:"0.5" ~min:0. ~max:1.
  68           ~set:(fun v -> misc#set_alignment ~y:v (); true);
  69         "x_padding",
  70         new prop_int ~name:"x padding" ~init:"0.5"
  71           ~set:(fun v -> misc#set_padding ~x:v (); true);
  72         "y_padding",
  73         new prop_int ~name:"y padding" ~init:"0.5"
  74           ~set:(fun v -> misc#set_padding ~y:v (); true)
  75
  76       ]
  77 end
  78
  79
  80 class tiarrow ~(widget : GMisc.arrow) ~name ~parent_tree ~pos
  81     ?(insert_evbox=true) parent_window =
  82 object(self)
  83   val arrow = widget
  84   inherit timisc ~name ~widget:(widget :> GMisc.misc) ~insert_evbox
  85       ~parent_tree ~pos parent_window as widget
  86
  87   method private class_name = "GMisc.arrow"
  88   initializer
  89     classe <- "arrow";
  90 end
  91
  92
  93 (* TODO   fenetre demandant kind et shadow
  94 let new_tiarrow ~name = new tiarrow ~widget:(GMisc.arrow ()) ~name
  95 *)
  96
  97
  98 class tilabel ~(widget : GMisc.label) ~name ~parent_tree ~pos
  99     ?(insert_evbox=true) parent_window =
 100 object(self)
 101   val labelw = widget
 102   inherit timisc ~name ~widget:(widget :> GMisc.misc) ~insert_evbox
 103       ~parent_tree ~pos parent_window as widget
 104
 105   method private class_name = "GMisc.label"
 106
 107   method private get_mandatory_props = [ "text" ]
 108
 109   initializer
 110     classe <- "label";
 111     proplist <-  proplist @
 112       [ "text",
 113         new prop_string ~name:"text" ~init:name ~set:(ftrue labelw#set_text);
 114         "line_wrap",
 115         new prop_bool ~name:"line_wrap" ~init:"true"
 116           ~set:(ftrue labelw#set_line_wrap)
 117       ]
 118 end
 119
 120 let new_tilabel ~name ?(listprop = []) =
 121   new tilabel ~widget:(GMisc.label ~text:name ()) ~name
 122
 123
 124
 125
 126
 127 class ticolor_selection ~(widget : GMisc.color_selection) ~name ~parent_tree ~pos
 128     ?(insert_evbox=true) parent_window =
 129 object(self)
 130   val color_selection = widget
 131   inherit tiwidget ~name ~widget ~insert_evbox
 132       ~parent_tree ~pos parent_window as widget
 133
 134   method private class_name = "GMisc.color_selection"
 135
 136   initializer
 137     classe <- "color_selection";
 138     proplist <-  proplist @
 139       [ "use_opacity",
 140         new prop_bool ~name:"use_opacity" ~init:"false"
 141           ~set:(ftrue color_selection#set_opacity);
 142         "update_policy",
 143         new prop_update_type ~name:"update_policy" ~init:"CONTINUOUS"
 144           ~set:(ftrue color_selection#set_update_policy)
 145       ]
 146 end
 147
 148 let new_ticolor_selection ~name ?(listprop = []) =
 149   new ticolor_selection ~widget:(GMisc.color_selection ()) ~name
 150
 151
 152 class tipixmap ~(widget : GMisc.pixmap) ~name ~parent_tree ~pos
 153     ?(insert_evbox=true) parent_window =
 154 object(self)
 155   val pixmap = widget
 156   inherit timisc ~name ~widget:(widget :> GMisc.misc) ~insert_evbox
 157       ~parent_tree ~pos parent_window as widget
 158
 159   method private class_name = "GMisc.pixmap"
 160   initializer
 161     classe <- "pixmap";
 162     proplist <- proplist @
 163       [ "file",
 164         new prop_file ~name:"file" ~init:""
 165           ~set:(fun v ->
 166             pixmap#set_pixmap
 167               (GDraw.pixmap_from_xpm ~window:parent_window#tiwin#widget
 168                  ~file:v ());
 169             true)
 170       ]
 171 end
 172
 173 let new_tipixmap ~name ?(listprop = []) ~parent_tree ~pos ?(insert_evbox=true) (parent_window : window_and_tree0) =
 174   new tipixmap ~widget:(GMisc.pixmap (GDraw.pixmap_from_xpm
 175    ~window:parent_window#tiwin#widget ~file:"pixmap.xpm" ()) ()) ~name
 176     ~parent_tree ~pos ~insert_evbox parent_window