helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/gDraw.ml

   1 (* $Id$ *)
   2
   3 open Gaux
   4 open Gdk
   5
   6 type color = [
   7   | `COLOR of Color.t
   8   | `WHITE
   9   | `BLACK
  10   | `NAME of string
  11   | `RGB of int * int * int
  12 ]
  13
  14 let default_colormap = GtkBase.Widget.get_default_colormap
  15
  16 let color ?(colormap = default_colormap ()) (c : color) =
  17   match c with
  18   | `COLOR col -> col
  19   | #Gdk.Color.spec as def -> Color.alloc ~colormap def
  20
  21 type optcolor = [
  22   | `COLOR of Color.t
  23   | `WHITE
  24   | `BLACK
  25   | `NAME of string
  26   | `RGB of int * int * int
  27   | `DEFAULT
  28 ]
  29
  30 let optcolor ?colormap (c : optcolor) =
  31   match c with
  32   | `DEFAULT -> None
  33   | #color as c -> Some (color ?colormap c)
  34
  35 class ['a] drawable ?(colormap = default_colormap ()) w =
  36 object (self)
  37   val colormap = colormap
  38   val gc = GC.create w
  39   val w : 'a Gdk.drawable = w
  40   method color = color ~colormap
  41   method set_foreground col = GC.set_foreground gc (self#color col)
  42   method set_background col = GC.set_background gc (self#color col)
  43   method gc_values = GC.get_values gc
  44   method set_clip_region region = GC.set_clip_region gc region
  45   method set_line_attributes ?width ?style ?cap ?join () =
  46     let v = GC.get_values gc in
  47     GC.set_line_attributes gc
  48       ~width:(default v.GC.line_width ~opt:width)
  49       ~style:(default v.GC.line_style ~opt:style)
  50       ~cap:(default v.GC.cap_style ~opt:cap)
  51       ~join:(default v.GC.join_style ~opt:join)
  52   method point = Draw.point w gc
  53   method line = Draw.line w gc
  54   method rectangle = Draw.rectangle w gc
  55   method arc = Draw.arc w gc
  56   method polygon ?filled l = Draw.polygon w gc ?filled l
  57   method string s = Draw.string w gc ~string:s
  58   method image ~width ~height ?(xsrc=0) ?(ysrc=0) ?(xdest=0) ?(ydest=0) image =
  59     Draw.image w gc ~image ~width ~height ~xsrc ~ysrc ~xdest ~ydest
  60 end
  61
  62 class pixmap ?colormap ?mask pm = object
  63   inherit [[`pixmap]] drawable ?colormap pm as pixmap
  64   val bitmap = may_map mask ~f:
  65       begin fun x ->
  66         let mask = new drawable x in
  67         mask#set_foreground `WHITE;
  68         mask
  69       end
  70   val mask : Gdk.bitmap option = mask
  71   method pixmap = w
  72   method mask = mask
  73   method set_line_attributes ?width ?style ?cap ?join () =
  74     pixmap#set_line_attributes ?width ?style ?cap ?join ();
  75     may bitmap ~f:(fun m -> m#set_line_attributes ?width ?style ?cap ?join ())
  76   method point ~x ~y =
  77     pixmap#point ~x ~y;
  78     may bitmap ~f:(fun m -> m#point ~x ~y)
  79   method line ~x ~y ~x:x' ~y:y' =
  80     pixmap#line ~x ~y ~x:x' ~y:y';
  81     may bitmap ~f:(fun m -> m#line ~x ~y ~x:x' ~y:y')
  82   method rectangle ~x ~y ~width ~height ?filled () =
  83     pixmap#rectangle ~x ~y ~width ~height ?filled ();
  84     may bitmap ~f:(fun m -> m#rectangle ~x ~y ~width ~height ?filled ())
  85   method arc ~x ~y ~width ~height ?filled ?start ?angle () =
  86     pixmap#arc ~x ~y ~width ~height ?filled ?start ?angle ();
  87     may bitmap
  88       ~f:(fun m -> m#arc ~x ~y ~width ~height ?filled ?start ?angle ());
  89   method polygon ?filled l =
  90     pixmap#polygon ?filled l;
  91     may bitmap ~f:(fun m -> m#polygon ?filled l)
  92   method string s ~font ~x ~y =
  93     pixmap#string s ~font ~x ~y;
  94     may bitmap ~f:(fun m -> m#string s ~font ~x ~y)
  95 end
  96
  97 class type misc_ops = object
  98   method allocation : Gtk.rectangle
  99   method colormap : colormap
 100   method draw : Rectangle.t option -> unit
 101   method hide : unit -> unit
 102   method hide_all : unit -> unit
 103   method intersect : Rectangle.t -> Rectangle.t option
 104   method pointer : int * int
 105   method realize : unit -> unit
 106   method set_app_paintable : bool -> unit
 107   method set_geometry :
 108     ?x:int -> ?y:int -> ?width:int -> ?height:int -> unit -> unit
 109   method show : unit -> unit
 110   method unmap : unit -> unit
 111   method unparent : unit -> unit
 112   method unrealize : unit -> unit
 113   method visible : bool
 114   method visual : visual
 115   method visual_depth : int
 116   method window : window
 117 end
 118
 119 let pixmap ~(window : < misc : #misc_ops; .. >)
 120     ~width ~height ?(mask=false) () =
 121   window#misc#realize ();
 122   let window =
 123     try window#misc#window
 124     with Gpointer.Null -> failwith "GDraw.pixmap : no window"
 125   and depth = window#misc#visual_depth
 126   and colormap = window#misc#colormap in
 127   let mask =
 128     if not mask then None else
 129     let bm = Bitmap.create window ~width ~height in
 130     let mask = new drawable bm in
 131     mask#set_foreground `BLACK;
 132     mask#rectangle ~x:0 ~y:0 ~width ~height ~filled:true ();
 133     Some bm
 134   in
 135   new pixmap (Pixmap.create window ~width ~height ~depth) ~colormap ?mask
 136
 137 let pixmap_from_xpm ~window ~file ?colormap ?transparent () =
 138   window#misc#realize ();
 139   let window =
 140     try window#misc#window
 141     with Gpointer.Null -> failwith "GDraw.pixmap_from_xpm : no window" in
 142   let pm, mask =
 143     try Pixmap.create_from_xpm window ~file ?colormap
 144         ?transparent:(may_map transparent ~f:(fun c -> color c))
 145     with Gpointer.Null -> invalid_arg ("GDraw.pixmap_from_xpm : " ^ file) in
 146   new pixmap pm ?colormap ~mask
 147
 148 let pixmap_from_xpm_d ~window ~data ?colormap ?transparent () =
 149   window#misc#realize ();
 150   let window =
 151     try window#misc#window
 152     with Gpointer.Null -> failwith "GDraw.pixmap_from_xpm_d : no window" in
 153   let pm, mask =
 154     Pixmap.create_from_xpm_d window ~data ?colormap
 155       ?transparent:(may_map transparent ~f:(fun c -> color c)) in
 156   new pixmap pm ?colormap ~mask
 157
 158 class drag_context context = object
 159   val context = context
 160   method status ?(time=0) act = DnD.drag_status context act ~time
 161   method suggested_action = DnD.drag_context_suggested_action context
 162   method targets = DnD.drag_context_targets context
 163 end