X-Git-Url: http://matita.cs.unibo.it/gitweb/?p=helm.git;a=blobdiff_plain;f=helm%2FDEVEL%2Flablgtk%2Flablgtk_20001129-0.1.0%2FgDraw.ml;fp=helm%2FDEVEL%2Flablgtk%2Flablgtk_20001129-0.1.0%2FgDraw.ml;h=0000000000000000000000000000000000000000;hp=5782079a0d748b29a709a4c5719738a247d8ea30;hb=869549224eef6278a48c16ae27dd786376082b38;hpb=89262281b6e83bd2321150f81f1a0583645eb0c8 diff --git a/helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/gDraw.ml b/helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/gDraw.ml deleted file mode 100644 index 5782079a0..000000000 --- a/helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/gDraw.ml +++ /dev/null @@ -1,163 +0,0 @@ -(* $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