+++ /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