This file is indexed.

/usr/lib/ocaml/lablgtk2/gdk.ml is in liblablgtk2-ocaml-dev 2.16.0+dfsg-1.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
(**************************************************************************)
(*                Lablgtk                                                 *)
(*                                                                        *)
(*    This program is free software; you can redistribute it              *)
(*    and/or modify it under the terms of the GNU Library General         *)
(*    Public License as published by the Free Software Foundation         *)
(*    version 2, with the exception described in file COPYING which       *)
(*    comes with the library.                                             *)
(*                                                                        *)
(*    This program is distributed in the hope that it will be useful,     *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of      *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the       *)
(*    GNU Library General Public License for more details.                *)
(*                                                                        *)
(*    You should have received a copy of the GNU Library General          *)
(*    Public License along with this program; if not, write to the        *)
(*    Free Software Foundation, Inc., 59 Temple Place, Suite 330,         *)
(*    Boston, MA 02111-1307  USA                                          *)
(*                                                                        *)
(*                                                                        *)
(**************************************************************************)

(* $Id$ *)

open StdLabels
open Gaux
open Gobject

type color
type colormap
type visual
type screen = [`gdkscreen] obj
type region
type gc
type window = [`drawable|`gdkwindow] obj
type pixmap = [`drawable|`gdkpixmap] obj
type bitmap = [`drawable|`gdkpixmap|`gdkbitmap] obj
type font
type image = [`gdkimage] obj
type atom
type keysym = int
type +'a event
type drag_context = [`dragcontext] Gobject.obj
type cursor
type xid = int32
type device
type display

exception Error of string
let _ = Callback.register_exception "gdkerror" (Error"")

external _gdk_init : unit -> unit = "ml_gdk_init"
let () = _gdk_init ()

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 | `SCROLL | `WINDOW_STATE | `SETTING ]

  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 | `SCROLL
    | `ALL_EVENTS ]

  type extension_mode =
    [ `NONE | `ALL | `CURSOR ]

  type visibility_state =
    [ `UNOBSCURED | `PARTIAL | `FULLY_OBSCURED ]

  type input_source =
    [ `MOUSE | `PEN | `ERASER | `CURSOR ]

  type scroll_direction =
    [ `UP | `DOWN | `LEFT | `RIGHT ]

  type notify_type =
    [ `ANCESTOR | `VIRTUAL | `INFERIOR | `NONLINEAR
    | `NONLINEAR_VIRTUAL | `UNKNOWN ] 

  type crossing_mode = [ `NORMAL | `GRAB | `UNGRAB ]

  type setting_action = [ `NEW | `CHANGED | `DELETED ]

  type window_state =
    [ `WITHDRAWN | `ICONIFIED | `MAXIMIZED | `STICKY ]

  type modifier =
    [ `SHIFT | `LOCK | `CONTROL | `MOD1 | `MOD2 | `MOD3 | `MOD4 | `MOD5
    | `BUTTON1 | `BUTTON2 | `BUTTON3 | `BUTTON4 | `BUTTON5 | `SUPER
    | `HYPER | `META | `RELEASE ]

  type drag_action =
    [ `DEFAULT | `COPY | `MOVE | `LINK | `PRIVATE | `ASK ]

  type rgb_dither = 
    [ `NONE | `NORMAL | `MAX]

  type property_state = [ `NEW_VALUE | `DELETE ]

  type property_mode = [ `REPLACE | `PREPEND | `APPEND ]

  type xdata =
    [ `BYTES of string
    | `SHORTS of int array
    | `INT32S of int32 array ]

  type xdata_ret = [ xdata | `NONE ]

  type gravity =
    [ `NORTH_WEST | `NORTH | `NORTH_EAST | `WEST | `CENTER | `EAST
    | `SOUTH_WEST | `SOUTH | `SOUTH_EAST | `STATIC ]

  type window_type_hint =
    [ `NORMAL | `DIALOG | `MENU | `TOOLBAR | `SPLASHSCREEN | `UTILITY
    | `DOCK | `DESKTOP ]
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)
  external test_window_state : window_state -> int -> bool
      = "ml_test_GdkWindowState_val"
  let window_state i =
    List.filter [ `WITHDRAWN; `ICONIFIED; `MAXIMIZED; `STICKY ]
      ~f:(fun m -> test_window_state m i)
end

module Atom = struct
  external intern : string -> bool -> atom = "ml_gdk_atom_intern"
  let intern ?(dont_create=false) name = intern name dont_create
  external name : atom -> string = "ml_gdk_atom_name"
  let none = intern "NONE"
  let primary = intern "PRIMARY"
  let secondary = intern "SECONDARY"
  let clipboard = intern "CLIPBOARD"
  let string = intern "STRING"
end

module Property = struct
  external change :
      window ->
      property:atom -> typ:atom -> mode:property_mode -> xdata -> unit
      = "ml_gdk_property_change"
  let change ~window ~typ ?(mode=`REPLACE) property data =
    change window ~property ~typ ~mode data
  external get :
      window -> property:atom ->
      max_length:int -> delete:bool -> (atom * xdata) option
      = "ml_gdk_property_get"
  let get ~window ?(max_length=65000) ?(delete=false) property =
    get window ~property ~max_length ~delete
  external delete : window:window -> atom -> unit
      = "ml_gdk_property_delete"
end

module Screen = struct
  external get_width : screen -> int = "ml_gdk_screen_get_width"
  external width : unit -> int = "ml_gdk_screen_width"
  let width ?screen () =
    match screen with None -> width () | Some s -> get_width s
  external get_height : screen -> int = "ml_gdk_screen_get_height"
  external height : unit -> int = "ml_gdk_screen_height"
  let height ?screen () =
    match screen with None -> height () | Some s -> get_height s
  external get_pango_context_for : screen -> Pango.context =
    "ml_gdk_pango_context_get_for_screen"
  external get_pango_context : unit -> Pango.context =
    "ml_gdk_pango_context_get"
  let get_pango_context ?screen () =
    match screen with None -> get_pango_context ()
    | Some s -> get_pango_context_for s

  (* Only with Gtk-2.2 *)
  external default : unit -> screen = "ml_gdk_screen_get_default"
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 ]

  let cast w : image = Gobject.try_cast w "GdkImage"
  let destroy = Gobject.unsafe_unref

  external create : kind: image_type -> visual: visual -> 
    width: int -> height: int -> image
      = "ml_gdk_image_new"
  external get :
      [>`drawable] obj -> x: int -> y: int -> width: int -> height: int -> image
      = "ml_gdk_drawable_get_image"
  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 width : image -> int = "ml_gdk_image_width"
  external height : image -> int = "ml_gdk_image_height"
  external depth : image -> int = "ml_gdk_image_depth"
  external get_visual : image -> visual = "ml_gdk_image_visual"
end

module Color = struct
  external color_white : colormap -> color = "ml_gdk_color_white"
  external color_black : colormap -> color = "ml_gdk_color_black"
  external color_parse : string -> color = "ml_gdk_color_parse"
  external color_alloc : colormap -> color -> bool = "ml_gdk_color_alloc"
  external color_create : red:int -> green:int -> blue:int -> color
      = "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
  external get_visual : colormap -> visual
      = "ml_gdk_colormap_get_visual"

  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 : color -> int = "ml_GdkColor_red"
  external blue : color -> int = "ml_GdkColor_blue"
  external green : color -> int = "ml_GdkColor_green"
  external pixel : color -> 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 Drawable = struct
  let cast w : [`drawable] obj = Gobject.try_cast w "GdkDrawable"
  external get_visual : [>`drawable] obj -> visual
    = "ml_gdk_drawable_get_visual"
  external get_depth : [>`drawable] obj -> int
    = "ml_gdk_drawable_get_depth"
  external get_colormap : [>`drawable] obj -> colormap
    = "ml_gdk_drawable_get_colormap"
  external get_size : [>`drawable] obj -> int * int
    = "ml_gdk_drawable_get_size"
end

module Window = struct
  let cast w : window = Gobject.try_cast w "GdkWindow"
  type background_pixmap = [ `NONE | `PARENT_RELATIVE | `PIXMAP of pixmap]
  external get_parent : window -> window = "ml_gdk_window_get_parent"
  external get_position : window -> int * int = "ml_gdk_window_get_position"
  external get_pointer_location : window -> int * int =
    "ml_gdk_window_get_pointer_location"
  external root_parent : unit -> window = "ml_GDK_ROOT_PARENT"
  external set_back_pixmap : window -> pixmap -> int -> unit = 
    "ml_gdk_window_set_back_pixmap"
  external set_cursor : window -> cursor -> unit = 
    "ml_gdk_window_set_cursor"
  external clear : window -> unit = "ml_gdk_window_clear"
  external clear_area :
    window -> x:int -> y:int -> width:int -> height:int -> unit
    = "ml_gdk_window_clear"
  external get_xwindow : [>`drawable] obj -> 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... *) 

  (* for backward compatibility for lablgtk1 programs *)	  
  let get_visual = Drawable.get_visual
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 SegmentArray = struct
  type t = { len: int}
  external create : len:int -> t = "ml_segment_array_new"
  external set : t -> pos:int -> x1:int -> y1:int -> x2:int -> y2: int -> unit = "ml_segment_array_set_bc" "ml_segment_array_set"
  let set arr ~pos =
    if pos < 0 || pos >= arr.len then invalid_arg "SegmentArray.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 copy : region -> region
      = "ml_gdk_region_copy"
  external intersect : region -> region -> region
      = "ml_gdk_region_intersect"
  external union : region -> region -> region 
      = "ml_gdk_region_union"
  external subtract : region -> region -> region 
      = "ml_gdk_region_subtract"
  external xor : region -> region -> region 
      = "ml_gdk_region_xor"
  external union_with_rect : region -> Rectangle.t -> region
      = "ml_gdk_region_union_with_rect"
  let intersect r1 r2 = let r3 = copy r1 in intersect r3 r2; r3
  let union r1 r2 = let r3 = copy r1 in union r3 r2; r3
  let subtract r1 r2 = let r3 = copy r1 in subtract r3 r2; r3
  let xor r1 r2 = let r3 = copy r1 in xor r3 r2; r3
  let union_with_rect r1 r2 = let r3 = copy r1 in union_with_rect r3 r2; r3
  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 : [>`drawable] obj -> gc = "ml_gdk_gc_new"
  external set_foreground : gc -> color -> unit = "ml_gdk_gc_set_foreground"
  external set_background : gc -> color -> 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 set_dashes : gc -> offset:int -> int list -> unit =
    "ml_gdk_gc_set_dashes"
  external copy : dst:gc -> gc -> unit = "ml_gdk_gc_copy"
  type values = {
      foreground : color;
      background : color;
      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
  let cast w : pixmap = Gobject.try_cast w "GdkPixmap"
  let destroy = Gobject.unsafe_unref
  open Gpointer
  external create :
      window optboxed -> width:int -> height:int -> depth:int -> pixmap
      = "ml_gdk_pixmap_new"
  let create ?window ~width ~height ?(depth = -1) () =
    try create (optboxed window) ~width ~height ~depth
    with _ -> failwith "Gdk.Pixmap.create"
  external create_from_data :
      window optboxed -> string -> width:int -> height:int -> depth:int ->
      fg:color -> bg:color -> pixmap
      = "ml_gdk_pixmap_create_from_data_bc" "ml_gdk_pixmap_create_from_data"
  let create_from_data ?window ~width ~height ?(depth = -1) ~fg ~bg data =
    try create_from_data (optboxed window) data ~width ~height ~depth ~fg ~bg
    with _ -> failwith "Gdk.Pixmap.create_from_data"
  external create_from_xpm :
      ?window:window -> ?colormap:colormap -> ?transparent:color ->
      file:string -> unit -> pixmap * bitmap
      = "ml_gdk_pixmap_colormap_create_from_xpm"
  external create_from_xpm_d :
      ?window:window -> ?colormap:colormap -> ?transparent:color ->
      data:string array -> unit -> pixmap * bitmap
      = "ml_gdk_pixmap_colormap_create_from_xpm_d"
end

module Bitmap = struct
  let cast w : bitmap =
    let w = Gobject.try_cast w "GdkPixmap" in
    if Drawable.get_depth w <> 1 then
      raise (Gobject.Cannot_cast("GdkPixmap","GdkBitmap"));
    w
  open Gpointer
  let create ?window ~width ~height () : bitmap =
    Gobject.unsafe_cast (Pixmap.create ?window ~width ~height ~depth:1 ())
  external create_from_data :
      window optboxed -> string -> width:int -> height:int -> bitmap
      = "ml_gdk_bitmap_create_from_data"
  let create_from_data ?window ~width ~height data =
    try create_from_data (optboxed window) data ~width ~height
    with _ -> failwith "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 : [>`drawable] obj -> gc -> x:int -> y:int -> unit
      = "ml_gdk_draw_point"
  external line :
      [>`drawable] obj -> gc -> x:int -> y:int -> x:int -> y:int -> unit
      = "ml_gdk_draw_line_bc" "ml_gdk_draw_line"
  external rectangle :
      [>`drawable] obj -> 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 :
      [>`drawable] obj -> 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.))

  let f_pointarray f l = 
    let array_of_points 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);
      arr
    in
    f (array_of_points l)

  let f_segmentarray f l = 
    let array_of_segments l =
      let len = List.length l in
      let arr = SegmentArray.create ~len in
      List.fold_left l ~init:0
      	~f:(fun pos ((x1,y1),(x2,y2)) -> 
	  SegmentArray.set arr ~pos ~x1 ~y1 ~x2 ~y2; pos+1);
      arr
    in
    f (array_of_segments l)

  external polygon :
    [>`drawable] obj -> gc -> filled:bool -> PointArray.t -> unit
    = "ml_gdk_draw_polygon"
  let polygon w gc ?(filled=false) = function
    | [] -> ()
    | l -> f_pointarray (polygon w gc ~filled) l
  external string :
    [>`drawable] obj -> font: font -> gc -> x: int -> y: int -> string -> unit
    = "ml_gdk_draw_string_bc" "ml_gdk_draw_string"	
  external layout :
    [>`drawable] obj -> gc -> x: int -> y: int -> Pango.layout ->
    ?fore:color -> ?back:color -> unit
    = "ml_gdk_draw_layout_with_colors_bc" "ml_gdk_draw_layout_with_colors"
  external image_ : [>`drawable] obj -> gc -> image -> 
    xsrc: int -> ysrc: int -> xdest: int -> ydest: int -> 
    width: int -> height: int -> unit
    = "ml_gdk_draw_image_bc" "ml_gdk_draw_image"
  let image w gc ?(xsrc=0) ?(ysrc=0) ?(xdest=0) ?(ydest=0)
      ?(width= -1) ?(height= -1) image =
    image_ w gc image ~xsrc ~ysrc ~xdest ~ydest ~width ~height
(*
  external bitmap : [>`drawable] obj -> gc -> bitmap: bitmap -> 
    xsrc: int -> ysrc: int -> xdest: int -> ydest: int -> 
    width: int -> height: int -> unit
      = "ml_gdk_draw_bitmap_bc" "ml_gdk_draw_bitmap"
*)
  external pixmap_ : [>`drawable] obj -> gc -> pixmap -> 
    xsrc: int -> ysrc: int -> xdest: int -> ydest: int -> 
    width: int -> height: int -> unit
    = "ml_gdk_draw_pixmap_bc" "ml_gdk_draw_pixmap"
  let pixmap w gc ?(xsrc=0) ?(ysrc=0) ?(xdest=0) ?(ydest=0)
      ?(width= -1) ?(height= -1) pixmap =
    pixmap_ w gc pixmap ~xsrc ~ysrc ~xdest ~ydest ~width ~height

  external points : [>`drawable] obj -> gc -> PointArray.t -> unit
      = "ml_gdk_draw_points"
  let points w gc l = f_pointarray (points w gc) l
  external lines : [>`drawable] obj -> gc -> PointArray.t -> unit
      = "ml_gdk_draw_lines"
  let lines w gc l = f_pointarray (lines w gc) l
  external segments : [>`drawable] obj -> gc -> SegmentArray.t -> unit
      = "ml_gdk_draw_segments"
  let segments w gc = function
    | [] -> ()
    | l -> f_segmentarray (segments w gc) l
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"
  external draw_image_ :
    [>`drawable] obj -> gc -> x:int -> y:int -> width:int -> height:int ->
    dither:rgb_dither -> buf:Gpointer.region -> row_stride:int -> unit
    = "ml_gdk_draw_rgb_image_bc" "ml_gdk_draw_rgb_image"
  let draw_image w gc ~width ~height ?(x=0) ?(y=0) ?(dither=`NORMAL)
    ?(row_stride=width*3) buf =
    if height <= 0 || width <= 0 || row_stride < width * 3
    || Gpointer.length buf < row_stride * (height - 1) + width
    then invalid_arg "Gdk.Rgb.draw_image";
    draw_image_ w gc ~x ~y ~width ~height ~dither ~buf ~row_stride
end

module DnD = struct
  external drag_status : drag_context -> drag_action option -> time:int32 -> 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 -> bg:color -> x:int -> y:int -> cursor
    = "ml_gdk_cursor_new_from_pixmap_bc" "ml_gdk_cursor_new_from_pixmap"
  external create_from_pixbuf :
    [`pixbuf] obj -> x:int -> y:int -> cursor
    = "ml_gdk_cursor_new_from_pixbuf" (** @since GTK 2.4 *)
  external get_image : cursor -> [`pixbuf] obj
    = "ml_gdk_cursor_get_image"       (** @since GTK 2.8 *)
end

module Display = struct
    (* since Gtk+-2.2 *)

  external default :
    unit -> display
    = "ml_gdk_display_get_default"
  external get_window_at_pointer :
    display -> (window * int * int) option
    = "ml_gdk_display_get_window_at_pointer"
  let window_at_pointer ?display () =
    get_window_at_pointer
      (match display with None -> default ()
      | Some disp -> disp)
end

module Windowing = struct
  external get : unit -> [`QUARTZ | `WIN32 | `X11] = "ml_gdk_get_platform"
  let platform = get ()
end