gd4o-1.0~alpha5/README.ocamlgd 0000664 0000000 0000000 00000001626 11644321154 0015773 0 ustar 00root root 0000000 0000000 Ocaml-GD 0.5
This is an interface to the GD graphics library for Ocaml.
It's used to make simple graphic images, usually in the png format.
The interface tends to follow the GD functions.
And unlike a lot of ocaml libraries, this uses it's OO features. It
also uses labels, though it should be possible to use it in code that
doesn't. It uses labels because many of the functions take many int
arguments, and the labels helps (Me, at least) to keep everything
straight. And if you forget the order, it's no big deal.
There's an image class, and color and font allocation classes, and a
color class. Thus, drawing a red line might look like:
myimage#line ~x1:0 ~y1:0 ~x2:60 ~y2:30 myimage#colors#red
intead of
Gd.line myimage ~x1:0 ~y1:0 ~x2:60 ~y2:30 (Gd.red myimage)
See manual.txt and gd.mli for documentation.
TODO:
Interlaced images
Serialization?
Reading and writing more image formats.
Brushes
Polygons gd4o-1.0~alpha5/TODO 0000664 0000000 0000000 00000000220 11644321154 0014163 0 ustar 00root root 0000000 0000000 Implement all drawing methods.
Implement TrueType font support.
Improve documentation.
Find out why antialiased curves are so bloody slow.
Etc.
gd4o-1.0~alpha5/doc/ 0000775 0000000 0000000 00000000000 11644321154 0014246 5 ustar 00root root 0000000 0000000 gd4o-1.0~alpha5/doc/api-xref.html 0000664 0000000 0000000 00000227464 11644321154 0016666 0 ustar 00root root 0000000 0000000
Haven Rock: GD4O API Cross-reference
GD4O API Cross-reference
The following tables list all functions in the GD API. Corresponding
OCaml function names are shown for all functions currently implemented
in GD4O. The When column shows when each function
was implemented: [0] indicates that the function was implemented in
OCamlGD 0.7; [1], [2], [3], [4], and [5] stand for GD4O releases 1.0a1,
1.0a2, 1.0a3, 1.0a4, and 1.0a5, respectively.
-
Image creation, destruction, loading, and saving
-
Drawing functions
-
Query functions
-
Font and text-handling functions
-
Color-handling functions
-
Copying and resizing functions
-
Miscellaneous functions
Image creation, destruction, loading, and saving
Drawing functions
Query functions
Font and text-handling functions
Color-handling functions
Copying and resizing functions
Miscellaneous functions
Copyright © 2003 by
Matt Gushee
:: Last modified:
Nov. 24, 2003
gd4o-1.0~alpha5/doc/api-xref.xml 0000664 0000000 0000000 00000124316 11644321154 0016512 0 ustar 00root root 0000000 0000000
GD4O API Cross-reference
The following tables list all functions in the GD API. Corresponding
OCaml function names are shown for all functions currently implemented
in GD4O. The When column shows when each function
was implemented: [0] indicates that the function was implemented in
OCamlGD 0.7; [1], [2], [3], [4], and [5] stand for GD4O releases 1.0a1,
1.0a2, 1.0a3, 1.0a4, and 1.0a5, respectively.
-
Image creation, destruction, loading, and saving
-
Drawing functions
-
Query functions
-
Font and text-handling functions
-
Color-handling functions
-
Copying and resizing functions
-
Miscellaneous functions
Image creation, destruction, loading, and saving
C Function
|
When
|
OCaml Function
|
Comments
|
gdImageCreate
|
[0]
|
create
|
|
gdImageCreateTrueColor
|
[2]
|
create_truecolor
|
|
gdImageCreateFromJpeg
|
[0]
|
open_jpeg
|
|
gdImageCreateFromPng
|
[0]
|
open_png
|
|
gdImageCreateFromPngSource
|
|
|
|
gdImageCreateFromGd
|
|
|
|
gdImageCreateFromGd2
|
|
|
|
gdImageCreateFromGd2Part
|
|
|
|
gdImageCreateFromXbm
|
|
|
|
gdImageCreateFromXpm
|
|
|
|
gdImageDestroy
|
|
|
|
gdImageJpeg
|
[0]
|
#image#save_as_jpeg
|
|
gdImageJpegPtr
|
|
|
|
gdImagePng
|
[0]
|
#image#save_as_png
|
|
gdImagePngEx
|
|
|
|
gdImagePngPtr
|
|
|
|
gdImagePngPtrEx
|
|
|
|
gdImagePngToSink
|
[0]
|
#image#out_as_png
|
|
gdImageWBMP
|
|
|
|
gdImageWBMPPtr
|
|
|
|
gdImageGd
|
|
|
|
gdImageGdPtr
|
|
|
|
gdImageGd2
|
|
|
|
gdImageGd2Ptr
|
|
|
|
gdImageTrueColorToPalette
|
|
|
|
Drawing functions
C Function
|
When
|
OCaml Function
|
Comments
|
gdImageSetPixel
|
[0]
|
#image#set_pixel
|
|
gdImageLine
|
[0]
|
#image#line
|
|
gdImageDashedLine
|
[0]
|
#image#dashed_line
|
|
gdImagePolygon
|
[1]
|
#image#polygon
|
|
gdImageRectangle
|
[0]
|
#image#rectangle
|
|
gdImageFilledPolygon
|
[1]
|
#image#filled_polygon
|
|
gdImageFilledRectangle
|
[0]
|
#image#filled_rectangle
|
|
gdImageArc
|
[0]
|
#image#arc
|
|
gdImageFilledArc
|
[2]
|
#image#closed_arc
&
#image#closed_chord
|
In the C library, 'FilledArc' takes a bitwise OR of several flags. But those
flags include one that specifies an arc, and another that specifies a chord
- which are in fact mutually exclusive drawing operations. Seems like rather
poor design to me, so I separated FilledArc into two methods. Furthermore, the
word 'closed' seems to me a more accurate description of what the method does.
|
gdImageFilledEllipse
|
[1]
|
#image#filled_ellipse
|
|
gdImageFillToBorder
|
[0]
|
#image#border_fill
|
This function works when called from a native code executable, but
when called from byte code, it seems to go into infinite recursion.
|
gdImageFill
|
[0]
|
#image#fill
|
|
gdImageSetAntiAliased
|
[1]
|
#image#set_antialiased
|
Antialiased drawing is surprisingly slow. Must be something sub-optimal
in the C wrapper.
|
gdImageSetAntiAliasedDontBlend
|
[2]
|
#image#set_antialiased_dontblend
|
|
gdImageSetBrush
|
[2]
|
#image#set_brush
|
|
gdImageSetTile
|
[2]
|
#image#set_tile
|
|
gdImageSetStyle
|
|
|
|
gdImageSetThickness
|
[2]
|
#image#set_thickness
|
|
gdImageAlphaBlending
|
|
|
|
gdImageSaveAlpha
|
|
|
|
gdImageSetClip
|
[2]
|
#image#set_clip
|
|
gdImageGetClip
|
|
|
|
gdImageBlue
|
|
|
|
Query functions
C Function
|
When
|
OCaml Function
|
Comments
|
gdImageAlpha
|
|
|
|
gdImageGetPixel
|
[0]
|
#image#get_pixel
|
|
gdImageBoundsSafe
|
[0]
|
#image#in_range
|
|
gdImageGreen
|
|
|
|
gdImageRed
|
|
|
|
gdImageSX
|
[0]
|
#image#width
|
|
gdImageSY
|
[0]
|
#image#height
|
|
Font and text-handling functions
C Function
|
When
|
OCaml Function
|
Comments
|
gdImageChar
|
[0]
|
#image#letter
|
|
gdImageCharUp
|
[0]
|
#image#letter_up
|
|
gdImageString
|
[0]
|
#image#string
|
|
gdImageString16
|
|
|
|
gdImageStringUp
|
[0]
|
#image#string_up
|
|
gdImageStringUp16
|
|
|
|
gdImageStringFT
|
[3]
|
#image#string_ft
&
ft_bbox
|
In the C API, gdImageStringFt returns the bounding box of the
string. If you need the bounding box without drawing the string,
you pass a null gdImagePointer. Since OCaml doesn't really have
null pointers, the ft_bbox function simply calls a C function
that passes a null gdImagePtr to gdImageStringFT.
|
gdImageStringFTEx
|
[4]
|
#image#string_ftex
&
ftex_bbox
|
Partially implemented. Supports multiline text, but not yet
double-byte characters. See also notes for gdImageStringFT.
|
gdImageStringTTF
|
|
|
|
Color-handling functions
C Function
|
When
|
OCaml Function
|
Comments
|
gdImageColorAllocate
|
[0]
|
#color_allocator#create
|
|
gdImageColorAllocateAlpha
|
|
|
|
gdImageColorClosest
|
[0]
|
#color_allocator#closest
|
|
gdImageColorClosestAlpha
|
|
|
|
gdImageColorClosestHWB
|
[0]
|
#collor_allocator#closest_hwb
|
|
gdImageColorExact
|
[0]
|
#collor_allocator#exact
|
|
gdImageColorResolve
|
[0]
|
#collor_allocator#resolve
|
|
gdImageColorResolveAlpha
|
|
|
|
gdImageColorsTotal
|
|
|
|
gdImageRed
|
[0]
|
#collor_allocator#red
|
|
gdImageGreen
|
[0]
|
#collor_allocator#green
|
|
gdImageBlue
|
[0]
|
#collor_allocator#blue
|
|
gdImageGetInterlaced
|
|
|
|
gdImageGetTransparent
|
[0]
|
#collor_allocator#get_transparent
|
Name changed to conform more closely to the C API. The previous name, '#transparent',
is now used for the method corresponding to gdImageTransparent.
|
gdImageColorDeallocate
|
|
|
|
gdImageColorTransparent
|
[2]
|
#color_allocator#set_transparent
|
|
gdImageTrueColor
|
|
|
|
gdImageTrueColorAlpha
|
|
|
|
Copying and resizing functions
C Function
|
When
|
OCaml Function
|
Comments
|
gdImageCopy
|
[5]
|
#image#copy
|
|
gdImageCopyResized
|
[5]
|
#image#copy_resized
|
|
gdImageCopyResampled
|
[5]
|
#image#copy_resampled
|
|
gdImageCopyRotated
|
[5]
|
#image#copy_rotated
|
|
gdImageCopyMerge
|
[5]
|
#image#copy_merge
|
|
gdImageCopyMergeGray
|
[5]
|
#image#copy_merge_gray
|
|
gdImagePaletteCopy
|
[5]
|
#image#palette_copy
|
|
Miscellaneous functions
C Function
|
When
|
OCaml Function
|
Comments
|
gdImageCompare
|
|
|
|
gdImageInterlace
|
|
|
|
gdFree
|
|
|
|
gd4o-1.0~alpha5/doc/manual.txt 0000664 0000000 0000000 00000010637 11644321154 0016273 0 ustar 00root root 0000000 0000000 This is not yet complete documentation!
Images:
Images are objects. However, they should not be created with new
directly. Instead, use the functions in the next section to create
them.
Creating images:
Images can be created from scratch, or from an existing file.
Gd.create: ~x:int -> ~y:int -> image
Creates a new image with the given dimensions.
Gd.open_png: string -> image
Creates a new image from the given png file.
Gd.open_jpeg: string -> image
Creates a new image from the given jpeg file. Raises Gd.Not_supported
if jpeg operations aren't compiled in.
Saving images:
Images can be saved to PNG files, or to jpeg's if Gd and OcamlGd are compiled
with jpeg support.
image#save_as_png: string -> unit
Saves a png version of the image to the file.
image:save_as_jpeg: ?quality:int -> string -> unit
Saves a jpeg version of the image to the file, with the given
image quality or a reasonable default. Quality is from 0 to 95,
the higher the more quality and larger the file. Raises Gd.Not_supported
if jpeg operations aren't compiled in.
image#out_as_png: out_channel -> unit
image#out_as_jpeg: ?quality:int -> out_channel -> unit
Dumps the image in the proper format to the out_channel. Useful for
things like a CGI program that wants to dump an image to stdout.
out_as_jpeg raises Gd.Not_supported if jpeg operations aren't compiled
in.
Colors:
Each image can have up to 255 different colors. The first color assigned
will be the image's default background color. All colors for an object
are created and looked up through a color_allocator object associated with
the image object. This can be accessed through the colors method.
E.g: let my_colors = myimage#colors;;
Colors themselves are another class, with three public methods, for
getting the red, green and blue componets of the color. red_part,
green_part, and blue_part.
Color allocators have a number of methods for predefined color names:
white, black, red, green, blue and transparent.
colors#create: ~red:int -> ~green:int -> ~blue:int -> Gd.color
Creates a new color for the associated image. Raises Gd.Too_many_colors
if more than 255 colors have already been assigned.
colors#closest: ~red:int -> ~green:int -> ~blue:int -> Gd.color
Looks up and returns the already created color closest to the RGB
values. If the lookup fails, raises Gd.Color_not_found.
colors#exact: ~red:int -> ~green:int -> ~blue:int -> Gd.color
Looks up and returns the already created color exactly matching the RGB
values. If the lookup fails, raises Gd.Color_not_found.
Fonts:
There are 5 different fonts available for drawing text, all in the
Gd.Font module. Unlike colors, they are independant of image. Listed
here, in order of increasing size.
Gd.Font.tiny
Gd.Font.small
Gd.Font.medium
Gd.Font.large
Gd.Font.giant
Text:
There are four methods for drawing text - two for single characters,
two for strings.
image#letter: font:Gd.font -> x:int -> y:int -> c:char -> Gd.color -> unit
image#letter_up: font:Gd.font -> x:int -> y:int -> c:char -> Gd.color -> unit
Draw a single character. letter goes from left to right, letter_up
bottom to top, rotated 90 degrees.
image#string: font:Gd.font -> x:int -> y:int -> s:string -> Gd.color -> unit
image#string_up: font:Gd.font -> x:int -> y:int -> s:string -> Gd.color -> unit
Draw a string. Letters go from left to right in string, and
string_up does bottom to top, rotated 90 degrees.
Lines:
There are two methods for drawing straight lines, and one for arcs:
image#line: x1:int -> y1:int -> x2:int -> y2:int -> color -> unit
image#dashed_line: x1:int -> y1:int -> x2:int -> y2:int -> color -> unit
image#arc: cx:int -> cy:int -> w:int -> h:int -> s:int -> e:int -> color -> unit
Shapes and coloring:
image#rectangle: x1:int -> y1:int -> x2:int -> y2:int -> color -> unit
image#filled_rectangle: x1:int -> y1:int -> x2:int -> y2:int -> color -> unit
image#border_fill: x:int -> y:int -> border:color -> fill:color -> unit
image#virtual fill: x:int -> y:int -> color -> unit
Individual pixels:
image#set_pixel: x:int -> y:int -> color -> unit
image#get_pixel: x:int -> y:int -> color
Information about the image:
There are a few methods for finding out information about the image. They do
the obvious things. in_range returns true if the image is large enough to
have a pixel at the given coordinates.
image#width : int
image#height : int
image#in_range: x:int -> y:int -> bool
gd4o-1.0~alpha5/font_list.txt 0000664 0000000 0000000 00000000422 11644321154 0016241 0 ustar 00root root 0000000 0000000 # This file should contain the full paths of four TrueType font files
# that exist on your system, as shown below.
/usr/local/share/fonts/ttf/ancis___.ttf
/usr/local/share/fonts/ttf/verdanab.ttf
/usr/local/share/fonts/ttf/wurker__.ttf
/usr/local/share/fonts/ttf/chancy.ttf
gd4o-1.0~alpha5/gd.ml 0000664 0000000 0000000 00000056405 11644321154 0014437 0 ustar 00root root 0000000 0000000 (* $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)
gd4o-1.0~alpha5/gd.mli 0000664 0000000 0000000 00000021574 11644321154 0014607 0 ustar 00root root 0000000 0000000 (* $Header: /home/cvs/gd4o/gd.mli,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
*)
type t (* image type *)
(* GD images can only have 256 colors *)
exception Too_many_colors
(* Tried to find a preallocated color that wasn't *)
exception Color_not_found
(* Couldn't create or open an image. *)
exception Image_creation_failed
(* This build doesn't support some image format (Jpeg, Xpm, etc.) *)
exception Not_supported
(* An operation was attempted without having performed one or more prerequisites. *)
exception Illegal_state of string
(* All of these classes are virtual because users shouldn't be instatiating them.
Instead, use the creation or opening functions listed at the bottom *)
(*
class virtual color :
object
(* Returns the red part (0-255) of the color *)
method virtual red_part : int
(* Returns the green part (0-255) of the color *)
method virtual green_part : int
(* Returns the blue part (0-255) of the color *)
method virtual blue_part : int
(* Returns the code of the color. Please don't use. *)
method virtual code : int
method virtual antialiased : color
method virtual is_aa : bool
end
*)
type color
type ftex_flag =
| FTExSetSpacing
| FTExSetCharmap
type ftex_charmap =
| FTExUnicode
| FTExShiftJIS
| FTExBig5
(* The first color allocated for an image is it's background *)
class virtual color_allocator :
object
(* R, G, and B values are integers 0-255 *)
method virtual create: red:int -> green:int -> blue:int -> color
(* Return the closest-matching color of those already allocated *)
method virtual closest: red:int -> green:int -> blue:int -> color
method virtual closest_hwb: red:int -> green:int -> blue:int -> color
(* Try exact, create, closest *)
method virtual resolve: red:int -> green:int -> blue:int -> color
(* Exact match color of those already allocated *)
method virtual exact: red:int -> green:int -> blue:int -> color
(* Try an exact, create *)
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
type font
module Font :
sig
val tiny: font
val small: font
val medium: font
val large: font
val giant: font
end
class virtual image :
object
(* This was private, but it needs to be exposed for things like tile
brush images. *)
method virtual get_image: t
(* Return the color_allocator object associated with this image *)
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
(* Fill an area bordered by the border color *)
method virtual border_fill: x:int -> y:int -> border:color ->
fill:color -> unit
(* Fill an area with the same color as the pixel *)
method virtual fill: x:int -> y:int -> color -> unit
(* Turn on antialiasing. *)
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
(* Draw one character *)
method virtual letter: font:font -> x:int -> y:int -> c:char -> color -> unit
(* Rotated 90 degrees *)
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
(* Rotated 90 degrees *)
method virtual string_up: font:font -> x:int -> y:int -> s:string ->
color -> unit
(* Freetype string *)
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 set_pixel: x:int -> y:int -> color -> unit
method virtual get_pixel: x:int -> y:int -> color
(* Image's size *)
method virtual width: int
method virtual height: int
(* Is proposed drawing location within the drawing area? *)
method virtual in_range: x:int -> y:int -> bool
(* Save to file *)
method virtual save_as_png: string -> unit
method virtual save_as_jpeg: ?quality:int -> string -> unit
(* Dump to an out_channel. *)
method virtual out_as_png: out_channel -> unit
method virtual out_as_jpeg: ?quality:int -> out_channel -> unit
(* Copy a region from another image to this image. *)
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
(* Create a new image with the given size *)
val create: x:int -> y:int -> image (* Throws Gd.Image_creation_faield *)
(* Create a new image with the given size *)
val create_truecolor: x:int -> y:int -> image (* Throws Gd.Image_creation_faield *)
(* Open a png file. Throws Not_found and Gd.Image_creation_failed *)
val open_png: string -> image
(* Same, but for jpeg's *)
val open_jpeg: string -> image
val is_truecolor: t -> bool
(* Return the bounding box for a string rendered with FreeType *)
val ft_bbox: fname:string -> size:float -> angle:float -> x:int ->
y:int -> string -> int array
val ftex_bbox: fname:string -> size:float -> angle:float -> x:int ->
y:int -> ?flags:ftex_flag array -> ?spacing:float ->
?charmap:ftex_charmap -> string -> int array
gd4o-1.0~alpha5/gdstubs.c 0000664 0000000 0000000 00000067517 11644321154 0015340 0 ustar 00root root 0000000 0000000 /* $Header: /home/cvs/gd4o/gdstubs.c,v 1.7 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
*/
#include
#include
#include
#include
#include
#include
#include
#include
#include
#include
#include
#include
#include
#include
#include
struct gd_wrapper {
gdImagePtr im;
};
typedef struct gd_wrapper GdWrapper;
struct font_wrapper {
gdFontPtr font;
};
typedef struct font_wrapper GdFWrapper;
struct points_wrapper {
gdPointPtr pts;
};
typedef struct points_wrapper GdPtsWrapper;
#define IM_VAL(X) ((*((GdWrapper *)(Data_custom_val(X)))).im)
#define FONT_VAL(X) ((*((GdFWrapper *)(Data_custom_val(X)))).font)
#define PTS_VAL(X) ((*((GdPtsWrapper *)(Data_custom_val(X)))).pts)
static void ml_gd_finalize(value);
static long ml_gd_hash(value);
static int ml_font_cmp(value, value);
static long ml_font_hash(value);
static struct custom_operations image_t_custom_operations = {
"GD image/0.1",
ml_gd_finalize,
NULL,
ml_gd_hash,
NULL,
NULL
};
static struct custom_operations font_t_custom_operations = {
"GD font/0.1",
NULL,
ml_font_cmp,
ml_font_hash,
NULL,
NULL
};
static gdFontPtr fonts[5] =
{
NULL,
NULL,
NULL,
NULL,
NULL
};
static int fonts_init = 0;
static int pseudoColors[6] =
{ gdAntiAliased, gdBrushed, gdStyled,
gdStyledBrushed, gdTiled, gdTransparent };
static int ftExFlags[2] =
{ gdFTEX_LINESPACE, gdFTEX_CHARMAP };
static int ftExCharmaps[3] =
{ gdFTEX_Unicode, gdFTEX_Shift_JIS, gdFTEX_Big5 };
void ml_gd_finalize(value v) {
if (IM_VAL(v))
gdImageDestroy(IM_VAL(v));
}
long ml_gd_hash(value v) {
return gdImageSX(IM_VAL(v));
}
int ml_font_cmp(value v1, value v2) {
return (int)FONT_VAL(v1) - (int)FONT_VAL(v2);
}
static long ml_font_hash(value v) {
return (long)FONT_VAL(v);
}
value ml_get_font(value i) {
CAMLparam1(i);
CAMLlocal1(v);
v = alloc_custom(&font_t_custom_operations, sizeof(GdFWrapper), 1, 10);
if (!fonts_init) {
fonts[0] = gdFontTiny;
fonts[1] = gdFontSmall;
fonts[2] = gdFontMediumBold;
fonts[3] = gdFontLarge;
fonts[4] = gdFontGiant;
fonts_init = 1;
}
FONT_VAL(v) = fonts[Int_val(i)];
CAMLreturn(v);
}
value ml_image_create(value sx, value sy) {
CAMLparam2(sx, sy);
CAMLlocal1(v);
gdImagePtr im;
im = gdImageCreate(Int_val(sx), Int_val(sy));
if (!im)
raise_constant(*(value *)caml_named_value("gdopen failed"));
v = alloc_custom(&image_t_custom_operations, sizeof(GdWrapper),
(Int_val(sx) * Int_val(sy)) + sizeof(gdImage), 10000);
IM_VAL(v) = im;
CAMLreturn(v);
}
value ml_image_create_truecolor(value sx, value sy) {
CAMLparam2(sx, sy);
CAMLlocal1(v);
gdImagePtr im;
im = gdImageCreateTrueColor(Int_val(sx), Int_val(sy));
if (!im)
raise_constant(*(value *)caml_named_value("gdopen failed"));
v = alloc_custom(&image_t_custom_operations, sizeof(GdWrapper),
(Int_val(sx) * Int_val(sy)) + sizeof(gdImage), 10000);
IM_VAL(v) = im;
CAMLreturn(v);
}
value ml_image_open_png(value filename) {
CAMLparam1(filename);
CAMLlocal1(v);
FILE *in;
gdImagePtr im;
in = fopen(String_val(filename), "rb");
if (!in)
raise_not_found();
im = gdImageCreateFromPng(in);
fclose(in);
if (!im)
raise_constant(*(value *)caml_named_value("gdopen failed"));
v = alloc_custom(&image_t_custom_operations, sizeof(GdWrapper),
sizeof(gdImage) + (gdImageSX(im) * gdImageSY(im)), 100000);
IM_VAL(v) = im;
CAMLreturn(v);
}
/* This is useful when an image has been created from a PNG file,
* so it could be either truecolor or 8-bit. */
value ml_image_is_truecolor(value gdw) {
gdImagePtr im;
im = IM_VAL(gdw);
if (im->trueColor) {
return Val_true;
}
else {
return Val_false;
}
}
value ml_image_open_jpeg(value filename) {
#ifdef HAVE_JPEG
FILE *in;
gdImagePtr im;
CAMLparam1(filename);
CAMLlocal1(v);
in = fopen(String_val(filename), "rb");
if (!in)
raise_not_found();
im = gdImageCreateFromJpeg(in);
fclose(in);
if (!im)
raise_constant(*(value *)caml_named_value("gdopen failed"));
v = alloc_custom(&image_t_custom_operations, sizeof(GdWrapper),
sizeof(gdImage) + (gdImageSX(im) * gdImageSY(im)), 100000);
IM_VAL(v) = im;
CAMLreturn(v);
#else
raise_constant(*(value *)caml_named_value("gd type not supported"));
return Val_unit;
#endif
}
value ml_image_line_native(value gdw, value x1, value y1, value x2, value y2,
value c, value pc) {
int pcval;
pcval = Int_val(pc);
if (pcval >= 0)
gdImageLine(IM_VAL(gdw), Int_val(x1), Int_val(y1), Int_val(x2), Int_val(y2),
pseudoColors[pcval]);
else
gdImageLine(IM_VAL(gdw), Int_val(x1), Int_val(y1), Int_val(x2), Int_val(y2),
Int_val(c));
return Val_unit;
}
value ml_image_line(value *argv, int argc) {
#ifdef SAFER
assert (argc == 7);
#endif
return
ml_image_line_native(argv[0], argv[1], argv[2], argv[3], argv[4],
argv[5], argv[6]);
}
value ml_image_dline_native(value gdw, value x1, value y1, value x2, value y2,
value c, value pc) {
int pcval;
pcval = Int_val(pc);
if (pcval >= 0)
gdImageDashedLine(IM_VAL(gdw), Int_val(x1), Int_val(y1), Int_val(x2),
Int_val(y2), pseudoColors[pcval]);
else
gdImageDashedLine(IM_VAL(gdw), Int_val(x1), Int_val(y1), Int_val(x2),
Int_val(y2), Int_val(c));
return Val_unit;
}
value ml_image_dline(value *argv, int argc) {
#ifdef SAFER
assert (argc == 7);
#endif
return
ml_image_line_native(argv[0], argv[1], argv[2], argv[3], argv[4],
argv[5], argv[6]);
}
value ml_image_rect_native(value gdw, value x1, value y1, value x2, value y2,
value c, value pc) {
int pcval;
pcval = Int_val(pc);
if (pcval >= 0)
gdImageRectangle(IM_VAL(gdw), Int_val(x1), Int_val(y1), Int_val(x2),
Int_val(y2), pseudoColors[pcval]);
else
gdImageRectangle(IM_VAL(gdw), Int_val(x1), Int_val(y1), Int_val(x2),
Int_val(y2), Int_val(c));
return Val_unit;
}
value ml_image_rect(value *argv, int argc) {
#ifdef SAFER
assert (argc == 7);
#endif
return
ml_image_rect_native(argv[0], argv[1], argv[2], argv[3], argv[4],
argv[5], argv[6]);
}
value ml_image_frect_native(value gdw, value x1, value y1, value x2, value y2,
value c, value pc) {
int pcval;
pcval = Int_val(pc);
if (pcval >= 0)
gdImageFilledRectangle(IM_VAL(gdw), Int_val(x1), Int_val(y1), Int_val(x2),
Int_val(y2), pseudoColors[pcval]);
else
gdImageFilledRectangle(IM_VAL(gdw), Int_val(x1), Int_val(y1), Int_val(x2),
Int_val(y2), Int_val(c));
return Val_unit;
}
value ml_image_frect(value *argv, int argc) {
#ifdef SAFER
assert (argc == 7);
#endif
return
ml_image_frect_native(argv[0], argv[1], argv[2], argv[3], argv[4],
argv[5], argv[6]);
}
/* Draw a polygon. */
value ml_image_poly(value gdw, value points, value numpts, value c, value pc) {
gdPoint gd_points[numpts];
int i, n, pcval;
pcval = Int_val(pc);
n = Int_val(numpts);
for (i = 0; i < n; i++) {
gd_points[i].x = Int_val(Field(Field(points, i), 0));
gd_points[i].y = Int_val(Field(Field(points, i), 1));
}
if (pcval >= 0)
gdImagePolygon(IM_VAL(gdw), gd_points, Int_val(numpts), pseudoColors[pcval]);
else
gdImagePolygon(IM_VAL(gdw), gd_points, Int_val(numpts), Int_val(c));
return Val_unit;
}
/* Draw a filled polygon. */
value ml_image_fpoly(value gdw, value points, value numpts, value c, value pc) {
gdPoint gd_points[numpts];
int i, n, pcval;
pcval = Int_val(pc);
n = Int_val(numpts);
for (i = 0; i < n; i++) {
gd_points[i].x = Int_val(Field(Field(points, i), 0));
gd_points[i].y = Int_val(Field(Field(points, i), 1));
}
if (pcval >= 0)
gdImageFilledPolygon(IM_VAL(gdw), gd_points, Int_val(numpts), pseudoColors[pcval]);
else
gdImageFilledPolygon(IM_VAL(gdw), gd_points, Int_val(numpts), Int_val(c));
return Val_unit;
}
value ml_image_fell_native(value gdw, value cx, value cy, value w, value h,
value c, value pc) {
int pcval;
pcval = Int_val(pc);
if (pcval >= 0)
gdImageFilledEllipse(IM_VAL(gdw), Int_val(cx), Int_val(cy), Int_val(w),
Int_val(h), pseudoColors[pcval]);
else
gdImageFilledEllipse(IM_VAL(gdw), Int_val(cx), Int_val(cy), Int_val(w),
Int_val(h), Int_val(c));
return Val_unit;
}
value ml_image_fell(value *argv, int argc) {
#ifdef SAFER
assert (argc == 7);
#endif
return
ml_image_fell_native(argv[0], argv[1], argv[2], argv[3], argv[4],
argv[5], argv[6]);
}
value ml_image_arc_native(value gdw, value cx, value cy, value w, value h,
value s, value e, value c, value pc) {
int pcval;
pcval = Int_val(pc);
if (pcval >= 0)
gdImageArc(IM_VAL(gdw), Int_val(cx), Int_val(cy), Int_val(w), Int_val(h),
Int_val(s), Int_val(e), pseudoColors[pcval]);
else
gdImageArc(IM_VAL(gdw), Int_val(cx), Int_val(cy), Int_val(w), Int_val(h),
Int_val(s), Int_val(e), Int_val(c));
return Val_unit;
}
value ml_image_arc(value *argv, int argc) {
#ifdef SAFER
assert (argc == 9);
#endif
return
ml_image_arc_native(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
argv[6], argv[7], argv[8]);
}
value ml_image_carc_native(value gdw, value cx, value cy, value w,
value h, value s, value e, value c,
value pc, value nofill, value edged) {
int color, style, pcval;
pcval = Int_val(pc);
if (pcval >= 0) color = pseudoColors[pcval];
else color = Int_val(c);
style = gdArc;
if (Bool_val(nofill)) style |= gdNoFill;
if (Bool_val(edged)) style |= gdEdged;
gdImageFilledArc(IM_VAL(gdw), Int_val(cx), Int_val(cy), Int_val(w),
Int_val(h), Int_val(s), Int_val(e), color, style);
return Val_unit;
}
value ml_image_carc(value *argv, int argc) {
#ifdef SAFER
assert (argc == 11);
#endif
return
ml_image_carc_native(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
argv[6], argv[7], argv[8], argv[9], argv[10]);
}
value ml_image_cchord_native(value gdw, value cx, value cy, value w,
value h, value s, value e, value c,
value pc, value nofill, value edged) {
int color, style, pcval;
pcval = Int_val(pc);
if (pcval >= 0) color = pseudoColors[pcval];
else color = Int_val(c);
style = gdChord;
if (Bool_val(nofill)) style |= gdNoFill;
if (Bool_val(edged)) style |= gdEdged;
gdImageFilledArc(IM_VAL(gdw), Int_val(cx), Int_val(cy), Int_val(w),
Int_val(h), Int_val(s), Int_val(e), color, style);
return Val_unit;
}
value ml_image_cchord(value *argv, int argc) {
#ifdef SAFER
assert (argc == 11);
#endif
return
ml_image_cchord_native(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
argv[6], argv[7], argv[8], argv[9], argv[10]);
}
value ml_image_border_fill_native(value gdw, value x, value y, value b,
value c) {
gdImageFillToBorder(IM_VAL(gdw), Int_val(x), Int_val(y), Int_val(b),
Int_val(c));
return Val_unit;
}
value ml_image_border_fill(value *argv, int argc) {
#ifdef SAFER
assert (argc == 5);
#endif
return
ml_image_border_fill_native(argv[0], argv[1], argv[2], argv[3], argv[4]);
}
value ml_image_fill(value gdw, value x, value y, value c) {
gdImageFill(IM_VAL(gdw), Int_val(x), Int_val(y), Int_val(c));
return Val_unit;
}
value ml_image_char_native(value gdw, value font, value x, value y, value c,
value color) {
gdImageChar(IM_VAL(gdw), FONT_VAL(font), Int_val(x), Int_val(y), Int_val(c),
Int_val(color));
return Val_unit;
}
value ml_image_char(value *argv, int argc) {
#ifdef SAFER
assert (argc == 6);
#endif
return ml_image_char_native(argv[0], argv[1], argv[2], argv[3], argv[4],
argv[5]);
}
value ml_image_charu_native(value gdw, value font, value x, value y, value c,
value color) {
gdImageCharUp(IM_VAL(gdw), FONT_VAL(font), Int_val(x), Int_val(y), Int_val(c),
Int_val(color));
return Val_unit;
}
value ml_image_charu(value *argv, int argc) {
#ifdef SAFER
assert (argc == 6);
#endif
return ml_image_charu_native(argv[0], argv[1], argv[2], argv[3], argv[4],
argv[5]);
}
value ml_image_str_native(value gdw, value font, value x, value y, value s,
value color) {
gdImageString(IM_VAL(gdw), FONT_VAL(font), Int_val(x), Int_val(y),
String_val(s), Int_val(color));
return Val_unit;
}
value ml_image_str(value *argv, int argc) {
#ifdef SAFER
assert (argc == 6);
#endif
return ml_image_str_native(argv[0], argv[1], argv[2], argv[3], argv[4],
argv[5]);
}
value ml_image_stru_native(value gdw, value font, value x, value y, value s,
value color) {
gdImageStringUp(IM_VAL(gdw), FONT_VAL(font), Int_val(x), Int_val(y),
String_val(s), Int_val(color));
return Val_unit;
}
value ml_image_stru(value *argv, int argc) {
#ifdef SAFER
assert (argc == 6);
#endif
return ml_image_stru_native(argv[0], argv[1], argv[2], argv[3], argv[4],
argv[5]);
}
void raise_freetype_exception(char *msg) {
raise_with_string(*caml_named_value("gd freetype exception"), msg);
}
value ml_image_str_ft_base(gdImagePtr im, value fg, value fname, value size,
value angle, value x, value y, value string) {
#ifdef HAVE_FREETYPE
CAMLparam5(fg, fname, size, angle, x);
CAMLxparam2(y, string);
int brect[8];
int i;
char *rc;
CAMLlocal1(ml_brect);
ml_brect = alloc (8, 0);
rc = gdImageStringFT(im, brect, Int_val(fg), String_val(fname),
Double_val(size), Double_val(angle), Int_val(x),
Int_val(y), String_val(string));
if (rc != NULL) {
raise_freetype_exception (rc);
}
for (i = 0; i < 8; i++)
Store_field(ml_brect, i, Val_int(brect[i]));
CAMLreturn(ml_brect);
#else
raise_constant(*(value *)caml_named_value("gd type not supported"));
return Val_unit;
#endif
}
value ml_image_str_ft_native(value gdw, value fg, value fname, value size,
value angle, value x, value y, value string) {
CAMLparam5(gdw, fg, fname, size, angle);
CAMLxparam3(x, y, string);
CAMLreturn(ml_image_str_ft_base(IM_VAL(gdw), fg, fname, size, angle,
x, y, string));
}
value ml_image_str_ft(value *argv, int argc) {
#ifdef SAFER
assert (argc == 8);
#endif
return ml_image_str_ft_native(argv[0], argv[1], argv[2], argv[3],
argv[4], argv[5], argv[6], argv[7]);
}
value ml_image_ft_bbox_native(value fname, value size, value angle,
value x, value y, value string) {
CAMLparam5(fname, size, angle, x, y);
CAMLxparam1(string);
CAMLreturn(ml_image_str_ft_base(NULL, 0, fname, size, angle,
x, y, string));
}
value ml_image_ft_bbox(value *argv, int argc) {
#ifdef SAFER
assert (argc == 6);
#endif
return ml_image_ft_bbox_native(argv[0], argv[1], argv[2], argv[3],
argv[4], argv[5]);
}
value ml_image_str_ftex_base(gdImagePtr im, value fg, value fname, value size,
value angle, value x, value y, value flags,
value spacing, value charmap, value string) {
#ifdef HAVE_FREETYPE
int numflags, i;
int brect[8];
char *rc;
gdFTStringExtra extra;
CAMLparam5(fg, fname, size, angle, x);
CAMLxparam5(y, flags, spacing, charmap, string);
CAMLlocal1(ml_brect);
numflags = Wosize_val(flags);
for (i = 0; i < numflags; i++)
extra.flags |= ftExFlags[Int_val(Field(flags, i))];
extra.linespacing = Double_val(spacing);
extra.charmap = ftExCharmaps[Int_val(charmap)];
ml_brect = alloc (8, 0);
rc = gdImageStringFTEx(im, brect, Int_val(fg), String_val(fname),
Double_val(size), Double_val(angle), Int_val(x),
Int_val(y), String_val(string), &extra);
if (rc != NULL) {
raise_freetype_exception (rc);
}
for (i = 0; i < 8; i++)
Store_field(ml_brect, i, Val_int(brect[i]));
CAMLreturn(ml_brect);
#else
raise_constant(*(value *)caml_named_value("gd type not supported"));
return Val_unit;
#endif
}
value ml_image_str_ftex_native(value gdw, value fg, value fname, value size,
value angle, value x, value y, value flags,
value spacing, value charmap, value string) {
CAMLparam5(gdw, fg, fname, size, angle);
CAMLxparam5(x, y, flags, spacing, charmap);
CAMLxparam1(string);
CAMLreturn(ml_image_str_ftex_base(IM_VAL(gdw), fg, fname, size, angle,
x, y, flags, spacing, charmap, string));
}
value ml_image_str_ftex(value *argv, int argc) {
#ifdef SAFER
assert (argc == 11);
#endif
return ml_image_str_ftex_native(argv[0], argv[1], argv[2], argv[3],
argv[4], argv[5], argv[6], argv[7],
argv[8], argv[9], argv[10]);
}
value ml_image_ftex_bbox_native(value fname, value size, value angle,
value x, value y, value flags, value spacing,
value charmap, value string) {
CAMLparam5(fname, size, angle, x, y);
CAMLxparam4(flags, spacing, charmap, string);
CAMLreturn(ml_image_str_ftex_base(NULL, 0, fname, size, angle,
x, y, flags, spacing, charmap,
string));
}
value ml_image_ftex_bbox(value *argv, int argc) {
#ifdef SAFER
assert (argc == 9);
#endif
return ml_image_ftex_bbox_native(argv[0], argv[1], argv[2], argv[3],
argv[4], argv[5], argv[6], argv[7],
argv[8]);
}
value ml_set_pixel(value gdw, value x, value y, value c) {
gdImageSetPixel(IM_VAL(gdw), Int_val(x), Int_val(y), Int_val(c));
return Val_unit;
}
value ml_get_pixel(value gdw, value x, value y) {
return Val_int(gdImageGetPixel(IM_VAL(gdw), Int_val(x), Int_val(y)));
}
value ml_get_width(value gdw) {
return Val_int(gdImageSX(IM_VAL(gdw)));
}
value ml_get_height(value gdw) {
return Val_int(gdImageSY(IM_VAL(gdw)));
}
value ml_save_png(value gdw, value filename) {
FILE *out;
out = fopen(String_val(filename), "wb");
gdImagePng(IM_VAL(gdw), out);
fclose(out);
return Val_unit;
}
value ml_save_jpeg(value gdw, value filename, value quality) {
#ifdef HAVE_JPEG
FILE *out;
out = fopen(String_val(filename), "wb");
gdImageJpeg(IM_VAL(gdw), out, Int_val(quality));
fclose(out);
#else
raise_constant(*(value*)caml_named_value("gd type not supported"));
#endif
return Val_unit;
}
/* Taken from the ocaml source... */
struct channel;
void really_putblock (struct channel *, char *, long);
/* Extract a struct channel * from the heap object representing it */
#define Channel(v) (*((struct channel **) (Data_custom_val(v))))
value ml_dump_png(value gdw, value chan) {
int size;
void* dat;
dat = gdImagePngPtr(IM_VAL(gdw), &size);
really_putblock(Channel(chan), dat, size);
free(dat);
return Val_unit;
}
value ml_dump_jpeg(value gdw, value chan, value quality) {
#ifdef HAVE_JPEG
int size;
void* dat;
dat = gdImageJpegPtr(IM_VAL(gdw), &size, Int_val(quality));
really_putblock(Channel(chan), dat, size);
free(dat);
#else
raise_constant(*(value*)caml_named_value("gd type not supported"));
#endif
return Val_unit;
}
value ml_image_set_antialiased(value gdw, value c) {
gdImageSetAntiAliased(IM_VAL(gdw), Int_val(c));
return Val_unit;
}
value ml_image_set_antialiased_dont_blend(value gdw, value aa, value db) {
gdImageSetAntiAliasedDontBlend(IM_VAL(gdw), Int_val(aa), Int_val(db));
return Val_unit;
}
value ml_image_set_brush(value gdw, value br) {
gdImageSetBrush(IM_VAL(gdw), IM_VAL(br));
return Val_unit;
}
value ml_image_set_tile(value gdw, value t) {
gdImageSetTile(IM_VAL(gdw), IM_VAL(t));
return Val_unit;
}
value ml_image_set_thickness(value gdw, value t) {
gdImageSetThickness(IM_VAL(gdw), Int_val(t));
return Val_unit;
}
value ml_image_set_clip(value gdw, value x1, value y1, value x2, value y2) {
gdImageSetClip(IM_VAL(gdw), Int_val(x1), Int_val(y1),
Int_val(x2), Int_val(y2));
return Val_unit;
}
value ml_image_color_alloc(value gdw, value r, value g, value b) {
int color;
color = gdImageColorAllocate(IM_VAL(gdw), Int_val(r), Int_val(g), Int_val(b));
return Val_int(color);
}
value ml_image_color_closest(value gdw, value r, value g, value b) {
int color;
color = gdImageColorClosest(IM_VAL(gdw), Int_val(r), Int_val(g), Int_val(b));
return Val_int(color);
}
value ml_image_color_closest_hwb(value gdw, value r, value g, value b) {
int color;
color =
gdImageColorClosestHWB(IM_VAL(gdw), Int_val(r), Int_val(g), Int_val(b));
return Val_int(color);
}
value ml_image_color_exact(value gdw, value r, value g, value b) {
int color;
color = gdImageColorExact(IM_VAL(gdw), Int_val(r), Int_val(g), Int_val(b));
return Val_int(color);
}
value ml_image_color_resolve(value gdw, value r, value g, value b) {
int color;
color = gdImageColorResolve(IM_VAL(gdw), Int_val(r), Int_val(g), Int_val(b));
return Val_int(color);
}
value ml_image_red_channel(value gdw, value c) {
return Val_int(gdImageRed(IM_VAL(gdw), Int_val(c)));
}
value ml_image_green_channel(value gdw, value c) {
return Val_int(gdImageGreen(IM_VAL(gdw), Int_val(c)));
}
value ml_image_blue_channel(value gdw, value c) {
return Val_int(gdImageBlue(IM_VAL(gdw), Int_val(c)));
}
value ml_image_alpha_channel(value gdw, value c) {
return Val_int(gdImageAlpha(IM_VAL(gdw), Int_val(c)));
}
value ml_image_get_transparent(value gdw) {
return Val_int(gdImageGetTransparent(IM_VAL(gdw)));
}
value ml_image_set_transparent(value gdw, value c) {
gdImageColorTransparent(IM_VAL(gdw), Int_val(c));
return Val_unit;
}
/* ================================================================== */
/* ============ Image Copying and Resizing Functions ================ */
/* ================================================================== */
value ml_image_copy_native(value dst, value src, value dst_x, value dst_y,
value src_x, value src_y, value w, value h) {
gdImageCopy(IM_VAL(dst), IM_VAL(src), Int_val(dst_x), Int_val(dst_y),
Int_val(src_x), Int_val(src_y), Int_val(w), Int_val(h));
return Val_unit;
}
value ml_image_copy(value *argv, int argc) {
#ifdef SAFER
assert (argc == 8);
#endif
return
ml_image_copy_native(argv[0], argv[1], argv[2], argv[3], argv[4],
argv[5], argv[6], argv[7]);
}
value ml_image_copy_resized_native(value dst, value src, value dst_x,
value dst_y, value src_x, value src_y,
value dst_w, value dst_h, value src_w,
value src_h) {
gdImageCopyResized(IM_VAL(dst), IM_VAL(src), Int_val(dst_x),
Int_val(dst_y), Int_val(src_x), Int_val(src_y),
Int_val(dst_w), Int_val(dst_h), Int_val(src_w),
Int_val(src_h));
return Val_unit;
}
value ml_image_copy_resized(value *argv, int argc) {
#ifdef SAFER
assert (argc == 10);
#endif
return
ml_image_copy_resized_native(argv[0], argv[1], argv[2], argv[3],
argv[4], argv[5], argv[6], argv[7],
argv[8], argv[9]);
}
value ml_image_copy_resampled_native(value dst, value src, value dst_x,
value dst_y, value src_x, value src_y,
value dst_w, value dst_h, value src_w,
value src_h) {
gdImageCopyResampled(IM_VAL(dst), IM_VAL(src), Int_val(dst_x),
Int_val(dst_y), Int_val(src_x), Int_val(src_y),
Int_val(dst_w), Int_val(dst_h), Int_val(src_w),
Int_val(src_h));
return Val_unit;
}
value ml_image_copy_resampled(value *argv, int argc) {
#ifdef SAFER
assert (argc == 10);
#endif
return
ml_image_copy_resampled_native(argv[0], argv[1], argv[2], argv[3],
argv[4], argv[5], argv[6], argv[7],
argv[8], argv[9]);
}
value ml_image_copy_rotated_native(value dst, value src, value dst_x,
value dst_y, value src_x, value src_y,
value w, value h, value angle) {
gdImageCopyRotated(IM_VAL(dst), IM_VAL(src), Double_val(dst_x),
Double_val(dst_y), Int_val(src_x), Int_val(src_y),
Int_val(w), Int_val(h), Int_val(angle));
return Val_unit;
}
value ml_image_copy_rotated(value *argv, int argc) {
#ifdef SAFER
assert (argc == 9);
#endif
return
ml_image_copy_rotated_native(argv[0], argv[1], argv[2], argv[3],
argv[4], argv[5], argv[6], argv[7],
argv[8]);
}
value ml_image_copy_merge_native(value dst, value src, value dst_x,
value dst_y, value src_x, value src_y,
value w, value h, value pct) {
gdImageCopyMerge(IM_VAL(dst), IM_VAL(src), Int_val(dst_x), Int_val(dst_y),
Int_val(src_x), Int_val(src_y), Int_val(w), Int_val(h),
Int_val(pct));
return Val_unit;
}
value ml_image_copy_merge(value *argv, int argc) {
#ifdef SAFER
assert (argc == 9);
#endif
return
ml_image_copy_merge_native(argv[0], argv[1], argv[2], argv[3],
argv[4], argv[5], argv[6], argv[7],
argv[8]);
}
value ml_image_copy_merge_gray_native(value dst, value src, value dst_x,
value dst_y, value src_x, value src_y,
value w, value h, value pct) {
gdImageCopyMergeGray(IM_VAL(dst), IM_VAL(src), Int_val(dst_x),
Int_val(dst_y), Int_val(src_x), Int_val(src_y),
Int_val(w), Int_val(h), Int_val(pct));
return Val_unit;
}
value ml_image_copy_merge_gray(value *argv, int argc) {
#ifdef SAFER
assert (argc == 9);
#endif
return
ml_image_copy_merge_gray_native(argv[0], argv[1], argv[2], argv[3],
argv[4], argv[5], argv[6], argv[7],
argv[8]);
}
value ml_image_palette_copy(value dst, value src) {
gdImagePaletteCopy(IM_VAL(dst), IM_VAL(src));
return Val_unit;
}
gd4o-1.0~alpha5/gdtest.ml 0000664 0000000 0000000 00000050164 11644321154 0015333 0 ustar 00root root 0000000 0000000 (* $Header: /home/cvs/gd4o/gdtest.ml,v 1.7 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
*)
open Gd;;
let write_header ch title desc =
output_string ch ("************************************" ^
"************************************\n\n");
output_string ch (title ^ ":\n");
output_string ch (desc ^ "\n\n");
output_string ch ("------------------------------------" ^
"------------------------------------\n\n\n")
let write_footer ch msg =
output_string ch ("\n\n" ^ msg ^ "\n");
output_string ch ("====================================" ^
"====================================\n\n\n")
let ok n msg = " " ^ string_of_int n ^ ": [--OK--]: " ^ msg ^ "\n"
let failed n msg = " " ^ string_of_int n ^ ": [FAILED]: " ^ msg ^ "\n"
let skiplineRE = Str.regexp "^\\([ \t]*#.*\\|[ \t]*\\)$"
let deg2rad = ( *. ) (3.1415926535 /. 180.)
let tempdir =
try
Sys.getenv "TMP"
with Not_found ->
begin
try
Sys.getenv "TEMP"
with Not_found ->
if Sys.file_exists "/tmp" then "/tmp"
else if Sys.file_exists "/var/tmp" then "/var/tmp"
else Sys.getcwd ()
end;;
let shapes_test msg_ch =
write_header msg_ch "SHAPES"
( "Create an image displaying various interesting shapes.\n" ^
"Save output as 'shapes_test.png'.");
let msg = output_string msg_ch in
let img =
try
let i = create 512 384 in
msg (ok 1 "created image");
i
with _ -> failwith "Failed to create image." in
let ca =
try
let c = img#colors in
msg (ok 2 "obtained color allocator instance");
c
with _ -> failwith "Failed to get color allocator." in
let white =
try
let w = ca#white in
msg (ok 3 "allocated white");
w
with _ -> failwith "Failed to get white."
and ltblue, maroon, orange, aqua, grey, brown =
try
let more =
ca#create 127 127 255, ca#create 127 0 0, ca#create 191 127 0,
ca#create 0 153 204, ca#create 153 153 153, ca#create 127 127 0 in
msg (ok 4 "allocated additional colors");
more
with _ -> failwith "Failed to create additional colors." in
begin
try
img#rectangle 10 10 180 140 maroon;
msg (ok 5 "drew outline rectangle")
with _ -> msg (failed 5 "Failed to draw outline rectangle.")
end;
begin
try
img#filled_rectangle 50 40 220 170 ltblue;
msg (ok 6 "drew filled rectangle")
with _ -> msg (failed 6 "Failed to draw filled rectangle.")
end;
begin
try
img#set_antialiased aqua;
begin
try
img#arc ~cx:108 ~cy:276 ~w:192 ~h:128 ~s:0 ~e:270
~pseudo:(ca#antialiased ()) aqua;
msg (ok 7 "drew partial outline arc with antialiased pseudocolor")
with _ -> msg (failed 7 "Failed to draw partial outline arc.")
end
with _ -> msg (failed 7 "Failed to set antialiased color.")
end;
begin
try
img#filled_ellipse 144 300 192 128 grey;
msg (ok 8 "drew filled ellipse")
with _ -> msg (failed 8 "Failed to draw filled ellipse.")
end;
begin
try
img#set_antialiased brown;
begin
try
img#polygon
~pts:[|280,80;340,32;440,48;440,144;360,144;280,108;280,80|]
~pseudo:(ca#antialiased ()) brown;
msg (ok 9 "drew outline polygon with antialiased pseudocolor")
with _ -> msg (failed 9 "Failed to draw polygon.")
end
with _ -> msg (failed 9 "Failed to set antialiased color.")
end;
begin
try
img#filled_polygon
[|320,110;380,62;480,78;480,174;400,174;320,138;320,110|] orange;
msg (ok 10 "drew filled polyon")
with _ -> msg (failed 10 "Failed to draw filled polygon.")
end;
begin
try
img#string
~x:244 ~y:228 ~font:Gd.Font.giant
~s:"As I was coming up the stair," orange;
msg (ok 11 "drew string 1")
with _ -> msg (failed 11 "Failed to draw string 1.")
end;
begin
try
img#string
~x:254 ~y:260 ~font:Gd.Font.large
~s:"I met a man who wasn't there." grey;
msg (ok 12 "drew string 2")
with _ -> msg (failed 12 "Failed to draw string 2.")
end;
begin
try
img#string
~x:264 ~y:290 ~font:Gd.Font.medium
~s:"He wasn't there again today!" aqua;
msg (ok 13 "drew string 3")
with _ -> msg (failed 13 "Failed to draw string 3.")
end;
begin
try
img#string
~x:274 ~y:318 ~font:Gd.Font.small
~s:"I wish, I wish, he'd go away." maroon;
msg (ok 14 "drew string 4")
with _ -> msg (failed 14 "Failed to draw string 4.")
end;
img#save_as_png (Filename.concat tempdir "shapes_test.png");
write_footer msg_ch "END SHAPES"
let color_allocation_test msg_ch =
write_header msg_ch "COLOR ALLOCATION"
("Create an 8-bit image and a truecolor image, and attempt to allocate\n"^
"a large number of colors in each. The test should fail at index 256 \n"^
"for the 8-bit image, and should *not* fail for the truecolor image.");
let msg = output_string msg_ch in
let rgbvals = [|0; 31; 63; 95; 127; 159; 191; 223; 255|] in
let numvals = Array.length rgbvals in
let last = numvals - 1 in
let do_colors img is_tc testno =
let (ca : color_allocator) = img#colors
and index = ref 0 in
try
for r = 0 to last do
for g = 0 to last do
for b = 0 to last do
index := (r * numvals * numvals + g * numvals + b);
ignore (ca#create rgbvals.(r) rgbvals.(g) rgbvals.(b))
done;
done;
done;
if is_tc then
msg (ok testno "Truecolor - all colors successfully allocated.")
else
msg (failed testno "8bit - too many colors allocated without error.")
with
| Too_many_colors ->
if is_tc then
msg (failed testno ("Truecolor - failed at index " ^
string_of_int !index ^ ".")) else
if !index = 256 then
msg (ok testno "8bit - failed at index 256.")
else
msg (failed testno ("8bit - failed at index " ^
string_of_int !index ^ "."))
| _ ->
if is_tc then msg (failed testno ("Truecolor - unknown exception " ^
"at index " ^
string_of_int !index ^ "."))
else msg (failed testno ("8bit - unknown exception at index " ^
string_of_int !index ^ ".")) in
do_colors (create 256 256) false 1;
do_colors (create_truecolor 256 256) true 2;
write_footer msg_ch "END COLOR ALLOCATION"
let copy_resize_test msg_ch =
write_header msg_ch "COPYING AND RESIZING"
( "Test copying and resizing functions.\n" ^
"1. Copy a small image into a larger image with 'copy'.\n" ^
"2. Copy a portion of an image into a larger image with 'copy'.\n" ^
"3. Copy a small image into a larger image with 'copy_resized'.\n" ^
"4. Copy a small image into a larger image with 'copy_resampled'.\n" ^
" Compare the output with that of test #2; details should be\n" ^
" smoother.\n" ^
"5. Copy a small image into a larger image with 'copy_rotated'.\n" ^
"6. Copy a small image into a larger image with 'copy_merge'.\n" ^
"7. Copy a small image into a larger image with 'copy_merge_gray'.\n" ^
"8. Create a new image, copy the palette from an existing image,\n" ^
" then copy the contents of the second image. If the palette is\n" ^
" copied correctly, this should produce a copy whose colors and\n" ^
" dimensions are identical to the original.\n");
let msg = output_string msg_ch in
let indexed_img1 = "yotei02-8.png"
and truecolor_img1 = "yotei02-t.png"
and indexed_img2 = "driver01-8.png"
and truecolor_img2 = "driver01-t.png"
and indexed_img3 = "kamokamogawa04-8.png"
and truecolor_img3 = "kamokamogawa04-t.png" in
let img_path name =
Filename.concat "." (Filename.concat "samples" name) in
let get_dims dst src = dst#width, dst#height, src#width, src#height in
let test1 img1 img2 =
let dst = open_png (img_path img1)
and src = open_png (img_path img2) in
try
let outfile = "copy.png" in
let dw, dh, sw, sh = get_dims dst src in
dst#copy src ~x:((dw - sw) / 2) ~y:((dh - sh) / 2)
~src_x:0 ~src_y:0 ~w:sw ~h:sh;
dst#save_as_png (Filename.concat tempdir outfile);
msg (ok 1 ("Saved " ^ outfile ^ "."))
with _ ->
msg (failed 1 "image#copy test failed.")
and test2 img1 img2 =
let dst = open_png (img_path img1)
and src = open_png (img_path img2) in
try
let outfile = "copy(crop).png" in
let dw, dh, sw, sh = get_dims dst src in
let crop_x = int_of_float ((float_of_int sw) *. 0.35)
and crop_y = int_of_float ((float_of_int sh) *. 0.35) in
dst#copy src ~x:(dw / 2) ~y:(dh / 2)
~src_x:crop_x ~src_y:crop_y ~w:(sw / 2) ~h:(sh / 2);
dst#save_as_png (Filename.concat tempdir outfile);
msg (ok 2 ("Saved " ^ outfile ^ "."))
with _ ->
msg (failed 2 "image#copy cropping test failed.")
and test3 img1 img2 =
let dst = open_png (img_path img1)
and src = open_png (img_path img2) in
try
let outfile = "copy_resized.png" in
let dw, dh, sw, sh = get_dims dst src in
let new_w = (int_of_float ((float_of_int sw) *. 0.75))
and new_h = (int_of_float ((float_of_int sh) *. 1.1)) in
dst#copy_resized src ~x:((dw - new_w) / 2) ~y:((dh - new_h) / 2)
~src_x:0 ~src_y:0 ~src_w:sw ~src_h:sh ~w:new_w ~h:new_h;
dst#save_as_png (Filename.concat tempdir outfile);
msg (ok 3 ("Saved " ^ outfile ^ "."))
with _ ->
msg (failed 3 "image#copy_resized test failed.")
and test4 img1 img2 =
let dst = open_png (img_path img1)
and src = open_png (img_path img2) in
try
let outfile = "copy_resampled.png" in
let dw, dh, sw, sh = get_dims dst src in
let new_w = (int_of_float ((float_of_int sw) *. 0.75))
and new_h = (int_of_float ((float_of_int sh) *. 1.1)) in
dst#copy_resampled src ~x:((dw - new_w) / 2) ~y:((dh - new_h) / 2)
~src_x:0 ~src_y:0 ~src_w:sw ~src_h:sh ~w:new_w ~h:new_h;
dst#save_as_png (Filename.concat tempdir outfile);
msg (ok 4 ("Saved " ^ outfile ^ "."))
with _ ->
msg (failed 4 "image#copy_resampled test failed.")
and test5 img1 img2 =
let dst = open_png (img_path img1)
and src = open_png (img_path img2) in
try
let outfile = "copy_rotated.png" in
let dw, dh, sw, sh = get_dims dst src in
let cx = (float_of_int dw) /. 2.
and cy = (float_of_int dh) /. 2. in
dst#copy src ~x:((dw - sw) / 2) ~y:((dh - sh) / 2)
~src_x:0 ~src_y:0 ~w:sw ~h:sh;
dst#copy_rotated src ~x:cx ~y:cy
~src_x:0 ~src_y:0 ~w:sw ~h:sh ~angle:30;
dst#copy_rotated src ~x:cx ~y:cy
~src_x:0 ~src_y:0 ~w:sw ~h:sh ~angle:60;
dst#copy_rotated src ~x:cx ~y:cy
~src_x:0 ~src_y:0 ~w:sw ~h:sh ~angle:90;
dst#save_as_png (Filename.concat tempdir outfile);
msg (ok 5 ("Saved " ^ outfile ^ "."))
with _ ->
msg (failed 5 "image#copy_rotated test failed.")
and test6 img =
let src = open_png (img_path img) in
let sw = src#width
and sh = src#height in
let dw = sw * 2
and dh = sh * 2 in
let dst = create ~x:dw ~y:dh in
try
let outfile = "copy_merge.png" in
let dw, dh, sw, sh = get_dims dst src in
let ca = dst#colors in
ignore (ca#create 0 204 153);
dst#copy_merge src ~x:((dw - sw) / 2) ~y:((dh - sh) / 2)
~src_x:0 ~src_y:0 ~w:sw ~h:sh ~pct:50;
dst#save_as_png (Filename.concat tempdir outfile);
msg (ok 6 ("Saved " ^ outfile ^ "."))
with _ ->
msg (failed 6 "image#copy_merge test failed.")
and test7 img =
let src = open_png (img_path img) in
let sw = src#width
and sh = src#height in
let dw = sw * 2
and dh = sh * 2 in
let dst = create ~x:dw ~y:dh in
try
let outfile = "copy_merge_gray.png" in
let dw, dh, sw, sh = get_dims dst src in
let ca = dst#colors in
ignore (ca#create 0 204 153);
dst#copy_merge_gray src ~x:((dw - sw) / 2) ~y:((dh - sh) / 2)
~src_x:0 ~src_y:0 ~w:sw ~h:sh ~pct:50;
dst#save_as_png (Filename.concat tempdir outfile);
msg (ok 7 ("Saved " ^ outfile ^ "."))
with _ ->
msg (failed 7 "image#copy_merge_gray test failed.")
and test8 img =
let src = open_png (img_path img) in
let sw = src#width
and sh = src#height in
let dw = sw
and dh = sh in
let dst = create ~x:dw ~y:dh in
try
let outfile = "palette_copy.png" in
let dw, dh, sw, sh = get_dims dst src in
dst#palette_copy src;
dst#copy src ~x:0 ~y:0 ~src_x:0 ~src_y:0 ~w:sw ~h:sh;
dst#save_as_png (Filename.concat tempdir outfile);
msg (ok 8 ("Saved " ^ outfile ^ "."))
with _ ->
msg (failed 8 "image#palette_copy test failed.") in
test1 indexed_img1 indexed_img2;
test2 indexed_img1 indexed_img2;
test3 truecolor_img1 indexed_img2;
test4 truecolor_img1 indexed_img2;
test5 truecolor_img1 truecolor_img2;
test6 indexed_img2;
test7 indexed_img2;
test8 indexed_img3;
write_footer msg_ch "END COPYING AND RESIZING"
let io_test msg_ch =
write_header msg_ch "INPUT/OUTPUT"
( "Test loading and saving functions.\n" ^
"1. Save to PNG with 'save_to_png'.\n" ^
"2. Save to JPEG with 'save_to_jpeg,' quality 100.\n" ^
"3. Save to JPEG with 'save_to_jpeg,' quality 60.\n" ^
"4. Save to PNG with 'open_out' -> 'out_as_png'.\n" ^
"5. Save to JPEG with 'open_out' -> 'out_as_jpeg'.\n");
let msg = output_string msg_ch in
let draw () =
let img = create 256 256 in
let ca = img#colors in
let white = ca#white
and red = ca#create 255 0 0
and black = ca#black in
img#filled_ellipse 64 64 100 100 red;
img#filled_ellipse 192 64 100 100 black;
img#filled_ellipse 64 192 100 100 black;
img#filled_ellipse 192 192 100 100 red;
img in
let fname = (Filename.concat tempdir "io_test-d.png")
and im = draw () in
begin
try
im#save_as_png fname;
msg (ok 1 "Saved " ^ fname)
with _ -> msg (failed 1 "Failed to save " ^ fname)
end;
let fname = Filename.concat tempdir "io_test-d-100.jpg"
and im = draw () in
begin
try
im#save_as_jpeg ~quality:100 fname;
msg (ok 2 "Saved " ^ fname);
with _ -> msg (failed 2 "Failed to save " ^ fname)
end;
let fname = Filename.concat tempdir "io_test-d-60.jpg"
and im = draw () in
begin
try
im#save_as_jpeg ~quality:60 fname;
msg (ok 3 "Saved " ^ fname);
with _ -> msg (failed 3 "Failed to save " ^ fname)
end;
let fname = Filename.concat tempdir "io_test-i.png"
and im = draw ()
and oc = open_out fname in
begin
try
im#out_as_png oc;
msg (ok 4 "Saved " ^ fname);
with _ -> msg (failed 4 "Failed to save " ^ fname)
end;
close_out oc;
let fname = Filename.concat tempdir "io_test-i.jpg"
and im = draw ()
and oc = open_out fname in
begin
try
im#out_as_jpeg oc;
msg (ok 5 "Saved " ^ fname);
with _ -> msg (failed 5 "Failed to save " ^ fname)
end;
close_out oc;
write_footer msg_ch "END INPUT/OUTPUT"
let ft_test msg_ch fonts =
try
let [ f1; f2; f3; f4 ] = fonts in
write_header msg_ch "TRUETYPE FONT RENDERING"
( "Test of #image#string_ft. Create an image with a white\n" ^
"background and four strings with the following properties:\n" ^
" 1. 24pt, blue, start at x:60,y:236, slopes upward 30 deg.\n" ^
" 2. 18pt, grey, start at x:60,y:272\n" ^
" 3. 12pt, red, start at x:60,y:96\n" ^
" 4. 8pt, black, start at x:60,y:316\n" ^
"Save output as 'ft_test.png'.");
let msg = output_string msg_ch in
let im = create 512 384 in
let ca = im#colors in
let white = ca#white
and black = ca#black
and grey = ca#create 153 153 153
and red = ca#create 204 0 0
and blue = ca#create 47 47 255 in
ignore (im#string_ft blue f1 24.0 (deg2rad 30.) 60 236
"As I was coming up the stair,");
msg (ok 1 "Rendered first string.");
ignore (im#string_ft grey f2 18.0 0.0 60 272
"I met a man who wasn't there.");
msg (ok 2 "Rendered second string.");
ignore (im#string_ft red f3 12.0 0.0 60 296
"He wasn't there again today!");
msg (ok 3 "Rendered third string.");
ignore (im#string_ft black f4 8.0 0.0 60 316
"I wish, I wish, he'd go away.");
msg (ok 4 "Rendered fourth string.");
im#save_as_png (Filename.concat tempdir "ft_test.png");
write_footer msg_ch "END TRUETYPE FONT RENDERING"
with Match_failure _ ->
prerr_endline
"The TrueType font test requires a list of four font files."
let ftex_test msg_ch fonts =
try
let fnt = List.hd fonts in
write_header msg_ch "TRUETYPE FONT EXTENDED RENDERING"
( "Test of #image#string_ftex. Create an image with a white\n" ^
"background and a four-line poem in black 14pt type, widely\n" ^
"spaced (2.5 * line height); save output as 'ftex_test.png'.");
let msg = output_string msg_ch in
let im = create 512 384 in
let ca = im#colors in
let white = ca#white
and black = ca#black in
let poem = ( "As I was coming up the stair,\n" ^
"I met a man who wasn't there.\n" ^
"He wasn't there again today!\n" ^
"I wish, I wish he'd go away." ) in
ignore (im#string_ftex ~fg:black ~fname:fnt ~size:14.0 ~angle:0.0
~x:100 ~y:80 ~flags:[|FTExSetSpacing|] ~spacing:2.5 poem);
msg (ok 1 "Rendered poem.");
im#save_as_png (Filename.concat tempdir "ftex_test.png");
msg (ok 2 "Saved to 'ftex_test.png'");
write_footer msg_ch "END TRUETYPE FONT EXTENDED RENDERING"
with Match_failure _ ->
prerr_endline
"The TrueType font test requires a list of four font files."
let ft_tests msg_ch =
let rec getfonts ch fnts =
if List.length fnts >= 4 then fnts
else
( try
let line = input_line ch in
if Str.string_match skiplineRE line 0 then
getfonts ch fnts
else
getfonts ch (line :: fnts)
with End_of_file -> fnts ) in
if Sys.file_exists "font.list" then
let ic = open_in "font.list" in
let fonts = List.rev (getfonts ic []) in
close_in ic;
ft_test msg_ch fonts;
ftex_test msg_ch fonts
else
prerr_endline
( "IMPORTANT: if you wish to run the TrueType font rendering tests,\n" ^
"you must have a file named 'font.list' which contains the full\n" ^
"pathnames of four font files that exist on your system. For an\n" ^
"example, see 'font_list.txt'" )
let test msg_ch =
color_allocation_test msg_ch;
shapes_test msg_ch;
copy_resize_test msg_ch;
io_test msg_ch;
ft_tests msg_ch
let _ =
prerr_endline ("::::::::::::::::::::::::::::::::::::" ^
"::::::::::::::::::::::::::::::::::::");
prerr_endline ("Starting tests. Files will be saved in " ^ tempdir ^ ".");
prerr_endline ("::::::::::::::::::::::::::::::::::::" ^
"::::::::::::::::::::::::::::::::::::");
if Array.length Sys.argv >= 2 then
let logfile = Sys.argv.(1) in
let msgchannel = open_out logfile in
test msgchannel;
prerr_endline ("Tests completed. For details, see " ^ logfile ^ ".");
close_out msgchannel
else
begin
test stderr;
prerr_endline "Tests completed."
end
gd4o-1.0~alpha5/samples/ 0000775 0000000 0000000 00000000000 11644321154 0015145 5 ustar 00root root 0000000 0000000 gd4o-1.0~alpha5/samples/driver01-8.png 0000664 0000000 0000000 00000106050 11644321154 0017456 0 ustar 00root root 0000000 0000000 PNG
IHDR s^ PLTE٧{st]X_LJK<>>!%-
ӨȖvgpwǕ
˨~^|A/afL}$M1&XS=q=*.
hdۡmB= CyOG강3(1;$(Z2<ٰ\Mlu\xƠ
!O=Z٧
/C/?/MěiMOh-'j/W
岥բϮ
s#,|vL,9͚ݩ!!o{۶ਫ਼.acZ /xӜ=%G
t
D67ۡa4[\Ld
XDEӲ؝sfzЌިРonFosylQb/2u^kƕ@,>~R}
ݯ,5kTPY=[ߩss֔O5^P%)I-N|f_ɩƋ=$5pRm$}4(HҠ
bx!˛_Cnب½xnSۘ%7FR3 'lTz`L^bEIK:R᪑""6!3Ѡ+*tsӴߠU