--- /dev/null
+(* $Id$ *)
+
+open Gaux
+
+type colormap
+type visual
+type region
+type gc
+type 'a drawable
+type window = [`window] drawable
+type pixmap = [`pixmap] drawable
+type bitmap = [`bitmap] drawable
+type font
+type image
+type atom = int
+type keysym = int
+type 'a event
+type drag_context
+type cursor
+type xid = int32
+
+exception Error of string
+let _ = Callback.register_exception "gdkerror" (Error"")
+
+module Tags = struct
+ type event_type =
+ [ `NOTHING|`DELETE|`DESTROY|`EXPOSE|`MOTION_NOTIFY|`BUTTON_PRESS
+ |`TWO_BUTTON_PRESS|`THREE_BUTTON_PRESS
+ |`BUTTON_RELEASE|`KEY_PRESS
+ |`KEY_RELEASE|`ENTER_NOTIFY|`LEAVE_NOTIFY|`FOCUS_CHANGE
+ |`CONFIGURE|`MAP|`UNMAP|`PROPERTY_NOTIFY|`SELECTION_CLEAR
+ |`SELECTION_REQUEST|`SELECTION_NOTIFY|`PROXIMITY_IN
+ |`PROXIMITY_OUT|`DRAG_ENTER|`DRAG_LEAVE|`DRAG_MOTION|`DRAG_STATUS
+ |`DROP_START|`DROP_FINISHED|`CLIENT_EVENT|`VISIBILITY_NOTIFY
+ |`NO_EXPOSE ]
+
+ type event_mask =
+ [ `EXPOSURE
+ |`POINTER_MOTION|`POINTER_MOTION_HINT
+ |`BUTTON_MOTION|`BUTTON1_MOTION|`BUTTON2_MOTION|`BUTTON3_MOTION
+ |`BUTTON_PRESS|`BUTTON_RELEASE
+ |`KEY_PRESS|`KEY_RELEASE
+ |`ENTER_NOTIFY|`LEAVE_NOTIFY|`FOCUS_CHANGE
+ |`STRUCTURE|`PROPERTY_CHANGE|`VISIBILITY_NOTIFY
+ |`PROXIMITY_IN|`PROXIMITY_OUT|`SUBSTRUCTURE
+ |`ALL_EVENTS ]
+
+ type extension_events =
+ [ `NONE|`ALL|`CURSOR ]
+
+ type visibility_state =
+ [ `UNOBSCURED|`PARTIAL|`FULLY_OBSCURED ]
+
+ type input_source =
+ [ `MOUSE|`PEN|`ERASER|`CURSOR ]
+
+ type notify_type =
+ [ `ANCESTOR|`VIRTUAL|`INFERIOR|`NONLINEAR|`NONLINEAR_VIRTUAL|`UNKNOWN ]
+
+ type crossing_mode =
+ [ `NORMAL|`GRAB|`UNGRAB ]
+
+ type modifier =
+ [ `SHIFT|`LOCK|`CONTROL|`MOD1|`MOD2|`MOD3|`MOD4|`MOD5|`BUTTON1
+ |`BUTTON2|`BUTTON3|`BUTTON4|`BUTTON5 ]
+
+ type drag_action =
+ [ `DEFAULT|`COPY|`MOVE|`LINK|`PRIVATE|`ASK ]
+
+end
+open Tags
+
+module Convert = struct
+ external test_modifier : modifier -> int -> bool
+ = "ml_test_GdkModifier_val"
+ let modifier i =
+ List.filter [`SHIFT;`LOCK;`CONTROL;`MOD1;`MOD2;`MOD3;`MOD4;`MOD5;
+ `BUTTON1;`BUTTON2;`BUTTON3;`BUTTON4;`BUTTON5]
+ ~f:(fun m -> test_modifier m i)
+end
+
+module Screen = struct
+ external width : unit -> int = "ml_gdk_screen_width"
+ external height : unit -> int = "ml_gdk_screen_height"
+end
+
+module Visual = struct
+ type visual_type =
+ [ `STATIC_GRAY|`GRAYSCALE|`STATIC_COLOR
+ |`PSEUDO_COLOR|`TRUE_COLOR|`DIRECT_COLOR ]
+
+ external get_best : ?depth:int -> ?kind:visual_type -> unit -> visual
+ = "ml_gdk_visual_get_best"
+ external get_type : visual -> visual_type = "ml_GdkVisual_type"
+ external depth : visual -> int = "ml_GdkVisual_depth"
+ external red_mask : visual -> int = "ml_GdkVisual_red_mask"
+ external red_shift : visual -> int = "ml_GdkVisual_red_shift"
+ external red_prec : visual -> int = "ml_GdkVisual_red_prec"
+ external green_mask : visual -> int = "ml_GdkVisual_green_mask"
+ external green_shift : visual -> int = "ml_GdkVisual_green_shift"
+ external green_prec : visual -> int = "ml_GdkVisual_green_prec"
+ external blue_mask : visual -> int = "ml_GdkVisual_blue_mask"
+ external blue_shift : visual -> int = "ml_GdkVisual_blue_shift"
+ external blue_prec : visual -> int = "ml_GdkVisual_blue_prec"
+end
+
+module Image = struct
+ type image_type =
+ [ `NORMAL|`SHARED|`FASTEST ]
+
+ external create_bitmap : visual: visual -> data: string ->
+ width: int -> height: int -> image
+ = "ml_gdk_image_new_bitmap"
+ external create : kind: image_type -> visual: visual ->
+ width: int -> height: int -> image
+ = "ml_gdk_image_new"
+ external get :
+ 'a drawable -> x: int -> y: int -> width: int -> height: int -> image
+ = "ml_gdk_image_get"
+ external put_pixel : image -> x: int -> y: int -> pixel: int -> unit
+ = "ml_gdk_image_put_pixel"
+ external get_pixel : image -> x: int -> y: int -> int
+ = "ml_gdk_image_get_pixel"
+ external destroy : image -> unit
+ = "ml_gdk_image_destroy"
+end
+
+module Color = struct
+ type t
+
+ external color_white : colormap -> t = "ml_gdk_color_white"
+ external color_black : colormap -> t = "ml_gdk_color_black"
+ external color_parse : string -> t = "ml_gdk_color_parse"
+ external color_alloc : colormap -> t -> bool = "ml_gdk_color_alloc"
+ external color_create : red:int -> green:int -> blue:int -> t
+ = "ml_GdkColor"
+
+ external get_system_colormap : unit -> colormap
+ = "ml_gdk_colormap_get_system"
+ external colormap_new : visual -> privat:bool -> colormap
+ = "ml_gdk_colormap_new"
+ let get_colormap ?(privat=false) vis = colormap_new vis ~privat
+
+ type spec = [ `BLACK | `NAME of string | `RGB of int * int * int | `WHITE]
+ let color_alloc ~colormap color =
+ if not (color_alloc colormap color) then raise (Error"Color.alloc");
+ color
+ let alloc ~colormap color =
+ match color with
+ `WHITE -> color_white colormap
+ | `BLACK -> color_black colormap
+ | `NAME s -> color_alloc ~colormap (color_parse s)
+ | `RGB (red,green,blue) ->
+ color_alloc ~colormap (color_create ~red ~green ~blue)
+
+ external red : t -> int = "ml_GdkColor_red"
+ external blue : t -> int = "ml_GdkColor_blue"
+ external green : t -> int = "ml_GdkColor_green"
+ external pixel : t -> int = "ml_GdkColor_pixel"
+end
+
+module Rectangle = struct
+ type t
+ external create : x:int -> y:int -> width:int -> height:int -> t
+ = "ml_GdkRectangle"
+ external x : t -> int = "ml_GdkRectangle_x"
+ external y : t -> int = "ml_GdkRectangle_y"
+ external width : t -> int = "ml_GdkRectangle_width"
+ external height : t -> int = "ml_GdkRectangle_height"
+end
+
+module Window = struct
+ type background_pixmap = [ `NONE | `PARENT_RELATIVE | `PIXMAP of pixmap]
+ external visual_depth : visual -> int = "ml_gdk_visual_get_depth"
+ external get_visual : window -> visual = "ml_gdk_window_get_visual"
+ external get_parent : window -> window = "ml_gdk_window_get_parent"
+ external get_size : window -> int * int = "ml_gdk_window_get_size"
+ external get_position : window -> int * int =
+ "ml_gdk_window_get_position"
+ external root_parent : unit -> window = "ml_GDK_ROOT_PARENT"
+ external set_back_pixmap : window -> pixmap -> int -> unit =
+ "ml_gdk_window_set_back_pixmap"
+ external clear : window -> unit = "ml_gdk_window_clear"
+ external get_xwindow : window -> xid = "ml_GDK_WINDOW_XWINDOW"
+
+ let set_back_pixmap w pix =
+ let null_pixmap = (Obj.magic Gpointer.boxed_null : pixmap) in
+ match pix with
+ `NONE -> set_back_pixmap w null_pixmap 0
+ | `PARENT_RELATIVE -> set_back_pixmap w null_pixmap 1
+ | `PIXMAP(pixmap) -> set_back_pixmap w pixmap 0
+ (* anything OK, Maybe... *)
+end
+
+module PointArray = struct
+ type t = { len: int}
+ external create : len:int -> t = "ml_point_array_new"
+ external set : t -> pos:int -> x:int -> y:int -> unit = "ml_point_array_set"
+ let set arr ~pos =
+ if pos < 0 || pos >= arr.len then invalid_arg "PointArray.set";
+ set arr ~pos
+end
+
+module Region = struct
+ type gdkFillRule = [ `EVEN_ODD_RULE|`WINDING_RULE ]
+ type gdkOverlapType = [ `IN|`OUT|`PART ]
+ external create : unit -> region = "ml_gdk_region_new"
+ external destroy : region -> unit = "ml_gdk_region_destroy"
+ external polygon : PointArray.t -> gdkFillRule -> region
+ = "ml_gdk_region_polygon"
+ let polygon l =
+ let len = List.length l in
+ let arr = PointArray.create ~len in
+ List.fold_left l ~init:0
+ ~f:(fun pos (x,y) -> PointArray.set arr ~pos ~x ~y; pos+1);
+ polygon arr
+ external intersect : region -> region -> region
+ = "ml_gdk_regions_intersect"
+ external union : region -> region -> region
+ = "ml_gdk_regions_union"
+ external subtract : region -> region -> region
+ = "ml_gdk_regions_subtract"
+ external xor : region -> region -> region
+ = "ml_gdk_regions_xor"
+ external union_with_rect : region -> Rectangle.t -> region
+ = "ml_gdk_region_union_with_rect"
+ external offset : region -> x:int -> y:int -> unit = "ml_gdk_region_offset"
+ external shrink : region -> x:int -> y:int -> unit = "ml_gdk_region_shrink"
+ external empty : region -> bool = "ml_gdk_region_empty"
+ external equal : region -> region -> bool = "ml_gdk_region_equal"
+ external point_in : region -> x:int -> y:int -> bool
+ = "ml_gdk_region_point_in"
+ external rect_in : region -> Rectangle.t -> gdkOverlapType
+ = "ml_gdk_region_rect_in"
+ external get_clipbox : region -> Rectangle.t -> unit
+ = "ml_gdk_region_get_clipbox"
+end
+
+
+module GC = struct
+ type gdkFunction = [ `COPY|`INVERT|`XOR ]
+ type gdkFill = [ `SOLID|`TILED|`STIPPLED|`OPAQUE_STIPPLED ]
+ type gdkSubwindowMode = [ `CLIP_BY_CHILDREN|`INCLUDE_INFERIORS ]
+ type gdkLineStyle = [ `SOLID|`ON_OFF_DASH|`DOUBLE_DASH ]
+ type gdkCapStyle = [ `NOT_LAST|`BUTT|`ROUND|`PROJECTING ]
+ type gdkJoinStyle = [ `MITER|`ROUND|`BEVEL ]
+ external create : 'a drawable -> gc = "ml_gdk_gc_new"
+ external set_foreground : gc -> Color.t -> unit = "ml_gdk_gc_set_foreground"
+ external set_background : gc -> Color.t -> unit = "ml_gdk_gc_set_background"
+ external set_font : gc -> font -> unit = "ml_gdk_gc_set_font"
+ external set_function : gc -> gdkFunction -> unit = "ml_gdk_gc_set_function"
+ external set_fill : gc -> gdkFill -> unit = "ml_gdk_gc_set_fill"
+ external set_tile : gc -> pixmap -> unit = "ml_gdk_gc_set_tile"
+ external set_stipple : gc -> pixmap -> unit = "ml_gdk_gc_set_stipple"
+ external set_ts_origin : gc -> x:int -> y:int -> unit
+ = "ml_gdk_gc_set_ts_origin"
+ external set_clip_origin : gc -> x:int -> y:int -> unit
+ = "ml_gdk_gc_set_clip_origin"
+ external set_clip_mask : gc -> bitmap -> unit = "ml_gdk_gc_set_clip_mask"
+ external set_clip_rectangle : gc -> Rectangle.t -> unit
+ = "ml_gdk_gc_set_clip_rectangle"
+ external set_clip_region : gc -> region -> unit = "ml_gdk_gc_set_clip_region"
+ external set_subwindow : gc -> gdkSubwindowMode -> unit
+ = "ml_gdk_gc_set_subwindow"
+ external set_exposures : gc -> bool -> unit = "ml_gdk_gc_set_exposures"
+ external set_line_attributes :
+ gc -> width:int -> style:gdkLineStyle -> cap:gdkCapStyle ->
+ join:gdkJoinStyle -> unit
+ = "ml_gdk_gc_set_line_attributes"
+ external copy : dst:gc -> gc -> unit = "ml_gdk_gc_copy"
+ type values = {
+ foreground : Color.t;
+ background : Color.t;
+ font : font option;
+ fonction : gdkFunction;
+ fill : gdkFill;
+ tile : pixmap option;
+ stipple : pixmap option;
+ clip_mask : bitmap option;
+ subwindow_mode : gdkSubwindowMode;
+ ts_x_origin : int;
+ ts_y_origin : int;
+ clip_x_origin : int;
+ clip_y_origin : int;
+ graphics_exposures : bool;
+ line_width : int;
+ line_style : gdkLineStyle;
+ cap_style : gdkCapStyle;
+ join_style : gdkJoinStyle;
+ }
+ external get_values : gc -> values = "ml_gdk_gc_get_values"
+end
+
+module Pixmap = struct
+ external create : window -> width:int -> height:int -> depth:int -> pixmap
+ = "ml_gdk_pixmap_new"
+ external create_from_data :
+ window -> string -> width:int -> height:int -> depth:int ->
+ fg:Color.t -> bg:Color.t -> pixmap
+ = "ml_gdk_pixmap_create_from_data_bc" "ml_gk_pixmap_create_from_data"
+ external create_from_xpm :
+ window -> ?colormap:colormap -> ?transparent:Color.t ->
+ file:string -> pixmap * bitmap
+ = "ml_gdk_pixmap_colormap_create_from_xpm"
+ external create_from_xpm_d :
+ window -> ?colormap:colormap -> ?transparent:Color.t ->
+ data:string array -> pixmap * bitmap
+ = "ml_gdk_pixmap_colormap_create_from_xpm_d"
+end
+
+module Bitmap = struct
+ let create : window -> width:int -> height:int -> bitmap =
+ Obj.magic (Pixmap.create ~depth:1)
+ external create_from_data :
+ window -> string -> width:int -> height:int -> bitmap
+ = "ml_gdk_bitmap_create_from_data"
+end
+
+module Font = struct
+ external load : string -> font = "ml_gdk_font_load"
+ external load_fontset : string -> font = "ml_gdk_fontset_load"
+ external string_width : font -> string -> int = "ml_gdk_string_width"
+ external char_width : font -> char -> int = "ml_gdk_char_width"
+ external string_height : font -> string -> int = "ml_gdk_string_height"
+ external char_height : font -> char -> int = "ml_gdk_char_height"
+ external string_measure : font -> string -> int = "ml_gdk_string_measure"
+ external char_measure : font -> char -> int = "ml_gdk_char_measure"
+ external get_type : font -> [`FONT | `FONTSET] = "ml_GdkFont_type"
+ external ascent : font -> int = "ml_GdkFont_ascent"
+ external descent : font -> int = "ml_GdkFont_descent"
+end
+
+module Draw = struct
+ external point : 'a drawable -> gc -> x:int -> y:int -> unit
+ = "ml_gdk_draw_point"
+ external line : 'a drawable -> gc -> x:int -> y:int -> x:int -> y:int -> unit
+ = "ml_gdk_draw_line_bc" "ml_gdk_draw_line"
+ external rectangle :
+ 'a drawable -> gc ->
+ filled:bool -> x:int -> y:int -> width:int -> height:int -> unit
+ = "ml_gdk_draw_rectangle_bc" "ml_gdk_draw_rectangle"
+ let rectangle w gc ~x ~y ~width ~height ?(filled=false) () =
+ rectangle w gc ~x ~y ~width ~height ~filled
+ external arc :
+ 'a drawable -> gc -> filled:bool -> x:int -> y:int ->
+ width:int -> height:int -> start:int -> angle:int -> unit
+ = "ml_gdk_draw_arc_bc" "ml_gdk_draw_arc"
+ let arc w gc ~x ~y ~width ~height ?(filled=false) ?(start=0.)
+ ?(angle=360.) () =
+ arc w gc ~x ~y ~width ~height ~filled
+ ~start:(truncate(start *. 64.))
+ ~angle:(truncate(angle *. 64.))
+ external polygon : 'a drawable -> gc -> filled:bool -> PointArray.t -> unit
+ = "ml_gdk_draw_polygon"
+ let polygon w gc ?(filled=false) l =
+ let len = List.length l in
+ let arr = PointArray.create ~len in
+ List.fold_left l ~init:0
+ ~f:(fun pos (x,y) -> PointArray.set arr ~pos ~x ~y; pos+1);
+ polygon w gc ~filled arr
+ external string : 'a drawable -> font: font -> gc -> x: int -> y: int ->
+ string: string -> unit
+ = "ml_gdk_draw_string_bc" "ml_gdk_draw_string"
+ external image : 'a drawable -> gc -> image: image ->
+ xsrc: int -> ysrc: int -> xdest: int -> ydest: int ->
+ width: int -> height: int -> unit
+ = "ml_gdk_draw_image_bc" "ml_gdk_draw_image"
+end
+
+module Rgb = struct
+ external init : unit -> unit = "ml_gdk_rgb_init"
+ external get_visual : unit -> visual = "ml_gdk_rgb_get_visual"
+ external get_cmap : unit -> colormap = "ml_gdk_rgb_get_cmap"
+end
+
+module DnD = struct
+ external drag_status : drag_context -> drag_action list -> time:int -> unit
+ = "ml_gdk_drag_status"
+ external drag_context_suggested_action : drag_context -> drag_action
+ = "ml_GdkDragContext_suggested_action"
+ external drag_context_targets : drag_context -> atom list
+ = "ml_GdkDragContext_targets"
+end
+
+module Truecolor = struct
+ (* Truecolor quick color query *)
+
+ type visual_shift_prec = {
+ red_shift : int;
+ red_prec : int;
+ green_shift : int;
+ green_prec : int;
+ blue_shift : int;
+ blue_prec : int
+ }
+
+ let shift_prec visual = {
+ red_shift = Visual.red_shift visual;
+ red_prec = Visual.red_prec visual;
+ green_shift = Visual.green_shift visual;
+ green_prec = Visual.green_prec visual;
+ blue_shift = Visual.blue_shift visual;
+ blue_prec = Visual.blue_prec visual;
+ }
+
+ let color_creator visual =
+ match Visual.get_type visual with
+ `TRUE_COLOR | `DIRECT_COLOR ->
+ let shift_prec = shift_prec visual in
+ Format.eprintf "red : %d %d, "
+ shift_prec.red_shift shift_prec.red_prec;
+ Format.eprintf "green : %d %d, "
+ shift_prec.green_shift shift_prec.green_prec;
+ Format.eprintf "blue : %d %d"
+ shift_prec.blue_shift shift_prec.blue_prec;
+ Format.pp_print_newline Format.err_formatter ();
+ let red_lsr = 16 - shift_prec.red_prec
+ and green_lsr = 16 - shift_prec.green_prec
+ and blue_lsr = 16 - shift_prec.blue_prec in
+ fun ~red: red ~green: green ~blue: blue ->
+ (((red lsr red_lsr) lsl shift_prec.red_shift) lor
+ ((green lsr green_lsr) lsl shift_prec.green_shift) lor
+ ((blue lsr blue_lsr) lsl shift_prec.blue_shift))
+ | _ -> raise (Invalid_argument "Gdk.Truecolor.color_creator")
+
+ let color_parser visual =
+ match Visual.get_type visual with
+ `TRUE_COLOR | `DIRECT_COLOR ->
+ let shift_prec = shift_prec visual in
+ let red_lsr = 16 - shift_prec.red_prec
+ and green_lsr = 16 - shift_prec.green_prec
+ and blue_lsr = 16 - shift_prec.blue_prec in
+ let mask = 1 lsl 16 - 1 in
+ fun pixel ->
+ ((pixel lsr shift_prec.red_shift) lsl red_lsr) land mask,
+ ((pixel lsr shift_prec.green_shift) lsl green_lsr) land mask,
+ ((pixel lsr shift_prec.blue_shift) lsl blue_lsr) land mask
+ | _ -> raise (Invalid_argument "Gdk.Truecolor.color_parser")
+end
+
+module X = struct
+ (* X related functions *)
+ external flush : unit -> unit
+ = "ml_gdk_flush"
+ external beep : unit -> unit
+ = "ml_gdk_beep"
+end
+
+module Cursor = struct
+ type cursor_type = [
+ | `X_CURSOR
+ | `ARROW
+ | `BASED_ARROW_DOWN
+ | `BASED_ARROW_UP
+ | `BOAT
+ | `BOGOSITY
+ | `BOTTOM_LEFT_CORNER
+ | `BOTTOM_RIGHT_CORNER
+ | `BOTTOM_SIDE
+ | `BOTTOM_TEE
+ | `BOX_SPIRAL
+ | `CENTER_PTR
+ | `CIRCLE
+ | `CLOCK
+ | `COFFEE_MUG
+ | `CROSS
+ | `CROSS_REVERSE
+ | `CROSSHAIR
+ | `DIAMOND_CROSS
+ | `DOT
+ | `DOTBOX
+ | `DOUBLE_ARROW
+ | `DRAFT_LARGE
+ | `DRAFT_SMALL
+ | `DRAPED_BOX
+ | `EXCHANGE
+ | `FLEUR
+ | `GOBBLER
+ | `GUMBY
+ | `HAND1
+ | `HAND2
+ | `HEART
+ | `ICON
+ | `IRON_CROSS
+ | `LEFT_PTR
+ | `LEFT_SIDE
+ | `LEFT_TEE
+ | `LEFTBUTTON
+ | `LL_ANGLE
+ | `LR_ANGLE
+ | `MAN
+ | `MIDDLEBUTTON
+ | `MOUSE
+ | `PENCIL
+ | `PIRATE
+ | `PLUS
+ | `QUESTION_ARROW
+ | `RIGHT_PTR
+ | `RIGHT_SIDE
+ | `RIGHT_TEE
+ | `RIGHTBUTTON
+ | `RTL_LOGO
+ | `SAILBOAT
+ | `SB_DOWN_ARROW
+ | `SB_H_DOUBLE_ARROW
+ | `SB_LEFT_ARROW
+ | `SB_RIGHT_ARROW
+ | `SB_UP_ARROW
+ | `SB_V_DOUBLE_ARROW
+ | `SHUTTLE
+ | `SIZING
+ | `SPIDER
+ | `SPRAYCAN
+ | `STAR
+ | `TARGET
+ | `TCROSS
+ | `TOP_LEFT_ARROW
+ | `TOP_LEFT_CORNER
+ | `TOP_RIGHT_CORNER
+ | `TOP_SIDE
+ | `TOP_TEE
+ | `TREK
+ | `UL_ANGLE
+ | `UMBRELLA
+ | `UR_ANGLE
+ | `WATCH
+ | `XTERM
+ ]
+ external create : cursor_type -> cursor = "ml_gdk_cursor_new"
+ external create_from_pixmap :
+ pixmap -> mask:bitmap ->
+ fg:Color.t -> bg:Color.t -> x:int -> y:int -> cursor
+ = "ml_gdk_cursor_new_from_pixmap_bc" "ml_gdk_cursor_new_from_pixmap"
+ external destroy : cursor -> unit = "ml_gdk_cursor_destroy"
+end
projects / helm.git / blobdiff