Source file gdkPixbuf.ml

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
(**************************************************************************)
(*                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 Gaux
open Gobject
open Gdk

type pixbuf = [`pixbuf] obj
type colorspace = [ `RGB ]
type alpha_mode = [ `BILEVEL | `FULL ]
type interpolation = [ `NEAREST | `TILES | `BILINEAR | `HYPER ]

type gdkpixbuferror =
  | ERROR_CORRUPT_IMAGE
  | ERROR_INSUFFICIENT_MEMORY
  | ERROR_BAD_OPTION
  | ERROR_UNKNOWN_TYPE
  | ERROR_UNSUPPORTED_OPERATION
  | ERROR_FAILED
exception GdkPixbufError of gdkpixbuferror * string
external _init : unit -> unit = "ml_gdkpixbuf_init"
let () = _init () ; Callback.register_exception "gdk_pixbuf_error" (GdkPixbufError (ERROR_CORRUPT_IMAGE, ""))
external set_marshal_use_rle : bool -> unit = "ml_gdk_pixbuf_set_marshal_use_rle"

(* Accessors *)

external get_n_channels : pixbuf -> int = "ml_gdk_pixbuf_get_n_channels"
external get_has_alpha : pixbuf -> bool = "ml_gdk_pixbuf_get_has_alpha"
external get_bits_per_sample : pixbuf -> int
  = "ml_gdk_pixbuf_get_bits_per_sample"
external get_width : pixbuf -> int = "ml_gdk_pixbuf_get_width"
external get_height : pixbuf -> int = "ml_gdk_pixbuf_get_height"
external get_rowstride : pixbuf -> int = "ml_gdk_pixbuf_get_rowstride"

external _get_pixels : pixbuf -> Obj.t * int = "ml_gdk_pixbuf_get_pixels"
let get_pixels pixbuf =
  let obj, pos = _get_pixels pixbuf in
  let get_length (_, pixbuf) =
    get_rowstride pixbuf * get_height pixbuf + pos
  in
  let r =
    Gpointer.unsafe_create_region ~path:[|0|] ~get_length (obj, pixbuf) in
  Gpointer.sub ~pos r

(* Constructors *)

external _create :
  colorspace:colorspace -> has_alpha:bool ->
  bits:int -> width:int -> height:int -> pixbuf
  = "ml_gdk_pixbuf_new"
let create ~width ~height ?(bits=8) ?(colorspace=`RGB) ?(has_alpha=false) () =
  _create ~colorspace ~has_alpha ~bits ~width ~height

let cast o : pixbuf = Gobject.try_cast o "GdkPixbuf"

external copy : pixbuf -> pixbuf = "ml_gdk_pixbuf_copy" 
external subpixbuf : pixbuf -> src_x:int -> src_y:int -> width:int -> height:int -> pixbuf 
  = "ml_gdk_pixbuf_new_subpixbuf"
external from_file : string -> pixbuf = "ml_gdk_pixbuf_new_from_file"
external get_file_info : string -> string * int * int = "ml_gdk_pixbuf_get_file_info"
external from_file_at_size : string -> width:int -> height:int -> pixbuf 
  = "ml_gdk_pixbuf_new_from_file_at_size"
external from_xpm_data : string array -> pixbuf
  = "ml_gdk_pixbuf_new_from_xpm_data"

external _from_data :
  Gpointer.region -> has_alpha:bool -> bits:int ->
  width:int -> height:int -> rowstride:int -> pixbuf
  = "ml_gdk_pixbuf_new_from_data_bc" "ml_gdk_pixbuf_new_from_data"
let from_data ~width ~height ?(bits=8) ?rowstride ?(has_alpha=false) data =
  let nc = if has_alpha then 4 else 3 in
  let rowstride = match rowstride with None -> width * nc | Some r -> r in
  if bits <> 8 || rowstride < width * nc || width <= 0 || height <= 0
  || Gpointer.length data < rowstride * (height - 1) + width * nc
  then invalid_arg "GdkPixbuf.from_data";
  _from_data data ~has_alpha ~bits ~width ~height ~rowstride

(* GtkPixbuf removed in gtk3

external _get_from_drawable :
  pixbuf -> [>`drawable] obj -> colormap -> src_x:int -> src_y:int ->
  dest_x:int -> dest_y:int -> width:int -> height:int -> unit
  = "ml_gdk_pixbuf_get_from_drawable_bc" "ml_gdk_pixbuf_get_from_drawable"
let get_from_drawable ~dest ?(dest_x=0) ?(dest_y=0) ?width ?height
    ?(src_x=0) ?(src_y=0) ?(colormap=Gdk.Rgb.get_cmap()) src =
  let dw, dh = Gdk.Drawable.get_size src in
  let mw = min (dw - src_x) (get_width dest - dest_x)
  and mh = min (dh - src_y) (get_height dest - dest_y) in
  let width = default mw ~opt:width and height = default mh ~opt:height in
  if src_x < 0 || src_y < 0 || dest_x < 0 || dest_y < 0
  || width <= 0 || height <= 0 || width > mw || height > mh
  then invalid_arg "GdkPixbuf.get_from_drawable";
  _get_from_drawable dest src colormap ~src_x ~src_y ~dest_x ~dest_y
    ~width ~height

(* Render *)

external _render_alpha :
  src:pixbuf -> bitmap -> src_x:int -> src_y:int ->
  dest_x:int -> dest_y:int -> width:int -> height:int -> threshold:int -> unit
  = "ml_gdk_pixbuf_render_threshold_alpha_bc"
    "ml_gdk_pixbuf_render_threshold_alpha"
let render_alpha bm ?(dest_x=0) ?(dest_y=0) ?width ?height ?(threshold=128)
    ?(src_x=0) ?(src_y=0) src =
  let width = may_default get_width src ~opt:width
  and height = may_default get_height src ~opt:height in
  _render_alpha ~src bm ~src_x ~src_y ~dest_x ~dest_y ~width ~height ~threshold

external _draw_pixbuf :
  src:pixbuf -> [>`drawable] obj -> gc -> src_x:int -> src_y:int ->
  dest_x:int -> dest_y:int -> width:int -> height:int ->
  dither:Tags.rgb_dither -> x_dither:int -> y_dither:int -> unit
  = "ml_gdk_pixbuf_render_to_drawable_bc"
    "ml_gdk_pixbuf_render_to_drawable"
let draw_pixbuf dw gc ?(dest_x=0) ?(dest_y=0)
    ?width ?height ?(dither=`NONE) ?(x_dither=0) ?(y_dither=0)
    ?(src_x=0) ?(src_y=0) src =
  let width = may_default get_width src ~opt:width
  and height = may_default get_height src ~opt:height in
  _draw_pixbuf dw gc ~src ~src_x ~src_y ~dest_x ~dest_y ~width ~height
    ~dither ~x_dither ~y_dither

let render_to_drawable dw ?(gc=Gdk.GC.create dw) =
  draw_pixbuf dw gc

external _render_to_drawable_alpha :
  src:pixbuf -> [>`drawable] obj -> src_x:int -> src_y:int ->
  dest_x:int -> dest_y:int -> width:int -> height:int ->
  alpha:alpha_mode -> threshold:int ->
  dither:Tags.rgb_dither -> x_dither:int -> y_dither:int -> unit
  = "ml_gdk_pixbuf_render_to_drawable_alpha_bc"
    "ml_gdk_pixbuf_render_to_drawable_alpha"
let render_to_drawable_alpha dw ?(dest_x=0) ?(dest_y=0) ?width ?height
    ?(alpha=`FULL) ?(threshold=128)
    ?(dither=`NONE) ?(x_dither=0) ?(y_dither=0) ?(src_x=0) ?(src_y=0) src =
  let width = may_default get_width src ~opt:width
  and height = may_default get_height src ~opt:height in
  _render_to_drawable_alpha ~src dw ~src_x ~src_y ~dest_x ~dest_y ~width
    ~height ~dither ~x_dither ~y_dither ~alpha ~threshold

external _create_pixmap : pixbuf -> threshold:int -> pixmap * bitmap option
  = "ml_gdk_pixbuf_render_pixmap_and_mask"
let create_pixmap ?(threshold=128) pb = _create_pixmap pb ~threshold
*)

(* Transform *)

external _add_alpha : pixbuf -> subst:bool -> r:int -> g:int -> b:int -> pixbuf
  = "ml_gdk_pixbuf_add_alpha"
let add_alpha ?transparent pb =
  match transparent with None -> _add_alpha pb ~subst:false ~r:0 ~g:0 ~b:0
  | Some (r, g, b) -> _add_alpha pb ~subst:true ~r ~g ~b

external fill : pixbuf -> int32 -> unit = "ml_gdk_pixbuf_fill"
external _saturate_and_pixelate : pixbuf -> dest:pixbuf -> saturation:float -> pixelate:bool -> unit
    = "ml_gdk_pixbuf_saturate_and_pixelate"
let saturate_and_pixelate ~dest ~saturation ~pixelate src =
  _saturate_and_pixelate src ~dest ~saturation ~pixelate

external _copy_area :
  src:pixbuf -> src_x:int -> src_y:int -> width:int -> height:int ->
  dest:pixbuf -> dest_x:int -> dest_y:int -> unit
  = "ml_gdk_pixbuf_copy_area_bc" "ml_gdk_pixbuf_copy_area"
let copy_area ~dest ?(dest_x=0) ?(dest_y=0) ?width ?height
    ?(src_x=0) ?(src_y=0) src =
  let mw = min (get_width src - src_x) (get_width dest - dest_x)
  and mh = min (get_height src - src_y) (get_height dest - dest_y) in
  let width = match width with Some w -> w | None -> mw
  and height = match height with Some h -> h | None -> mh in
  if src_x < 0 || src_y < 0 || dest_x < 0 || dest_y < 0
  || width <= 0 || height <= 0 || width > mw || height > mh
  then invalid_arg "GdkPixbuf.copy_area";
  _copy_area ~src ~src_x ~src_y ~width ~height ~dest ~dest_x ~dest_y

let get_size sz sc ~ssrc ~sdest ~dest ~ofs =
  match sz, sc with
    None, None    -> (sdest - dest, (float dest +. ofs) /. float ssrc)
  | None, Some sc -> (truncate(float ssrc *. sc -. ofs), sc)
  | Some sz, None -> (sz, (float sz +. ofs) /. float ssrc)
  | Some sz, Some sc -> (sz, sc)

external _scale :
  src:pixbuf -> dest:pixbuf -> dest_x:int -> dest_y:int -> width:int ->
  height:int -> ofs_x:float -> ofs_y:float -> scale_x:float ->
  scale_y:float -> interp:interpolation -> unit
  = "ml_gdk_pixbuf_scale_bc" "ml_gdk_pixbuf_scale"
let scale ~dest ?(dest_x=0) ?(dest_y=0) ?width ?height ?(ofs_x=0.) ?(ofs_y=0.)
    ?scale_x ?scale_y ?(interp=`BILINEAR) src =
  let width, scale_x =
    get_size width scale_x ~ssrc:(get_width src)
      ~sdest:(get_width dest) ~dest:dest_x ~ofs:ofs_x
  and height, scale_y =
    get_size height scale_y ~ssrc:(get_height src)
      ~sdest:(get_height dest) ~dest:dest_y ~ofs:ofs_y
  in
  _scale ~src ~dest ~dest_x ~dest_y ~width ~height ~ofs_x ~ofs_y ~scale_x
    ~scale_y ~interp

external _composite :
  src:pixbuf -> dest:pixbuf -> dest_x:int -> dest_y:int -> width:int ->
  height:int -> ofs_x:float -> ofs_y:float -> scale_x:float ->
  scale_y:float -> interp:interpolation -> alpha:int -> unit
  = "ml_gdk_pixbuf_composite_bc" "ml_gdk_pixbuf_composite"
let composite ~dest ~alpha ?(dest_x=0) ?(dest_y=0) ?width ?height
    ?(ofs_x=0.) ?(ofs_y=0.) ?scale_x ?scale_y ?(interp=`BILINEAR) src =
  let width, scale_x =
    get_size width scale_x ~ssrc:(get_width src)
      ~sdest:(get_width dest) ~dest:dest_x ~ofs:ofs_x
  and height, scale_y =
    get_size height scale_y ~ssrc:(get_height src)
      ~sdest:(get_height dest) ~dest:dest_y ~ofs:ofs_y
  in
  _composite ~src ~dest ~dest_x ~dest_y ~width ~height ~ofs_x ~ofs_y ~scale_x
    ~scale_y ~interp ~alpha

(* Saving *)

external save : filename:string -> typ:string -> ?options:(string * string) list -> pixbuf -> unit
    = "ml_gdk_pixbuf_save"

external save_to_callback : 
  pixbuf -> typ:string -> ?options:(string * string) list -> 
  (string -> unit) -> unit = "ml_gdk_pixbuf_save_to_callback"

let save_to_buffer pb ~typ ?options buffer =
  save_to_callback pb ~typ ?options (Buffer.add_string buffer)