+++ /dev/null
-(* $Id$ *)
-
-open Gaux
-open Gdk
-
-type color = [
- | `COLOR of Color.t
- | `WHITE
- | `BLACK
- | `NAME of string
- | `RGB of int * int * int
-]
-
-let default_colormap = GtkBase.Widget.get_default_colormap
-
-let color ?(colormap = default_colormap ()) (c : color) =
- match c with
- | `COLOR col -> col
- | #Gdk.Color.spec as def -> Color.alloc ~colormap def
-
-type optcolor = [
- | `COLOR of Color.t
- | `WHITE
- | `BLACK
- | `NAME of string
- | `RGB of int * int * int
- | `DEFAULT
-]
-
-let optcolor ?colormap (c : optcolor) =
- match c with
- | `DEFAULT -> None
- | #color as c -> Some (color ?colormap c)
-
-class ['a] drawable ?(colormap = default_colormap ()) w =
-object (self)
- val colormap = colormap
- val gc = GC.create w
- val w : 'a Gdk.drawable = w
- method color = color ~colormap
- method set_foreground col = GC.set_foreground gc (self#color col)
- method set_background col = GC.set_background gc (self#color col)
- method gc_values = GC.get_values gc
- method set_clip_region region = GC.set_clip_region gc region
- method set_line_attributes ?width ?style ?cap ?join () =
- let v = GC.get_values gc in
- GC.set_line_attributes gc
- ~width:(default v.GC.line_width ~opt:width)
- ~style:(default v.GC.line_style ~opt:style)
- ~cap:(default v.GC.cap_style ~opt:cap)
- ~join:(default v.GC.join_style ~opt:join)
- method point = Draw.point w gc
- method line = Draw.line w gc
- method rectangle = Draw.rectangle w gc
- method arc = Draw.arc w gc
- method polygon ?filled l = Draw.polygon w gc ?filled l
- method string s = Draw.string w gc ~string:s
- method image ~width ~height ?(xsrc=0) ?(ysrc=0) ?(xdest=0) ?(ydest=0) image =
- Draw.image w gc ~image ~width ~height ~xsrc ~ysrc ~xdest ~ydest
-end
-
-class pixmap ?colormap ?mask pm = object
- inherit [[`pixmap]] drawable ?colormap pm as pixmap
- val bitmap = may_map mask ~f:
- begin fun x ->
- let mask = new drawable x in
- mask#set_foreground `WHITE;
- mask
- end
- val mask : Gdk.bitmap option = mask
- method pixmap = w
- method mask = mask
- method set_line_attributes ?width ?style ?cap ?join () =
- pixmap#set_line_attributes ?width ?style ?cap ?join ();
- may bitmap ~f:(fun m -> m#set_line_attributes ?width ?style ?cap ?join ())
- method point ~x ~y =
- pixmap#point ~x ~y;
- may bitmap ~f:(fun m -> m#point ~x ~y)
- method line ~x ~y ~x:x' ~y:y' =
- pixmap#line ~x ~y ~x:x' ~y:y';
- may bitmap ~f:(fun m -> m#line ~x ~y ~x:x' ~y:y')
- method rectangle ~x ~y ~width ~height ?filled () =
- pixmap#rectangle ~x ~y ~width ~height ?filled ();
- may bitmap ~f:(fun m -> m#rectangle ~x ~y ~width ~height ?filled ())
- method arc ~x ~y ~width ~height ?filled ?start ?angle () =
- pixmap#arc ~x ~y ~width ~height ?filled ?start ?angle ();
- may bitmap
- ~f:(fun m -> m#arc ~x ~y ~width ~height ?filled ?start ?angle ());
- method polygon ?filled l =
- pixmap#polygon ?filled l;
- may bitmap ~f:(fun m -> m#polygon ?filled l)
- method string s ~font ~x ~y =
- pixmap#string s ~font ~x ~y;
- may bitmap ~f:(fun m -> m#string s ~font ~x ~y)
-end
-
-class type misc_ops = object
- method allocation : Gtk.rectangle
- method colormap : colormap
- method draw : Rectangle.t option -> unit
- method hide : unit -> unit
- method hide_all : unit -> unit
- method intersect : Rectangle.t -> Rectangle.t option
- method pointer : int * int
- method realize : unit -> unit
- method set_app_paintable : bool -> unit
- method set_geometry :
- ?x:int -> ?y:int -> ?width:int -> ?height:int -> unit -> unit
- method show : unit -> unit
- method unmap : unit -> unit
- method unparent : unit -> unit
- method unrealize : unit -> unit
- method visible : bool
- method visual : visual
- method visual_depth : int
- method window : window
-end
-
-let pixmap ~(window : < misc : #misc_ops; .. >)
- ~width ~height ?(mask=false) () =
- window#misc#realize ();
- let window =
- try window#misc#window
- with Gpointer.Null -> failwith "GDraw.pixmap : no window"
- and depth = window#misc#visual_depth
- and colormap = window#misc#colormap in
- let mask =
- if not mask then None else
- let bm = Bitmap.create window ~width ~height in
- let mask = new drawable bm in
- mask#set_foreground `BLACK;
- mask#rectangle ~x:0 ~y:0 ~width ~height ~filled:true ();
- Some bm
- in
- new pixmap (Pixmap.create window ~width ~height ~depth) ~colormap ?mask
-
-let pixmap_from_xpm ~window ~file ?colormap ?transparent () =
- window#misc#realize ();
- let window =
- try window#misc#window
- with Gpointer.Null -> failwith "GDraw.pixmap_from_xpm : no window" in
- let pm, mask =
- try Pixmap.create_from_xpm window ~file ?colormap
- ?transparent:(may_map transparent ~f:(fun c -> color c))
- with Gpointer.Null -> invalid_arg ("GDraw.pixmap_from_xpm : " ^ file) in
- new pixmap pm ?colormap ~mask
-
-let pixmap_from_xpm_d ~window ~data ?colormap ?transparent () =
- window#misc#realize ();
- let window =
- try window#misc#window
- with Gpointer.Null -> failwith "GDraw.pixmap_from_xpm_d : no window" in
- let pm, mask =
- Pixmap.create_from_xpm_d window ~data ?colormap
- ?transparent:(may_map transparent ~f:(fun c -> color c)) in
- new pixmap pm ?colormap ~mask
-
-class drag_context context = object
- val context = context
- method status ?(time=0) act = DnD.drag_status context act ~time
- method suggested_action = DnD.drag_context_suggested_action context
- method targets = DnD.drag_context_targets context
-end
projects / helm.git / blobdiff