File: gd.ml

package info (click to toggle)
gd4o 1.0~alpha5-9
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, sid
  • size: 1,212 kB
  • sloc: xml: 1,618; ml: 1,136; ansic: 781; makefile: 85
file content (650 lines) | stat: -rw-r--r-- 23,813 bytes parent folder | download | duplicates (3)
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
(* $Header: /home/cvs/gd4o/gd.ml,v 1.6 2003/11/25 01:02:32 matt Exp $ *)
(*
 * GD4O: An OCaml interface to the Gd graphics library.
 * Based on Shawn Wagner's OCamlGD 0.7.0.
 * Copyright (C) 2002  Shawn Wagner
 * Copyright (C) 2003  Matthew C. Gushee
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 *)


exception Too_many_colors
exception Color_not_found
exception Image_creation_failed 
exception Not_supported
exception Illegal_state of string
exception GD_Freetype_exception of string

let _ = Callback.register_exception "gdopen failed" Image_creation_failed
let _ = Callback.register_exception "gd type not supported" Not_supported
let _ = Callback.register_exception "gd freetype exception" (GD_Freetype_exception "msg")

type t (* Image type *)
type c = int (* Color type *)
type font (* Font type *)

type ftex_flag =
  | FTExSetSpacing
  | FTExSetCharmap
type ftex_charmap =
  | FTExUnicode
  | FTExShiftJIS
  | FTExBig5

(*
class virtual color =
object
  method virtual red_part: int
  method virtual green_part: int
  method virtual blue_part: int
  method virtual code: int
  method virtual antialiased: color
  method virtual is_aa: bool
end
*)
type color = {
  red_channel : int;
  green_channel : int;
  blue_channel : int;
  alpha_channel : int;
  index : int;
}

class virtual color_allocator =
  object
    method virtual create: red:int -> green:int -> blue:int -> color
    method virtual closest: red:int -> green:int -> blue:int -> color
    method virtual closest_hwb: red:int -> green:int -> blue:int -> color
    method virtual resolve: red:int -> green:int -> blue:int -> color
    method virtual exact: red:int -> green:int -> blue:int -> color
    method virtual find: red:int -> green:int -> blue:int -> color
    method virtual get_color_by_index: int -> color
    method virtual white: color
    method virtual black: color
    method virtual blue: color
    method virtual green: color
    method virtual red: color
    method virtual get_transparent: color
    method virtual set_transparent: color -> unit
    method virtual set_antialiased: bool -> unit
    method virtual set_brushed: bool -> unit
    method virtual set_styled: bool -> unit
    method virtual set_tiled: bool -> unit
    method virtual antialiased: unit -> int
    method virtual brushed: unit -> int
    method virtual styled: unit -> int
    method virtual styled_brushed: unit -> int
    method virtual tiled: unit -> int
    method virtual transparent: unit -> int
  end

class virtual image =
  object
    method virtual get_image: t
    method virtual colors: color_allocator
    method virtual line: x1:int -> y1:int -> x2:int -> y2:int -> 
        ?pseudo:int -> color -> unit
    method virtual dashed_line: x1:int -> y1:int -> x2:int -> y2:int -> 
        ?pseudo:int -> color -> unit
    method virtual rectangle: x1:int -> y1:int -> x2:int -> y2:int -> 
        ?pseudo:int -> color -> unit
    method virtual filled_rectangle: x1:int -> y1:int -> x2:int -> y2:int -> 
        ?pseudo:int -> color -> unit
    method virtual polygon: pts:(int * int) array -> ?pseudo:int -> 
        color -> unit
    method virtual filled_polygon: pts:(int * int) array -> ?pseudo:int -> 
        color -> unit
    method virtual arc: cx:int -> cy:int -> w:int -> h:int -> s:int -> 
        e:int -> ?pseudo:int -> color -> unit
    method virtual closed_arc:
        cx:int -> cy:int -> w:int -> h:int -> s:int -> e:int ->
        ?nofill:bool -> ?edged:bool -> ?pseudo:int -> color -> unit
    method virtual closed_chord:
        cx:int -> cy:int -> w:int -> h:int -> s:int -> e:int ->
        ?nofill:bool -> ?edged:bool -> ?pseudo:int -> color -> unit 
    method virtual filled_ellipse: cx:int -> cy:int -> w:int -> h:int -> 
        ?pseudo:int -> color -> unit
    method virtual border_fill: x:int -> y:int -> border:color -> 
        fill:color -> unit
    method virtual fill: x:int -> y:int -> color -> unit
    method virtual set_antialiased: color -> unit
    method virtual set_antialiased_dont_blend: 
      aacolor:color -> dontblend:color -> unit
    method virtual set_brush: image -> unit
    method virtual set_tile: image -> unit
    method virtual set_thickness: int -> unit
    method virtual set_clip: x1:int -> y1:int -> x2:int -> y2:int -> unit
    method virtual save_as_png: string -> unit
    method virtual save_as_jpeg: ?quality:int -> string -> unit
    method virtual out_as_png: out_channel -> unit
    method virtual out_as_jpeg: ?quality:int -> out_channel -> unit
    method virtual set_pixel: x:int -> y:int -> color -> unit
    method virtual get_pixel: x:int -> y:int -> color
    method virtual width: int
    method virtual height: int
    method virtual in_range: x:int -> y:int -> bool
    method virtual letter: font:font -> x:int -> y:int -> c:char ->
      color -> unit
    method virtual letter_up: font:font -> x:int -> y:int -> c:char -> 
      color -> unit
    method virtual string: font:font -> x:int -> y:int -> s:string -> 
      color -> unit
    method virtual string_up: font:font -> x:int -> y:int -> s:string -> 
      color -> unit
    method virtual string_ft:
      fg:color -> fname:string -> size:float -> angle:float -> 
      x:int -> y:int -> string -> int array
    method virtual string_ftex:
      fg:color -> fname:string -> size:float -> angle:float -> 
      x:int -> y:int -> ?flags:ftex_flag array -> ?spacing:float -> 
      ?charmap:ftex_charmap -> string -> int array
    method virtual copy: image -> x:int -> y:int -> src_x:int -> src_y:int ->
      w:int -> h:int -> unit
    method virtual copy_resized: image -> x:int -> y:int -> src_x:int -> 
      src_y:int -> w:int -> h:int -> src_w:int -> src_h:int -> unit
    method virtual copy_resampled: image -> x:int -> y:int -> src_x:int -> 
      src_y:int -> w:int -> h:int -> src_w:int -> src_h:int -> unit
    method virtual copy_rotated: image -> x:float -> y:float -> src_x:int ->
      src_y:int -> w:int -> h:int -> angle:int -> unit
    method virtual copy_merge: image -> x:int -> y:int -> src_x:int ->
      src_y:int -> w:int -> h:int -> pct:int -> unit
    method virtual copy_merge_gray: image -> x:int -> y:int -> src_x:int ->
      src_y:int -> w:int -> h:int -> pct:int -> unit
    method virtual palette_copy: image -> unit 
  end

(* Private interface routines. *)
(* Create an image *)
external do_image_create: int -> int -> t = "ml_image_create"
external do_image_create_truecolor: int -> int -> t
    = "ml_image_create_truecolor"
external do_image_open_png: string -> t = "ml_image_open_png"
external do_image_open_jpeg: string -> t = "ml_image_open_jpeg"

external do_is_truecolor: t -> bool = "ml_image_is_truecolor"

(* Drawing functions *)        
external do_set_pixel: t -> int -> int -> int -> unit = "ml_set_pixel"

external do_get_pixel: t -> int -> int -> int = "ml_get_pixel"

external do_get_width: t -> int = "ml_get_width"
external do_get_height: t -> int = "ml_get_height"

external do_draw_line: t -> int -> int -> int -> int -> int -> int -> unit
    = "ml_image_line" "ml_image_line_native"

external do_draw_dline: t -> int -> int -> int -> int -> int -> int -> unit
    = "ml_image_dline" "ml_image_dline_native"

external do_draw_rect: t -> int -> int -> int -> int -> int -> int -> unit
    = "ml_image_rect" "ml_image_rect_native"

external do_draw_frect: t -> int -> int -> int -> int -> int -> int -> unit
    = "ml_image_frect" "ml_image_frect_native"

external do_draw_poly: t -> (int * int) array -> int -> int -> int -> unit
    = "ml_image_poly"

external do_draw_fpoly: t -> (int * int) array -> int -> int -> int -> unit
    = "ml_image_fpoly"

external do_draw_arc:
  t -> int -> int -> int -> int -> int -> int -> int -> int -> unit
    = "ml_image_arc" "ml_image_arc_native"

external do_draw_carc:
  t -> int -> int -> int -> int -> int -> int -> int -> int -> bool -> bool -> unit
  = "ml_image_carc" "ml_image_carc_native"

external do_draw_cchord:
  t -> int -> int -> int -> int -> int -> int -> int -> int -> bool -> bool -> unit
  = "ml_image_cchord" "ml_image_cchord_native"

external do_draw_fell:
  t -> int -> int -> int -> int -> int -> int -> unit
    = "ml_image_fell" "ml_image_fell_native"

external do_border_fill: t -> int -> int -> int -> int -> unit
    = "ml_image_border_fill" "ml_image_border_fill_native"
    
external do_fill: t -> int -> int -> int -> unit 
    = "ml_image_fill"

external do_set_antialiased: t -> int -> unit
    = "ml_image_set_antialiased"
external do_set_antialiased_dont_blend: t -> int -> int -> unit
    = "ml_image_set_antialiased_dont_blend"

external do_set_brush: t -> t -> unit
    = "ml_image_set_brush"
external do_set_tile: t -> t -> unit
    = "ml_image_set_tile"
external do_set_thickness: t -> int -> unit
    = "ml_image_set_thickness"
external do_set_clip: t -> int -> int -> int -> int -> unit
    = "ml_image_set_clip"

external do_save_png: t -> string -> unit = "ml_save_png"
external do_save_jpeg: t -> string -> int -> unit = "ml_save_jpeg"

external do_dump_png: t -> out_channel -> unit = "ml_dump_png"
external do_dump_jpeg: t -> out_channel -> int -> unit = "ml_dump_jpeg"


(* External functions related to colors *)
external do_color_create: t -> red:int -> green:int -> blue:int -> c
    = "ml_image_color_alloc"

external do_find_closest: t -> red:int -> green:int -> blue:int -> c
    = "ml_image_color_closest"

external do_find_closest_hwb: t -> red:int -> green:int -> blue:int -> c
    = "ml_image_color_closest_hwb"

external do_find_exact: t -> red:int -> green:int -> blue:int -> c
    = "ml_image_color_exact"

external do_resolve: t -> red:int -> green:int -> blue:int -> c
    = "ml_image_color_resolve"

external do_green_channel: t -> int -> int = "ml_image_green_channel"
external do_red_channel: t -> int -> int = "ml_image_red_channel"
external do_blue_channel: t -> int -> int = "ml_image_blue_channel"
external do_alpha_channel: t -> int -> int = "ml_image_alpha_channel"
external do_get_transparent: t -> int = "ml_image_get_transparent"
external do_set_transparent: t -> int -> unit = "ml_image_set_transparent"

external do_get_font: int -> font = "ml_get_font"

external do_draw_char: t -> font -> int -> int -> char -> int -> unit
    = "ml_image_char" "ml_image_char_native"

external do_draw_charu: t -> font -> int -> int -> char -> int -> unit
    = "ml_image_charu" "ml_image_charu_native"

external do_draw_str: t -> font -> int -> int -> string -> int -> unit
    = "ml_image_str" "ml_image_str_native"

external do_draw_stru: t -> font -> int -> int -> string -> int -> unit
    = "ml_image_stru" "ml_image_stru_native"

external do_draw_str_ft:
    t -> int -> string -> float -> float -> int -> int -> string -> int array
    = "ml_image_str_ft" "ml_image_str_ft_native"
external do_draw_str_ftex:
    t -> int -> string -> float -> float -> int -> int -> ftex_flag array ->
        float -> ftex_charmap -> string -> int array
    = "ml_image_str_ftex" "ml_image_str_ftex_native"

external do_ft_bbox:
    string -> float -> float -> int -> int -> string -> int array
    = "ml_image_ft_bbox" "ml_image_ft_bbox_native"
external do_ftex_bbox:
    string -> float -> float -> int -> int -> ftex_flag array -> 
        float -> ftex_charmap -> string -> int array
    = "ml_image_ftex_bbox" "ml_image_ftex_bbox_native"

external do_copy: t -> t -> x:int -> y:int -> src_x:int -> src_y:int ->
    w:int -> h:int -> unit
    = "ml_image_copy" "ml_image_copy_native"
external do_copy_resized: t -> t -> x:int -> y:int -> src_x:int -> 
    src_y:int -> w:int -> h:int -> src_w:int -> src_h:int -> unit
    = "ml_image_copy_resized" "ml_image_copy_resized_native"
external do_copy_resampled: t -> t -> x:int -> y:int -> src_x:int -> 
    src_y:int -> w:int -> h:int -> src_w:int -> src_h:int -> unit
    = "ml_image_copy_resampled" "ml_image_copy_resampled_native"
external do_copy_rotated: t -> t -> x:float -> y:float -> src_x:int ->
    src_y:int -> w:int -> h:int -> angle:int -> unit
    = "ml_image_copy_rotated" "ml_image_copy_rotated_native"
external do_copy_merge: t -> t -> x:int -> y:int -> src_x:int ->
    src_y:int -> w:int -> h:int -> pct:int -> unit
    = "ml_image_copy_merge" "ml_image_copy_merge_native"
external do_copy_merge_gray: t -> t -> x:int -> y:int -> src_x:int ->
    src_y:int -> w:int -> h:int -> pct:int -> unit
    = "ml_image_copy_merge_gray" "ml_image_copy_merge_gray_native"
external do_palette_copy: t -> t -> unit 
    = "ml_image_palette_copy"


module Font =
  struct
    let tiny = do_get_font 0
    let small = do_get_font 1
    let medium = do_get_font 2
    let large = do_get_font 3
    let giant = do_get_font 4
  end


(* Implementation classes *)
(*
class gdColor im col =
  object(self)
    inherit color
    val antialias_color = false
    method code = col
    method blue_part = do_blue_part im col
    method red_part = do_red_part im col
    method green_part = do_green_part im col
    method antialiased = ({< antialias_color = true >} :> color)
    method is_aa = antialias_color
  end
*)

      
class virtual gd_color_allocator im = 
  object (self)
    inherit color_allocator
  
    val mutable aa_pcolor = false
    val mutable brushed_pcolor = false
    val mutable styled_pcolor = false
    val mutable styled_brushed_pcolor = false
    val mutable tiled_pcolor = false
    val mutable transparent_pcolor = true

      
    method create ~red ~green ~blue =
      let cindex = do_color_create im ~red ~green ~blue in
      if cindex = -1 then raise Too_many_colors 
      else self#new_ml_color cindex
  
    method closest ~red ~green ~blue =
      let cindex = do_find_closest im ~red ~green ~blue in
      if cindex = -1 then raise Color_not_found 
      else self#new_ml_color cindex
  
    method closest_hwb ~red ~green ~blue =
      let cindex = do_find_closest_hwb im ~red ~green ~blue in
      if cindex = -1 then raise Color_not_found 
      else self#new_ml_color cindex
  
    method exact ~red ~green ~blue =
      let cindex = do_find_exact im ~red ~green ~blue in
      if cindex = -1 then raise Color_not_found 
      else self#new_ml_color cindex
  
    method resolve ~red ~green ~blue =
      let cindex = do_resolve im ~red ~green ~blue in
      if cindex = -1 then raise Color_not_found 
      else self#new_ml_color cindex
  
    method find ~red ~green ~blue =
      let cindex = do_find_exact im ~red ~green ~blue in
      if cindex <> -1 then
        self#new_ml_color cindex
      else
        let cindex = do_color_create im ~red ~blue ~green in
        if cindex = -1 then raise Too_many_colors 
        else self#new_ml_color cindex

    method black = self#find ~red:0 ~blue:0 ~green:0
    method white = self#find ~red:255 ~blue:255 ~green:255
    method blue = self#find ~blue:255 ~red:0 ~green:0
    method green = self#find ~green:255 ~red:0 ~blue:0
    method red = self#find ~red:255 ~green:0 ~blue:0
    method get_transparent =
      let cindex = do_get_transparent im in
      if cindex = -1 then raise Color_not_found 
      else self#new_ml_color cindex
    method set_transparent color =
      do_set_transparent im color.index
    method set_antialiased enable = aa_pcolor <- enable 
    method set_brushed enable =
      brushed_pcolor <- enable;
      styled_brushed_pcolor <- enable && styled_pcolor
    method set_styled enable =
      styled_pcolor <- enable;
      styled_brushed_pcolor <- enable && brushed_pcolor
    method set_tiled enable = tiled_pcolor <- enable
    method antialiased () = 
      if aa_pcolor then 0
      else raise (Illegal_state 
        "You must call 'set_antialiased' before calling 'antialiased'.")
    method brushed () = 
      if brushed_pcolor then 1
      else raise (Illegal_state 
        "You must call 'set_brushed' before calling 'brushed'.")
    method styled () = 
      if styled_pcolor then 2
      else raise (Illegal_state 
        "You must call 'set_styled' before calling 'styled'.")
    method styled_brushed () = 
      if styled_brushed_pcolor then 3
      else raise (Illegal_state 
        "You must call 'set_brushed' and 'set_styled' before calling 
         'styled_brushed'.")
    method tiled () = 
      if tiled_pcolor then 4
      else raise (Illegal_state 
        "You must call 'set_tiled' before calling 'tiled'.")
    method transparent () =
      if transparent_pcolor then 5
      else raise (Illegal_state 
        "Transparent pseudocolor is disabled.")
  end

class gd_8bit_color_allocator im =
  object(self)
    inherit gd_color_allocator im

    val colors = Array.make 256 
      { index = -1; red_channel = -1; green_channel = -1;
        blue_channel = -1; alpha_channel = -1; } 

    method private new_ml_color idx =
      let mc =
        { index = idx;
          red_channel = (do_red_channel im idx);
          green_channel = (do_green_channel im idx);
          blue_channel = (do_blue_channel im idx);
          alpha_channel = (do_alpha_channel im idx); }  in
      colors.(idx) <- mc;
      mc

    method get_color_by_index idx =
      let c = colors.(idx) in
      if c.index = -1 then self#new_ml_color idx
      else c
  
  end

class gd_truecolor_allocator im =
  object(self)
    inherit gd_color_allocator im

    val colors:((int, color) Hashtbl.t) = Hashtbl.create 1024

    method private new_ml_color idx =
      let mc =
        { index = idx;
          red_channel = (do_red_channel im idx);
          green_channel = (do_green_channel im idx);
          blue_channel = (do_blue_channel im idx);
          alpha_channel = (do_alpha_channel im idx); }  in
      Hashtbl.replace colors idx mc;
      mc

    method get_color_by_index idx =
      try
        Hashtbl.find colors idx
      with Not_found ->
        self#new_ml_color idx
  
  end

      

class virtual gdImage im =
  object(self)
    inherit image
  
    method get_image = im
  
    method line ~x1 ~y1 ~x2 ~y2 ?(pseudo = -1) color =
      do_draw_line im x1 y1 x2 y2 color.index pseudo
  
    method dashed_line ~x1 ~y1 ~x2 ~y2 ?(pseudo = -1) color =
      do_draw_dline im x1 y1 x2 y2 color.index pseudo
  
    method rectangle ~x1 ~y1 ~x2 ~y2 ?(pseudo = -1) color =
      do_draw_rect im x1 y1 x2 y2 color.index pseudo
  
    method filled_rectangle ~x1 ~y1 ~x2 ~y2 ?(pseudo = -1) color =
      do_draw_frect im x1 y1 x2 y2 color.index pseudo
  
    method polygon ~pts ?(pseudo = -1) color =
      do_draw_poly im pts (Array.length pts) color.index pseudo
  
    method filled_polygon ~pts ?(pseudo = -1) color =
      do_draw_fpoly im pts (Array.length pts) color.index pseudo
  
    method arc ~cx ~cy ~w ~h ~s ~e ?(pseudo = -1) color =
      do_draw_arc im cx cy w h s e color.index pseudo
  
    method closed_arc
        ~cx ~cy ~w ~h ~s ~e ?(nofill = false) ?(edged = false) ?(pseudo = -1) color =
      do_draw_carc im cx cy w h s e color.index pseudo nofill edged
  
    method closed_chord
        ~cx ~cy ~w ~h ~s ~e ?(nofill = false) ?(edged = false) ?(pseudo = -1) color =
      do_draw_cchord im cx cy w h s e color.index pseudo nofill edged
  
    method filled_ellipse ~cx ~cy ~w ~h ?(pseudo = -1) color =
      do_draw_fell im cx cy w h color.index pseudo
  
    method border_fill ~x ~y ~border ~fill =
      do_border_fill im x y (border.index) (fill.index)
  
    method fill ~x ~y color =
      do_fill im x y color.index
  
    method set_antialiased col =
      self#colors#set_antialiased true;
      do_set_antialiased im col.index
  
    method set_antialiased_dont_blend ~aacolor ~dontblend =
      self#colors#set_antialiased true;
      do_set_antialiased_dont_blend im aacolor.index dontblend.index
  
    method set_brush br =
      self#colors#set_brushed true;
      do_set_brush im br#get_image
    method set_tile ti =
      self#colors#set_tiled true;
      do_set_tile im ti#get_image
    method set_thickness th = do_set_thickness im th
    method set_clip ~x1 ~y1 ~x2 ~y2 =
      do_set_clip im x1 y1 x2 y2
  
    method letter ~font ~x ~y ~c color =
      do_draw_char im font x y c color.index
  
    method letter_up ~font ~x ~y ~c color =
      do_draw_charu im font x y c color.index
  
    method string ~font ~x ~y ~s color =
      do_draw_str im font x y s color.index
  
    method string_up ~font ~x ~y ~s color =
      do_draw_stru im font x y s color.index

    method string_ft ~fg ~fname ~size ~angle ~x ~y text =
      do_draw_str_ft im fg.index fname size angle x y text
    method string_ftex ~fg ~fname ~size ~angle ~x ~y ?(flags = [||]) 
        ?(spacing = 1.05) ?(charmap = FTExUnicode) text =
      do_draw_str_ftex im fg.index fname size angle x y flags spacing 
        charmap text
  
    method save_as_png filename = do_save_png im filename
    method save_as_jpeg ?(quality = -1) filename =
      do_save_jpeg im filename quality
  
    method out_as_png channel = do_dump_png im channel
    method out_as_jpeg ?(quality = -1) channel =
      do_dump_jpeg im channel quality
  
    method set_pixel ~x ~y color =
      do_set_pixel im x y color.index
  
    method get_pixel ~x ~y =
      self#colors#get_color_by_index (do_get_pixel im x y)
  
    method width = do_get_width im
    method height = do_get_height im
  
    method in_range ~x ~y =
      x >= 0 && x <= (do_get_width im) && y >= 0 && y <= (do_get_height im)

    method copy src ~x ~y ~src_x ~src_y ~w ~h =
      do_copy im src#get_image x y src_x src_y w h
    method copy_resized src ~x ~y ~src_x ~src_y ~w ~h ~src_w ~src_h =
      do_copy_resized im src#get_image x y src_x src_y w h src_w src_h
    method copy_resampled src ~x ~y ~src_x ~src_y ~w ~h ~src_w ~src_h =
      do_copy_resampled im src#get_image x y src_x src_y w h src_w src_h
    method copy_rotated src ~x ~y ~src_x ~src_y ~w ~h ~angle =
      do_copy_rotated im src#get_image x y src_x src_y w h angle
    method copy_merge src ~x ~y ~src_x ~src_y ~w ~h ~pct =
      do_copy_merge im src#get_image x y src_x src_y w h pct
    method copy_merge_gray src ~x ~y ~src_x ~src_y ~w ~h ~pct =
      do_copy_merge_gray im src#get_image x y src_x src_y w h pct
    method palette_copy src = 
      do_palette_copy im src#get_image

  end

(* 8-bit (indexed-color) image *)
class gdImage8 im =
  object
    inherit gdImage im

    val c_a = new gd_8bit_color_allocator im
    method colors = c_a
  end

(* Truecolor image *)
class gdImageT im =
  object
    inherit gdImage im

    val c_a = new gd_truecolor_allocator im
    method colors = c_a
  end


let is_truecolor im = do_is_truecolor im

let ft_bbox ~fname ~size ~angle ~x ~y text =
  do_ft_bbox fname size angle x y text
let ftex_bbox ~fname ~size ~angle ~x ~y ?(flags = [||]) ?(spacing = 1.05)
    ?(charmap = FTExUnicode) text =
  do_ftex_bbox fname size angle x y flags spacing charmap text

(* Image creation functions *)
let create ~(x:int) ~(y:int) = 
  new gdImage8 (do_image_create x y)

let create_truecolor ~(x:int) ~(y:int) = 
  new gdImageT (do_image_create_truecolor x y)

let open_png filename =
  let im = (do_image_open_png filename) in
  if (is_truecolor im) then new gdImageT im
  else new gdImage8 im

let open_jpeg filename =
  new gdImageT (do_image_open_jpeg filename)