]> matita.cs.unibo.it Git - helm.git/blob - helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/gDraw.ml
SQL quoting fixed in relation.ml
[helm.git] / helm / DEVEL / lablgtk / lablgtk_20000829-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