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.