/*
 *                     The OCaml-gtk interface
 *
 * Copyright (c) 1997-99   David Monniaux, Pascal Cuoq, Sven Luther
 *
 *
 * This file is distributed under the conditions described in
 * the file LICENSE.
 */

/* $Id: mlgdk_stub.c,v 1.33 1999/11/23 15:05:45 cuoq Exp $ */

#include <caml/memory.h>
#include <caml/alloc.h>
#include <caml/mlvalues.h>
#include <caml/fail.h>
#include <caml/callback.h>
#include <gdk/gdk.h>
#include <stdio.h>
#include "config.h"

#include "mlgdk.h"

/* Visuals */

value mlgdk_visual_from_window (value window)
{
  value final_visual;
  final_visual = (value) gdk_window_get_visual (GdkWindow_ml(window));
  return final_visual;
}

/* Events */
#define mlgdk_expose_event_extract(coord) \
value mlgdk_expose_event_extract_##coord (value ptr) \
{ \
  return Val_int(((GdkEventExpose*) ptr)->area.##coord); \
}

mlgdk_expose_event_extract(x)
mlgdk_expose_event_extract(y)
mlgdk_expose_event_extract(width)
mlgdk_expose_event_extract(height)
	
#define mlgdk_configure_event_extract(coord) \
value mlgdk_configure_event_extract_##coord (value ptr) \
{ \
  return Val_int(((GdkEventConfigure*) ptr)->##coord); \
}

mlgdk_configure_event_extract(x)
mlgdk_configure_event_extract(y)
mlgdk_configure_event_extract(width)
mlgdk_configure_event_extract(height)
	
#define mlgdk_button_event_extract(coord) \
value mlgdk_button_event_extract_##coord (value ptr) \
{ \
  return Val_int(((GdkEventButton*) ptr)->##coord); \
}

mlgdk_button_event_extract(button)
mlgdk_button_event_extract(state)
mlgdk_button_event_extract(x)
mlgdk_button_event_extract(y)

#define mlgdk_motion_event_extract(get,coord) \
value mlgdk_motion_event_extract_##coord (value ptr) \
{ \
  return (##get(((GdkEventMotion*) ptr)->##coord)); \
}

mlgdk_motion_event_extract(Val_bool, is_hint)
mlgdk_motion_event_extract(Val_int, state)
mlgdk_motion_event_extract(Val_int, x)
mlgdk_motion_event_extract(Val_int, y)

#define mlgdk_key_event_extract(get,coord) \
value mlgdk_key_event_extract_##coord (value ptr) \
{ \
  return (##get(((GdkEventKey*) ptr)->##coord)); \
}

mlgdk_key_event_extract(copy_string,string)
mlgdk_key_event_extract(Val_int,keyval)
mlgdk_key_event_extract(Val_int,state)


value mlgdk_events_pending(value dummy)
{
  return Val_bool (gdk_events_pending());
}


/* Color */
GdkColor GdkColor_ml (value color)
{
  GdkColor col;
  col.pixel = Int_val (Field (color, 0));
  col.red = Int_val (Field (color, 1));
  col.green = Int_val (Field (color, 2));
  col.blue = Int_val (Field (color, 3));
  return col;
}

value ml_GdkColor (GdkColor color)
{
  value col;
  col = alloc_tuple (4);
  Store_field (col, 0, Val_int(color.pixel));
  Store_field (col, 1, Val_int(color.red));
  Store_field (col, 2, Val_int(color.green));
  Store_field (col, 3, Val_int(color.blue));
  return ml_GdkObject (col) ;
}

value mlgdk_colormap_alloc_color (value cmap, value color, value writeable,
                                  value best_match)
{
  int retval;
  GdkColor col;
#ifdef DEBUG
  fprintf (stderr, "mlgdk_colormap_alloc_color.\n");
#endif
  col = GdkColor_ml(color);
#ifdef DEBUG
  fprintf (stderr, "Pixel : P = %d, R = %d, G = %d, B = %d.\n",
    col.pixel, col.red, col.green, col.blue);
#endif
  retval = gdk_colormap_alloc_color(GdkColormap_ml(cmap), &col,
    Bool_val(writeable), Bool_val(best_match));
  if (!retval) failwith ("colormap_alloc_color : No color free.");
#ifdef DEBUG
  fprintf (stderr, "Pixel : P = %d, R = %d, G = %d, B = %d.\n",
    col.pixel, col.red, col.green, col.blue);
#endif
  return ml_GdkObject (ml_GdkColor(col)) ;
}

value mlgdk_colormap_change (value cmap, value color)
{
  gdk_colormap_change (GdkColormap_ml(cmap), ((GdkColor *)color)->pixel+1);
  return Val_unit;
}

value mlgdk_colormap_get_color (value cmap, value pixel)
{
  GdkColor col;
#ifdef DEBUG
  fprintf (stderr, "mlgdk_colormap_get_color.\n");
  fprintf (stderr, "Pixel = %d.\n", Int_val(pixel));
  fprintf (stderr, "Colormap->Colors = %p.\n", GdkColormap_ml(cmap)->colors) ;
#endif
  if (GdkColormap_ml(cmap)->colors == NULL)
  {
    col.pixel = Int_val(pixel);
    col.red = ((Int_val(pixel) >> 16) & 255)<<8;
    col.green = ((Int_val(pixel) >> 8) & 255)<<8;
    col.blue = (Int_val(pixel) & 255)<<8;
  }
  else if (Int_val(pixel)>(GdkColormap_ml(cmap))->size)
  {
    char failmesg[128];
    sprintf (failmesg, "colormap_get_color : %d exceeds cmap size (%d).",
      Int_val(pixel), GdkColormap_ml(cmap)->size);
    failwith (failmesg);
  }
  else col = GdkColormap_ml(cmap)->colors[Int_val(pixel)];
#ifdef DEBUG
  fprintf (stderr, "Pixel : P = %d, R = %d, G = %d, B = %d.\n",
    col.pixel, col.red, col.green, col.blue);
#endif
  return ml_GdkColor(col);
}

/* Fonts */

value mlgdk_font_load(value font_name)
{
  value final_font;
  final_font = (value) gdk_font_load(String_val(font_name));
  return final_font; 
}

value mlgdk_string_extents (value font, value str)
{
  value extent;
  gint lbearing, rbearing, width, ascent, descent;
  gdk_string_extents (GdkFont_ml(font), String_val(str),
    &lbearing, &rbearing, &width, &ascent, &descent);
  extent = alloc_tuple (5);
  Store_field (extent, 0, Val_int(lbearing));
  Store_field (extent, 1, Val_int(rbearing));
  Store_field (extent, 2, Val_int(width));
  Store_field (extent, 3, Val_int(ascent));
  Store_field (extent, 4, Val_int(descent));
  return extent;
}

value mlgdk_string_width (value font, value str)
{
  return Val_int(gdk_string_width(GdkFont_ml(font), String_val(str)));
}

value mlgdk_string_measure (value font, value str)
{
  return Val_int(gdk_string_measure(GdkFont_ml(font), String_val(str)));
}

value mlgdk_string_height (value font, value str)
{
  return Val_int(gdk_string_height(GdkFont_ml(font), String_val(str)));
}

/* GC */
value mlgdk_gc_new(value window)
{
#ifdef DEBUG
  fprintf (stderr, "mlgdk_gc_new.\n");
#endif
  return (value) gdk_gc_new(GdkWindow_ml(window));
}

value mlgdk_gc_destroy(value gc)
{
  gdk_gc_destroy((GdkGC*) gc);
  return Val_unit;
}

value mlgdk_gc_set_clip_rectangle(value gc,
  value x, value y, value w, value h)
{
  GdkRectangle r;
  r.x = Int_val(x);
  r.y = Int_val(y);
  r.width = Int_val(w);
  r.height = Int_val(h);
  gdk_gc_set_clip_rectangle((GdkGC*) gc, &r);
  return Val_unit;
}

value mlgdk_gc_set_foreground(value gc, value color)
{
  GdkColor col;
#ifdef DEBUG
  fprintf (stderr, "mlgdk_gc_set_foreground.\n");
#endif
  col = GdkColor_ml(color);
  gdk_gc_set_foreground((GdkGC*)gc, &col);
  return Val_unit;
}

value mlgdk_gc_set_background(value gc, value color)
{
  GdkColor col;
  col = GdkColor_ml(color);
  gdk_gc_set_background((GdkGC*)gc, &col);
  return Val_unit;
}

value mlgdk_gc_set_font(value gc, value font)
{
  gdk_gc_set_font((GdkGC*)gc, GdkFont_ml(font));
  return Val_unit;
}

value mlgdk_gc_set_function(value gc, value function)
{
  gdk_gc_set_function((GdkGC*)gc, (GdkFunction) (Int_val(function)));
  return Val_unit;
}

value mlgdk_gc_set_fill(value gc, value fill)
{
  gdk_gc_set_fill((GdkGC*) gc, Int_val(fill));
  return Val_unit;
}

value mlgdk_gc_set_tile(value gc, value pixmap)
{
  gdk_gc_set_tile((GdkGC*) gc, GdkPixmap_ml(pixmap));
  return Val_unit;
}

value mlgdk_gc_set_stipple(value gc, value fill)
{
  gdk_gc_set_fill((GdkGC*)gc, (GdkFill) (Int_val(fill)));
  return Val_unit;
}

value mlgdk_gc_set_line_attributes(value gc, value line_width,
				   value line_style, value cap_style,
				    value join_style)
{
  gdk_gc_set_line_attributes((GdkGC*) gc,
    Int_val(line_width), Int_val(line_style),
    Int_val(cap_style), Int_val(join_style));
  return Val_unit;
}

/* Pixmap */

value mlgdk_pixmap_new(value window, value width, value height, value depth)
{
  value final_pixmap;
  final_pixmap = 
    (value)gdk_pixmap_new (GdkWindow_ml(window),
			   Int_val(width), Int_val(height), Int_val(depth)) ;
  return final_pixmap;
}

value mlgdk_pixmap_unref (value pixmap)
{
  gdk_pixmap_unref((GdkPixmap *)pixmap) ;
  return Val_unit ;
}

value
mlgdk_pixmap_create_from_xpm (value window, value filename)
{
  value mlpixmap, mlcolor ;
  value tuple ;

  GdkBitmap *mask=NULL ;  
  GdkColor transparent_color ; 

  mlpixmap = ml_GdkObject (gdk_pixmap_create_from_xpm (GdkWindow_ml(window),
						       &mask,
						       &transparent_color,
						       String_val(filename))) ;
  mlcolor = ml_GdkColor (transparent_color) ;
  
  tuple = alloc_tuple (3) ;

  Store_field (tuple, 0, mlpixmap) ;
  Store_field (tuple, 1, mlcolor) ;
  Store_field (tuple, 2, ml_GdkObject (mask));

  return tuple ;
}

/* Images */
value mlgdk_image_new_bitmap (value visual, value data,
			      value width, value height)
{
  return
    ml_GdkObject (gdk_image_new_bitmap (GdkVisual_ml(visual), (gpointer) data,
    Int_val(width), Int_val(height)));
}

value mlgdk_image_new (value type, value visual,
		       value width, value height)
{
  return
    ml_GdkObject (gdk_image_new ((GdkImageType) type, GdkVisual_ml(visual),
    Int_val(width), Int_val(height)));
}

value mlgdk_image_get (value window, value x, value y,
		       value width, value height)
{
  return
    ml_GdkObject (gdk_image_get (GdkWindow_ml(window), Int_val(x), Int_val(y),
    Int_val(width), Int_val(height)));
}

value mlgdk_image_put_pixel (value image, value x, value y, value pixel)
{
  gdk_image_put_pixel ((GdkImage*)image, Int_val(x), Int_val(y),
		  Int_val(pixel));
  return Val_unit ;
}

value mlgdk_image_get_pixel (value image, value x, value y)
{
  return Val_int(gdk_image_get_pixel ((GdkImage*)image, Int_val(x),
    Int_val(y)));
}

value mlgdk_image_destroy (value image)
{
  gdk_image_destroy ((GdkImage*)image);
  return Val_unit ;
}

/* Drawing */
value mlgdk_draw_point(value drawable, value gc, value x, value y)
{
  gdk_draw_point(GdkDrawable_ml(drawable), (GdkGC*)gc, Int_val(x), Int_val(y));
  return Val_unit;
}

value mlgdk_draw_line_native(value drawable, value gc,
  value x1, value y1, value x2, value y2)
{
  gdk_draw_line(GdkDrawable_ml(drawable), (GdkGC*)gc,
   Int_val(x1), Int_val(y1), Int_val(x2), Int_val(y2));
  return Val_unit;
}

value mlgdk_draw_line(value *argv, int argc)
{
  return mlgdk_draw_line_native(argv[0], argv[1],
    argv[2], argv[3], argv[4], argv[5]);
}

value mlgdk_draw_rectangle_native(value drawable, value gc, value filled,
  value x, value y, value w, value h)
{
#ifdef DEBUG
  GdkGCValues val;
  gdk_gc_get_values ((GdkGC *)gc, &val);
  fprintf (stderr, "mlgdk_draw_rectangle_native.\n");
  fprintf (stderr, "PRGB = %u, %u, %u, %u.\n", val.foreground.pixel,
    val.foreground.red, val.foreground.green, val.foreground.blue);
#endif
  gdk_draw_rectangle(GdkDrawable_ml(drawable), (GdkGC*)gc, Int_val(filled),
   Int_val(x), Int_val(y), Int_val(w), Int_val(h));
  return Val_unit;
}

value mlgdk_draw_rectangle(value *argv, int argc)
{
#ifdef DEBUG
  fprintf (stderr, "mlgdk_draw_rectangle.\n");
#endif
  return mlgdk_draw_rectangle_native(argv[0], argv[1],
    argv[2], argv[3], argv[4], argv[5], argv[6]);
}

value mlgdk_draw_arc_native(value drawable, value gc, value filled,
  value x, value y, value w, value h,
  value angle1, value angle2)
{
  gdk_draw_arc(GdkDrawable_ml(drawable), (GdkGC*)gc, Int_val(filled),
   Int_val(x), Int_val(y), Int_val(w), Int_val(h),
   Int_val(angle1), Int_val(angle2));
  return Val_unit;
}

value mlgdk_draw_arc(value *argv, int argc)
{
  return mlgdk_draw_arc_native(argv[0], argv[1],
    argv[2], argv[3], argv[4], argv[5], argv[6],
    argv[7], argv[8]);
}

value mlgdk_draw_polygon(value drawable, value gc, value filled,
  value xyarray)
{
  int n = Wosize_val(xyarray);
  BEGIN_LOCAL_ARRAY(GdkPoint, xyarray_g, n);
  int i;
  for (i=0; i<n; i++) {
      value xy = Field(xyarray, i);
      xyarray_g[i].x = Field(xy, 0);
      xyarray_g[i].y = Field(xy, 1);
    }
  gdk_draw_polygon(GdkDrawable_ml(drawable), (GdkGC*)gc,
    Int_val(filled), xyarray_g, n);
  END_LOCAL_ARRAY(GdkPoint, xyarray_g, n);
  return Val_unit;
}

value mlgdk_draw_string_native(value drawable, value font, value gc,
  value x, value y, value string)
{
  gdk_draw_string(GdkDrawable_ml(drawable), GdkFont_ml(font), (GdkGC*)gc,
    Int_val(x), Int_val(y), String_val(string));
  return Val_unit;
}

value mlgdk_draw_string(value *argv, int argc)
{
  return mlgdk_draw_string_native(argv[0], argv[1],
    argv[2], argv[3], argv[4], argv[5]);
}

value mlgdk_draw_pixmap_native(value drawable, value gc, value src,
				value xsrc, value ysrc, value xdest,
				value ydest, value width, value height)
{
#ifdef DEBUG
  fprintf(stderr, "Gdk.draw_pixmap DEBUGGING ...") ;
  if (drawable==(value)NULL) fprintf (stderr, "\tdrawable is NULL\n") ;
  if (gc==(value)NULL) fprintf (stderr, "\tgc is NULL\n") ;
  fprintf(stderr, "\tvalues are : %d, %d, %d, %d, %d, %d\n",
	Int_val(xsrc), Int_val(ysrc),
	Int_val(xdest), Int_val(ydest),
	Int_val(width), Int_val(height)) ;
#endif
  gdk_draw_pixmap(GdkDrawable_ml(drawable), (GdkGC*) gc, GdkPixmap_ml(src),
    Int_val(xsrc), Int_val(ysrc), Int_val(xdest), Int_val(ydest),
    Int_val(width), Int_val(height));
  return Val_unit;
}

value mlgdk_draw_pixmap(value *argv, int argc)
{
  return
    mlgdk_draw_pixmap_native(argv[0], argv[1],
			     argv[2], argv[3], argv[4], argv[5],
			     argv[6], argv[7], argv[8]);
}

value mlgdk_draw_points(value drawable, value gc, value xyarray)
{
  int n = Wosize_val(xyarray);
  BEGIN_LOCAL_ARRAY(GdkPoint, xyarray_g, n);
  int i;
  for (i=0; i<n; i++) {
      value xy = Field(xyarray, i);
      xyarray_g[i].x = Field(xy, 0);
      xyarray_g[i].y = Field(xy, 1);
    }
  gdk_draw_points(GdkDrawable_ml(drawable), (GdkGC*)gc, xyarray_g, n);
  END_LOCAL_ARRAY(GdkPoint, xyarray_g, n);
  return Val_unit;
}

value mlgdk_draw_segments(value drawable, value gc, value xyarray)
{
  int n = Wosize_val(xyarray);
  BEGIN_LOCAL_ARRAY(GdkSegment, xyarray_g, n);
  int i;
  for (i=0; i<n; i++) {
      value xy = Field(xyarray, i);
      xyarray_g[i].x1 = Field(xy, 0);
      xyarray_g[i].y1 = Field(xy, 1);
      xyarray_g[i].x2 = Field(xy, 2);
      xyarray_g[i].y2 = Field(xy, 3);
    }
  gdk_draw_segments(GdkDrawable_ml(drawable), (GdkGC*)gc, xyarray_g, n);
  END_LOCAL_ARRAY(GdkSegment, xyarray_g, n);
  return Val_unit;
}

value mlgdk_draw_lines(value drawable, value gc, value xyarray)
{
  int n = Wosize_val(xyarray);
  BEGIN_LOCAL_ARRAY(GdkPoint, xyarray_g, n);
  int i;
  for (i=0; i<n; i++) {
      value xy = Field(xyarray, i);
      xyarray_g[i].x = Field(xy, 0);
      xyarray_g[i].y = Field(xy, 1);
    }
  gdk_draw_lines(GdkDrawable_ml(drawable), (GdkGC*)gc, xyarray_g, n);
  END_LOCAL_ARRAY(GdkPoint, xyarray_g, n);
  return Val_unit;
}

/* Windows */
value mlgdk_window_get_colormap (value window)
{
  value final_cmap;

#ifdef DEBUG
  fprintf (stderr, "mlgdk_window_get_colormap.\n");
#endif
  final_cmap = (value) gdk_window_get_colormap (GdkWindow_ml(window));
  return final_cmap;
}

value mlgdk_window_get_pointer (value window)
{
  int x, y;
  GdkModifierType state;
  value r;
#ifdef DEBUG
  fprintf (stderr, "mlgdk_window_get_pointer.\n");
#endif
  gdk_window_get_pointer (GdkWindow_ml(window), &x, &y, &state);
  r = alloc_tuple(3);
  Store_field(r,0,Val_int(x));
  Store_field(r,1,Val_int(y));
  Store_field(r,2,Val_int(state));
  return r;
}


/* Initialization */
static value exn_not_available;
void mlgdk_init()
{
  exn_not_available = (value) caml_named_value("color not available");
}