This is the mail archive of the guile@cygnus.com mailing list for the guile project.
| Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
|---|---|---|
| Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |
Jim-
Here is a gd library interface for guile. I have not packaged it up
properly, but the guts are most definitely there. If there is anyone
that wishes to take this code and run with it, great.
-russ
/*
Copyright (C) 1998 Russ McManus
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
#include <gd.h>
#include <gdfontg.h>
#include <gdfontl.h>
#include <gdfontmb.h>
#include <gdfonts.h>
#include <gdfontt.h>
#include <guile/gh.h>
#include <gh_extra.h>
#include <stdio.h>
#include <errno.h>
#include <stdlib.h>
static struct {
long gd_image_type_tag;
long gd_font_type_tag;
} g;
/*
* image boxing, unboxing, type testing, sweeping, and printing
*/
static SCM
gd_image_box(gdImagePtr i)
{
SCM obj;
SCM_DEFER_INTS;
SCM_NEWCELL(obj);
SCM_SETCAR(obj, g.gd_image_type_tag);
SCM_SETCDR(obj, i);
SCM_ALLOW_INTS;
return obj;
}
static gdImagePtr
gd_image_unbox(SCM obj)
{
return ((gdImagePtr)SCM_CDR(obj));
}
static int
gd_image_p(SCM x)
{
return (SCM_NIMP(x) && SCM_CAR(x) == g.gd_image_type_tag);
}
static scm_sizet
gd_image_free(SCM obj)
{
gdImagePtr ip = gd_image_unbox(obj);
gdImageDestroy(ip);
return 0;
}
static int
gd_image_print(SCM obj, SCM port, scm_print_state *pstate)
{
scm_gen_puts(scm_regular_string, "#<gd-image ", port);
scm_intprint(obj, 16, port);
scm_gen_putc('>', port);
return 1;
}
/*
* font boxing, unboxing, type testing, sweeping, and printing.
*/
gdFontPtr
gd_font_unbox(SCM obj)
{
return ((gdFontPtr)SCM_CDR(obj));
}
SCM
gd_font_box(gdFontPtr f)
{
SCM obj;
SCM_DEFER_INTS;
SCM_NEWCELL(obj);
SCM_SETCAR(obj, g.gd_font_type_tag);
SCM_SETCDR(obj, f);
SCM_ALLOW_INTS;
return obj;
}
int
gd_font_p(SCM x)
{
return (SCM_NIMP(x) && SCM_CAR(x) == g.gd_font_type_tag);
}
scm_sizet
gd_font_free(SCM obj)
{
gdFontPtr fp = gd_font_unbox(obj);
(void)fp;
/* no destroy function for fonts? */
return 0;
}
int
gd_font_print(SCM obj, SCM port, scm_print_state *pstate)
{
scm_gen_puts(scm_regular_string, "#<gd-font ", port);
scm_intprint(obj, 16, port);
scm_gen_putc('>', port);
return 1;
}
/*
* gc functions for smobs
*/
SCM
gd_mark(SCM obj)
{
#if 0
if (SCM_GC8MARKP(obj)) {
return SCM_BOOL_F;
}
SCM_SETGC8MARK(obj);
#endif
return SCM_BOOL_F;
}
/*
* implementation of primitives
*/
SCM_PROC(s_gd_image_interlace, "gd:image-interlace", 1, 0, 0, scm_gd_image_interlace);
static SCM
scm_gd_image_interlace(SCM im)
{
SCM_ASSERT(gd_image_p(im), im, SCM_ARG1, s_gd_image_interlace);
SCM_DEFER_INTS;
gdImageInterlace(gd_image_unbox(im), 1);
SCM_ALLOW_INTS;
return SCM_BOOL_T;
}
SCM_PROC(s_gd_image_set_style, "gd:image-set-style", 2, 0, 0, scm_gd_image_set_style);
static SCM
scm_gd_image_set_style(SCM im, SCM vect)
{
int i, n, *style;
SCM_ASSERT(gd_image_p(im), im, SCM_ARG1, s_gd_image_set_style);
SCM_ASSERT((SCM_NIMP(vect) && SCM_VECTORP(vect)), vect, SCM_ARG2, s_gd_image_set_style);
n = SCM_INUM(scm_vector_length(vect));
for (i=0; i<n; i++) {
SCM x = scm_vector_ref(vect, SCM_MAKINUM(i));
if (SCM_NINUMP(x)) {
scm_misc_error(s_gd_image_set_style,
"bad style spec at index %s: %s",
scm_listify(SCM_MAKINUM(i), x, SCM_UNDEFINED));
}
}
SCM_DEFER_INTS;
style = (int*)scm_must_malloc(sizeof(int)*n, s_gd_image_set_style);
for (i=0; i<n; i++) {
style[i] = SCM_INUM(scm_vector_ref(vect, SCM_MAKINUM(i)));
}
gdImageSetStyle(gd_image_unbox(im), style, n);
free(style);
SCM_ALLOW_INTS;
return SCM_BOOL_T;
}
SCM_PROC(s_gd_image_filled_polygon, "gd:image-filled-polygon", 3, 0, 0, scm_gd_image_filled_polygon);
static SCM
scm_gd_image_filled_polygon(SCM im, SCM vect, SCM color)
{
int i,n;
gdPoint *points;
SCM_ASSERT(gd_image_p(im), im, SCM_ARG1, s_gd_image_filled_polygon);
SCM_ASSERT(scm_vector_p(vect), vect, SCM_ARG2, s_gd_image_filled_polygon);
SCM_ASSERT(SCM_INUMP(color), color, SCM_ARG3, s_gd_image_filled_polygon);
n = SCM_INUM(scm_vector_length(vect));
for (i=0; i<n; i++) {
SCM pair = scm_vector_ref(vect, SCM_MAKINUM(i));
if (!scm_pair_p(pair) ||
SCM_NINUMP(SCM_CAR(pair)) ||
SCM_NINUMP(SCM_CDR(pair))) {
scm_misc_error(s_gd_image_filled_polygon,
"bad point spec at index %s: %s",
scm_listify(SCM_MAKINUM(i), pair, SCM_UNDEFINED));
}
}
SCM_DEFER_INTS;
points = (gdPoint*)scm_must_malloc(n*sizeof(gdPoint), s_gd_image_filled_polygon);
for (i=0; i<n; i++) {
SCM pair = scm_vector_ref(vect, SCM_MAKINUM(i));
points[i].x = SCM_INUM(SCM_CAR(pair));
points[i].y = SCM_INUM(SCM_CDR(pair));
}
gdImageFilledPolygon(gd_image_unbox(im),
points,
n,
SCM_INUM(color));
free(points);
SCM_ALLOW_INTS;
return SCM_BOOL_T;
}
SCM_PROC(s_gd_image_fill, "gd:image-fill", 4, 0, 0, scm_gd_image_fill);
static SCM
scm_gd_image_fill(SCM im, SCM x, SCM y, SCM color)
{
SCM_ASSERT(gd_image_p(im), im, SCM_ARG1, s_gd_image_fill);
SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG2, s_gd_image_fill);
SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG3, s_gd_image_fill);
SCM_ASSERT(SCM_INUMP(color), color, SCM_ARG3, s_gd_image_fill);
SCM_DEFER_INTS;
gdImageFill(gd_image_unbox(im), SCM_INUM(x), SCM_INUM(y), SCM_INUM(color));
SCM_ALLOW_INTS;
return SCM_BOOL_T;
}
SCM_PROC(s_gd_image_arc, "gd:image-arc", 8, 0, 0, scm_gd_image_arc);
static SCM
scm_gd_image_arc(SCM im, SCM cx, SCM cy, SCM w, SCM h, SCM s, SCM e, SCM color)
{
char *wta = "wrong type arg";
SCM_ASSERT(gd_image_p(im), im, SCM_ARG1, s_gd_image_arc);
SCM_ASSERT(SCM_INUMP(cx), cx, SCM_ARG2, s_gd_image_arc);
SCM_ASSERT(SCM_INUMP(cy), cy, SCM_ARG3, s_gd_image_arc);
SCM_ASSERT(SCM_INUMP(w), w, SCM_ARG4, s_gd_image_arc);
SCM_ASSERT(SCM_INUMP(h), h, SCM_ARG5, s_gd_image_arc);
SCM_ASSERT(SCM_INUMP(s), s, SCM_ARG6, s_gd_image_arc);
SCM_ASSERT(SCM_INUMP(e), e, SCM_ARG7, s_gd_image_arc);
SCM_ASSERT(SCM_INUMP(color), color, wta, s_gd_image_arc);
SCM_DEFER_INTS;
gdImageArc(gd_image_unbox(im),
SCM_INUM(cx), SCM_INUM(cy),
SCM_INUM(w), SCM_INUM(h),
SCM_INUM(s), SCM_INUM(e),
SCM_INUM(color));
SCM_ALLOW_INTS;
return SCM_BOOL_T;
}
#include "gd_glue.h"
#if 0
SCM_PROC(s_gd_image_set_brush, "gd:image-set-brush", 2, 0, 0, scm_gd_image_set_brush);
static SCM
scm_gd_image_set_brush(SCM im, SCM brush)
{
SCM_ASSERT(gd_image_p(im), im, SCM_ARG1, s_gd_image_set_brush);
SCM_ASSERT(gd_image_p(brush), brush, SCM_ARG2, s_gd_image_set_brush);
SCM_DEFER_INTS;
gdImageSetBrush(gd_image_unbox(im), gd_image_unbox(brush));
SCM_ALLOW_INTS;
return SCM_BOOL_T;
}
SCM_PROC(s_gd_image_copy_resized, "gd:image-copy-resized", 10, 0, 0, scm_gd_image_copy_resized);
static SCM
scm_gd_image_copy_resized(SCM dst, SCM src,
SCM dst_x, SCM dst_y,
SCM src_x, SCM src_y,
SCM dst_w, SCM dst_h,
SCM src_w, SCM src_h)
{
char *wta = "wrong type arg";
SCM_ASSERT(gd_image_p(dst), dst, SCM_ARG1, s_gd_image_copy_resized);
SCM_ASSERT(gd_image_p(src), src, SCM_ARG2, s_gd_image_copy_resized);
SCM_ASSERT(SCM_INUMP(dst_x), dst_x, SCM_ARG3, s_gd_image_copy_resized);
SCM_ASSERT(SCM_INUMP(dst_y), dst_y, SCM_ARG4, s_gd_image_copy_resized);
SCM_ASSERT(SCM_INUMP(src_x), src_x, SCM_ARG5, s_gd_image_copy_resized);
SCM_ASSERT(SCM_INUMP(src_y), src_y, SCM_ARG6, s_gd_image_copy_resized);
SCM_ASSERT(SCM_INUMP(dst_w), dst_w, SCM_ARG7, s_gd_image_copy_resized);
SCM_ASSERT(SCM_INUMP(dst_h), dst_h, wta, s_gd_image_copy_resized);
SCM_ASSERT(SCM_INUMP(src_w), src_w, wta, s_gd_image_copy_resized);
SCM_ASSERT(SCM_INUMP(src_h), src_h, wta, s_gd_image_copy_resized);
SCM_DEFER_INTS;
gdImageCopyResized(gd_image_unbox(dst), gd_image_unbox(src),
SCM_INUM(dst_x), SCM_INUM(dst_y),
SCM_INUM(src_x), SCM_INUM(src_y),
SCM_INUM(dst_w), SCM_INUM(dst_h),
SCM_INUM(src_w), SCM_INUM(src_h));
SCM_ALLOW_INTS;
return SCM_BOOL_T;
}
#endif
SCM_PROC(s_gd_image_create_from_gif, "gd:image-create-from-gif", 1, 0, 0, scm_gd_image_create_from_gif);
static SCM
scm_gd_image_create_from_gif(SCM filename_obj)
{
char *filename;
FILE *fp;
gdImagePtr ip;
SCM_ASSERT(SCM_ROSTRINGP(filename_obj), filename_obj, SCM_ARG1, s_gd_image_create_from_gif);
SCM_DEFER_INTS;
filename = SCM_ROCHARS(filename_obj);
fp = fopen(filename, "rb");
if (fp == NULL) {
scm_misc_error(s_gd_image_create_from_gif, "error opening file '%s': %s",
scm_listify(filename_obj,
scm_makfrom0str(strerror(errno)),
SCM_UNDEFINED));
}
ip = gdImageCreateFromGif(fp);
fclose(fp);
SCM_ALLOW_INTS;
return(gd_image_box(ip));
}
SCM_PROC(s_gd_image_color_transparent, "gd:image-color-transparent", 2, 0, 0, scm_gd_image_color_transparent);
static SCM
scm_gd_image_color_transparent(SCM image_obj, SCM color_obj)
{
gdImagePtr ip;
int color;
SCM_ASSERT(gd_image_p(image_obj), image_obj, SCM_ARG1, s_gd_image_color_transparent);
SCM_ASSERT(SCM_INUMP(color_obj), color_obj, SCM_ARG2, s_gd_image_color_transparent);
SCM_DEFER_INTS;
ip = gd_image_unbox(image_obj);
color = SCM_INUM(color_obj);
gdImageColorTransparent(ip, color);
SCM_ALLOW_INTS;
return SCM_BOOL_T;
}
SCM_PROC(s_gd_image_gif, "gd:image-gif", 2, 0, 0, scm_gd_image_gif);
static SCM
scm_gd_image_gif(SCM image_obj, SCM str_obj)
{
gdImagePtr ip;
char *str;
FILE *file;
/* check types and convert to c */
SCM_ASSERT(gd_image_p(image_obj), image_obj, SCM_ARG1, s_gd_image_gif);
SCM_ASSERT(SCM_ROSTRINGP(str_obj), str_obj, SCM_ARG5, s_gd_image_gif);
SCM_DEFER_INTS;
ip = gd_image_unbox(image_obj);
str = SCM_ROCHARS(str_obj);
/* open an output file */
file = fopen(str, "wb");
if (file == NULL) {
scm_misc_error(s_gd_image_gif, "error opening file '%s': %s",
scm_listify(str_obj,
scm_makfrom0str(strerror(errno)),
SCM_UNDEFINED));
}
/* write out the gif */
gdImageGif(ip, file);
/* cleanup */
fclose(file);
SCM_ALLOW_INTS;
return SCM_BOOL_T;
}
SCM_PROC(s_gd_image_string, "gd:image-string", 6, 0, 0, scm_gd_image_string);
static SCM
scm_gd_image_string(SCM im,
SCM font,
SCM x, SCM y,
SCM str,
SCM color)
{
/* check types */
SCM_ASSERT(gd_image_p(im), im, SCM_ARG1, s_gd_image_string);
SCM_ASSERT(gd_font_p(font), font, SCM_ARG2, s_gd_image_string);
SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG3, s_gd_image_string);
SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG4, s_gd_image_string);
SCM_ASSERT(SCM_ROSTRINGP(str), str, SCM_ARG5, s_gd_image_string);
SCM_ASSERT(SCM_INUMP(color), color, SCM_ARG6, s_gd_image_string);
SCM_DEFER_INTS;
/* is there a meaningful error code here? */
gdImageString(gd_image_unbox(im),
gd_font_unbox(font),
SCM_INUM(x), SCM_INUM(y),
SCM_ROCHARS(str),
SCM_INUM(color));
SCM_ALLOW_INTS;
return SCM_BOOL_T;
}
SCM_PROC(s_gd_image_string_up, "gd:image-string-up", 6, 0, 0, scm_gd_image_string_up);
static SCM
scm_gd_image_string_up(SCM im,
SCM font,
SCM x, SCM y,
SCM str,
SCM color)
{
/* check types */
SCM_ASSERT(gd_image_p(im), im, SCM_ARG1, s_gd_image_string_up);
SCM_ASSERT(gd_font_p(font), font, SCM_ARG2, s_gd_image_string_up);
SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG3, s_gd_image_string_up);
SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG4, s_gd_image_string_up);
SCM_ASSERT(SCM_ROSTRINGP(str), str, SCM_ARG5, s_gd_image_string_up);
SCM_ASSERT(SCM_INUMP(color), color, SCM_ARG6, s_gd_image_string_up);
SCM_DEFER_INTS;
/* is there a meaningful error code here? */
gdImageStringUp(gd_image_unbox(im),
gd_font_unbox(font),
SCM_INUM(x), SCM_INUM(y),
SCM_ROCHARS(str),
SCM_INUM(color));
SCM_ALLOW_INTS;
return SCM_BOOL_T;
}
SCM_PROC(s_gd_image_create, "gd:image-create", 2, 0, 0, scm_gd_image_create);
static SCM
scm_gd_image_create(SCM x, SCM y)
{
gdImagePtr ip;
/* check types */
SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_gd_image_create);
SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_gd_image_create);
SCM_DEFER_INTS;
ip = gdImageCreate(SCM_INUM(x), SCM_INUM(y));
SCM_ALLOW_INTS;
return(gd_image_box(ip));
}
SCM_SYMBOL(gd_font_tiny, "gd-font-tiny");
SCM_SYMBOL(gd_font_small, "gd-font-small");
SCM_SYMBOL(gd_font_medium_bold, "gd-font-medium-bold");
SCM_SYMBOL(gd_font_large, "gd-font-large");
SCM_SYMBOL(gd_font_giant, "gd-font-giant");
SCM_PROC(s_gd_font_create, "gd:font-create", 1, 0, 0, scm_gd_font_create);
static SCM
scm_gd_font_create(SCM name_obj)
{
gdFontPtr font;
if (name_obj == gd_font_tiny) {
font = gdFontTiny;
} else if (name_obj == gd_font_small) {
font = gdFontSmall;
} else if (name_obj == gd_font_medium_bold) {
font = gdFontMediumBold;
} else if (name_obj == gd_font_large) {
font = gdFontLarge;
} else if (name_obj == gd_font_giant) {
font = gdFontGiant;
} else {
SCM_ASSERT(0, name_obj, SCM_ARG1, s_gd_font_create);
}
return(gd_font_box(font));
}
SCM_PROC(s_gd_image_color_allocate, "gd:image-color-allocate", 4, 0, 0, scm_gd_image_color_allocate);
static SCM
scm_gd_image_color_allocate(SCM im,
SCM red,
SCM green,
SCM blue)
{
int color;
SCM_ASSERT(gd_image_p(im), im, SCM_ARG1, s_gd_image_color_allocate);
SCM_ASSERT(SCM_INUMP(red), red, SCM_ARG2, s_gd_image_color_allocate);
SCM_ASSERT(SCM_INUMP(green), green, SCM_ARG3, s_gd_image_color_allocate);
SCM_ASSERT(SCM_INUMP(blue), blue, SCM_ARG4, s_gd_image_color_allocate);
SCM_DEFER_INTS;
color = gdImageColorAllocate(gd_image_unbox(im),
SCM_INUM(red),
SCM_INUM(green),
SCM_INUM(blue));
SCM_ALLOW_INTS;
return(SCM_MAKINUM(color));
}
SCM_PROC(s_gd_image_info, "gd:image-info", 1, 0, 0, scm_gd_image_info);
static SCM
scm_gd_image_info(SCM image_obj)
{
SCM vect;
gdImagePtr ip;
SCM_ASSERT(gd_image_p(image_obj), image_obj, SCM_ARG1, s_gd_image_info);
SCM_DEFER_INTS;
ip = gd_image_unbox(image_obj);
vect = gh_vector(gh_int2scm(5), SCM_BOOL_F);
# define set(i, v) gh_vset(vect, gh_int2scm(i), gh_int2scm(v));
set(0, gdImageSX(ip));
set(1, gdImageSY(ip));
set(2, gdImageColorsTotal(ip));
set(3, gdImageGetTransparent(ip));
set(4, gdImageGetInterlaced(ip));
# undef set
SCM_ALLOW_INTS;
return vect;
}
SCM_PROC(s_gd_image_color_to_rgb, "gd:image-color->rgb", 2, 0, 0, scm_gd_image_color_to_rgb);
static SCM
scm_gd_image_color_to_rgb(SCM image_obj, SCM color_obj)
{
gdImagePtr ip;
int color;
SCM vect;
SCM_ASSERT(gd_image_p(image_obj), image_obj, SCM_ARG1, s_gd_image_color_to_rgb);
SCM_ASSERT(SCM_INUMP(image_obj), color_obj, SCM_ARG2, s_gd_image_color_to_rgb);
SCM_DEFER_INTS;
ip = gd_image_unbox(image_obj);
color = SCM_INUM(color_obj);
vect = gh_vector(gh_int2scm(3), SCM_BOOL_F);
# define set(i, v) gh_vset(vect, gh_int2scm(i), gh_int2scm(v));
set(0, gdImageRed(ip, color));
set(1, gdImageGreen(ip, color));
set(2, gdImageBlue(ip, color));
# undef set
SCM_ALLOW_INTS;
return vect;
}
SCM_PROC(s_gd_image_line, "gd:image-line", 6, 0, 0, scm_gd_image_line);
static SCM
scm_gd_image_line(SCM image_obj,
SCM x1_obj, SCM y1_obj,
SCM x2_obj, SCM y2_obj,
SCM color_obj)
{
gdImagePtr ip;
int x1,y1,x2,y2,color;
SCM_ASSERT(gd_image_p(image_obj), image_obj, SCM_ARG1, s_gd_image_line);
SCM_ASSERT(SCM_INUMP(x1_obj), x1_obj, SCM_ARG2, s_gd_image_line);
SCM_ASSERT(SCM_INUMP(y1_obj), y1_obj, SCM_ARG3, s_gd_image_line);
SCM_ASSERT(SCM_INUMP(x2_obj), x2_obj, SCM_ARG4, s_gd_image_line);
SCM_ASSERT(SCM_INUMP(y2_obj), y2_obj, SCM_ARG5, s_gd_image_line);
SCM_ASSERT(SCM_INUMP(color_obj), color_obj, SCM_ARG6, s_gd_image_line);
SCM_DEFER_INTS;
ip = gd_image_unbox(image_obj);
x1 = SCM_INUM(x1_obj);
y1 = SCM_INUM(y1_obj);
x2 = SCM_INUM(x2_obj);
y2 = SCM_INUM(y2_obj);
color = SCM_INUM(color_obj);
gdImageLine(ip, x1, y1, x2, y2, color);
SCM_ALLOW_INTS;
return SCM_BOOL_T;
}
/*
* initialization code
*/
void scm_init_gd()
{
static scm_smobfuns gd_image_smob;
static scm_smobfuns gd_font_smob;
INIT_PRINT(fprintf(stderr, "calling gd init function.\n"));
gd_font_tiny = gd_font_box(gdFontTiny);
/* new image type */
gd_image_smob.mark = gd_mark;
gd_image_smob.free = gd_image_free;
gd_image_smob.print = gd_image_print;
gd_image_smob.equalp = NULL;
g.gd_image_type_tag = scm_newsmob(&gd_image_smob);
/* new font type */
gd_font_smob.mark = gd_mark;
gd_font_smob.free = gd_font_free;
gd_font_smob.print = gd_font_print;
gd_font_smob.equalp = NULL;
g.gd_font_type_tag = scm_newsmob(&gd_font_smob);
#include "gd_glue.x"
return;
}
void
scm_init_gd_module()
{
INIT_PRINT(fprintf(stderr, "calling gd pre-init function.\n"));
scm_register_module_xxx("gd", scm_init_gd);
return;
}
--
If I haven't seen further, it is by standing in the footsteps of giants.