/***********************************************************************/
/*                                                                     */
/*                           Objective Caml                            */
/*                                                                     */
/*             Damien Doligez, projet Para, INRIA Rocquencourt         */
/*                                                                     */
/*  Copyright 1998 Institut National de Recherche en Informatique et   */
/*  en Automatique.  All rights reserved.  This file is distributed    */
/*  under the terms of the GNU Library General Public License.         */
/*                                                                     */
/***********************************************************************/

/* $Id$ */

#include "alloc.h"
#include "callback.h"
#include "fail.h"
#include "memory.h"
#include "mlvalues.h"
#include "signals.h"

#include "main.h"      /* Include main.h last or Assert will not work. */


/* The off-screen buffer that holds the contents of the graphics arena. */
static GWorldPtr gworld = NULL;

/* An arbitrarily large rectangle (for clipping). */
static Rect maxrect = { -SHRT_MAX, -SHRT_MAX, SHRT_MAX, SHRT_MAX };

/* Coordinates (relative to the window) of the top-left corner
   of the graphics arena. */
long x0, y0;

/* Width and height of the graphics arena. */
long w0, h0;

RGBColor fgcolor;

/* Convert from Caml coordinates to QD coordinates in the off-screen buffer. */
/* Note: these conversions are self-inverse (see gr_current_point). */
#define Bx(x) (x)
#define By(y) (h0-1 - (y))

/* Convert from Caml coordinates to QD coordinates in the window. */
#define Wx(x) (Bx(x) + x0)
#define Wy(y) (By(y) + y0)

/* Convert from QD window coordinates to Caml coordinates. */
#define Cx(x) ((x) - x0)
#define Cy(y) (h0-1 - ((y) - y0))


/***********************************************************************/
/* User interface functions                                            */
/***********************************************************************/

static void GraphUpdateGW (void)
{
  Rect r;
  WStatusH st = WinGetStatus (winGraphics);

  Assert (st != NULL);
  Assert (gworld != NULL);
  WELongRectToRect (&(*st)->destrect, &r);
  OffsetRect (&r, winGraphics->portRect.left, winGraphics->portRect.top);
  UpdateGWorld (&gworld, 0, &r, NULL, NULL, clipPix);
}

void GraphNewSizePos (void)
{
  GraphUpdateGW ();
}

/* The current port must be winGraphics when this function is called. */
void GraphUpdate (void)
{
  Rect r, src, dst;
  Boolean good;
  WStatusH st = WinGetStatus (winGraphics);
  RGBColor forecolor, backcolor;

  Assert (st != NULL);
  GraphUpdateGW ();
  good = LockPixels (GetGWorldPixMap (gworld));   Assert (good);
  WELongRectToRect (&(*st)->destrect, &r);
  WELongRectToRect (&(*st)->viewrect, &dst);
  src = dst;
  OffsetRect (&src, -r.left, -r.top);
  GetBackColor (&backcolor);
  GetForeColor (&forecolor);
  BackColor (whiteColor);
  ForeColor (blackColor);
  CopyBits (&((GrafPtr) gworld)->portBits, &((GrafPtr) winGraphics)->portBits,
            &src, &dst, srcCopy, NULL);
  RGBBackColor (&backcolor);
  RGBForeColor (&forecolor);
  UnlockPixels (GetGWorldPixMap (gworld));
}

/* All scrolling of the graphics window must go through this function
   so it can update the coordinates x0 and y0, and the pen location. */
void GraphScroll (long dx, long dy)
{
  Rect r;
  RgnHandle update = NewRgn ();
  WStatusH st = WinGetStatus (winGraphics);
  Point p;
  GrafPtr port;

  Assert (st != NULL);
  GetPort (&port);
  SetPort (winGraphics);
  WELongRectToRect (&(*st)->viewrect, &r);
  ScrollRect (&r, dx, dy, update);
  WEOffsetLongRect (&(*st)->destrect, dx, dy);
  SetClip (update);
  GraphUpdate ();
  ClipRect (&maxrect);
  DisposeRgn (update);

  x0 += dx;
  y0 += dy;
  GetPen (&p);
  MoveTo (p.h + dx, p.v + dy);
  SetPort (port);
}

/* Graphics event queue */
#define GraphQsize 15
static EventRecord graphQ[GraphQsize];
static int graphQlen = 0;

#define Succ(x) ((x) >= GraphQsize ? 0 : (x)+1)

void GraphGotEvent (EventRecord *evt)
{
  GrafPort *saveport;

  if (graphQlen < GraphQsize) ++ graphQlen;
  memmove (&(graphQ[1]), &(graphQ[0]), (graphQlen - 1) * sizeof (graphQ[0]));

  graphQ[0] = *evt;

  PushWindowPort (winGraphics);
  GlobalToLocal (&(graphQ[0].where));
  PopPort;
}
static void DequeueEvent (int i)
{
  -- graphQlen;
  memmove (&(graphQ[i]), &(graphQ[i+1]), (graphQlen - i) * sizeof (graphQ[0]));
}

/***********************************************************************/
/* Primitives for the graphics library                                 */
/***********************************************************************/

value gr_open_graph (value vgeometry);
value gr_close_graph (value unit);
value gr_sigio_signal (value unit);
value gr_sigio_handler (value unit);
value gr_display_mode (value flag);
value gr_remember_mode (value flag);
value gr_synchronize (value unit);
value gr_clear_graph (value unit);
value gr_size_x (value unit);
value gr_size_y (value unit);
value gr_set_color (value vrgb);
value gr_plot (value vx, value vy);
value gr_point_color (value vx, value vy);
value gr_moveto (value vx, value vy);
value gr_current_x (value unit);
value gr_current_y (value unit);
value gr_lineto (value vx, value vy);
value gr_draw_rect (value vx, value vy, value vw, value vh);
value gr_draw_arc (value *argv, int argc);
value gr_draw_arc_nat (value, value, value, value, value, value);
value gr_set_line_width (value vwidth);
value gr_fill_rect (value vx, value vy, value vw, value vh);
value gr_fill_poly (value vpoints);
value gr_fill_arc (value *argv, int argc);
value gr_fill_arc_nat (value, value, value, value, value, value);
value gr_draw_char (value vchr);
value gr_draw_string (value vstr);
value gr_set_font (value vfontname);
value gr_set_text_size (value vsz);
value gr_text_size (value vstr);
value gr_make_image (value varray);
value gr_dump_image (value vimage);
value gr_draw_image (value vimage, value vx, value vy);
value gr_create_image (value vw, value vh);
value gr_blit_image (value vimage, value vx, value vy);
value gr_wait_event (value veventlist);
value gr_sound (value vfreq, value vdur);
value gr_set_window_title (value title);

#define UNIMPLEMENTED(f, args) \
value f args; \
value f args \
{ \
  failwith ("not implemented: " #f); \
  return Val_unit;  /* not reached */ \
}

UNIMPLEMENTED (gr_window_id, (value unit))
UNIMPLEMENTED (gr_open_subwindow, (value x, value y, value w, value h))
UNIMPLEMENTED (gr_close_subwindow, (value id))


/**** Ancillary macros and function */

/* double-buffer or write-through */
static int grdisplay_mode;
static int grremember_mode;

/* Current state */
static long cur_x, cur_y;
static short cur_width, cur_font, cur_size;
/* see also fgcolor */


/* Drawing off-screen and on-screen simultaneously.  The following three
   macros must always be used together and in this order.
*/
/* 1. Begin drawing in the off-screen buffer. */
#define BeginOff { \
  CGrafPtr _saveport_; \
  GDHandle _savegdev_; \
  Rect _cliprect_; \
  if (grremember_mode) { \
    GetGWorld (&_saveport_, &_savegdev_); \
    LockPixels (GetGWorldPixMap (gworld)); \
    SetGWorld ((CGrafPtr) gworld, NULL);

/* 2. Continue with on-screen drawing. */
#define On \
    SetGWorld (_saveport_, _savegdev_); \
    UnlockPixels (GetGWorldPixMap (gworld)); \
  } \
  if (grdisplay_mode) { \
    SetPort (winGraphics); \
    ScrollCalcGraph (winGraphics, &_cliprect_); \
    ClipRect (&_cliprect_);

/* 3. Clean up after drawing. */
#define EndOffOn \
    ClipRect (&maxrect); \
    SetPort ((GrafPtr) _saveport_); \
  } \
}

/* Set up the current port unconditionally.  This is for functions that
   don't draw (measurements and setting the graphport state).
   Usage: BeginOffAlways / EndOffAlways
      or  BeginOffAlways / OnAlways / EndOffOnAlways
   */
#define BeginOffAlways { \
  CGrafPtr _saveport_; \
  GDHandle _savegdev_; \
  GetGWorld (&_saveport_, &_savegdev_); \
  LockPixels (GetGWorldPixMap (gworld)); \
  SetGWorld ((CGrafPtr) gworld, NULL);

#define EndOffAlways \
  SetGWorld (_saveport_, _savegdev_); \
  UnlockPixels (GetGWorldPixMap (gworld)); \
}

#define OnAlways \
  SetGWorld (_saveport_, _savegdev_); \
  UnlockPixels (GetGWorldPixMap (gworld)); \
  SetPort (winGraphics); \

#define EndOffOnAlways \
  SetPort ((GrafPtr) _saveport_); \
}

/* Convert a red, green, or blue value from 8 bits to 16 bits. */
#define RGB8to16(x) ((x) | ((x) << 8))

/* Declare and convert x and y from vx and vy. */
#define XY long x = Long_val (vx), y = Long_val (vy)


static value * graphic_failure_exn = NULL;

static void gr_fail(char *fmt, void *arg)
{
  char buffer[1024];

  if (graphic_failure_exn == NULL) {
    graphic_failure_exn = caml_named_value("Graphics.Graphic_failure");
    if (graphic_failure_exn == NULL){
      invalid_argument("Exception Graphics.Graphic_failure not initialized,"
                       " you must load graphics.cma");
    }
  }
  sprintf(buffer, fmt, arg);
  raise_with_string(*graphic_failure_exn, buffer);
}

static void gr_check_open (void)
{
  if (winGraphics == NULL) gr_fail("graphic screen not opened", NULL);
}

/* Max_image_mem is the number of image pixels that can be allocated
   in one major GC cycle.  The GC will speed up to match this allocation
   speed.
*/
#define Max_image_mem 1000000   /*FIXME Should use user pref. */

#define Transparent (-1)

struct grimage {
  final_fun f;                  /* Finalization function */
  long width, height;           /* Dimensions of the image */
  GWorldPtr data;               /* Pixels */
  GWorldPtr mask;               /* Mask for transparent points, or NULL */
};

#define Grimage_wosize \
  ((sizeof (struct grimage) + sizeof (value) - 1) / sizeof (value))

static void free_image (value vimage)
{
  struct grimage *im = (struct grimage *) Bp_val (vimage);

  if (im->data != NULL) DisposeGWorld (im->data);
  if (im->mask != NULL) DisposeGWorld (im->mask);
}

static value alloc_image (long w, long h)
{
  value res = alloc_final (Grimage_wosize, free_image, w*h, Max_image_mem);
  struct grimage *im = (struct grimage *) Bp_val (res);
  Rect r;
  QDErr err;

  im->width = w;
  im->height = h;
  im->mask = NULL;
  SetRect (&r, 0, 0, w, h);
  err = NewGWorld (&im->data, 32, &r, NULL, NULL, 0);
  if (err != noErr){
    im->data = NULL;
    gr_fail ("Cannot allocate image (error code %ld)", (void *) err);
  }
  return res;
}

static value gr_alloc_int_vect(mlsize_t size)
{
  value res;
  mlsize_t i;

  if (size <= Max_young_wosize) {
    res = alloc(size, 0);
  } else {
    res = alloc_shr(size, 0);
  }
  for (i = 0; i < size; i++) {
    Field(res, i) = Val_long(0);
  }
  return res;
}

/***********************************************************************/

value gr_open_graph (value vgeometry)
{
  int i;
  short err;
  Rect r;
  WStatusH st;

  if (winGraphics == NULL){
    Assert (gworld == NULL);

    i = sscanf (String_val (vgeometry), "%ldx%ld", &w0, &h0);
    if (i < 2){
      w0 = 640;
      h0 = 480;
    }
    if (w0 < kMinWindowWidth - kScrollBarWidth - 1){
      w0 = kMinWindowWidth - kScrollBarWidth - 1;
    }
    if (h0 < kMinWindowHeight - kScrollBarWidth - 1){
      h0 = kMinWindowHeight - kScrollBarWidth - 1;
    }

    err = WinOpenGraphics (w0, h0);
    if (err != noErr) goto failed;

    x0 = y0 = 0;

    st = WinGetStatus (winGraphics);   Assert (st != NULL);
    WELongRectToRect (&(*st)->destrect, &r);
    OffsetRect (&r, winGraphics->portRect.left, winGraphics->portRect.top);
    err = NewGWorld (&gworld, 0, &r, NULL, NULL, 0);
    if (err != noErr) goto failed;

    fgcolor.red = fgcolor.green = fgcolor.blue = 0;
  }
  /* Synchronise off-screen and on-screen by initialising everything. */
  grremember_mode = 1;
  grdisplay_mode = 1;
  gr_clear_graph (Val_unit);
  gr_moveto (Val_long (0), Val_long (0));
  gr_set_color (Val_long (0));
  gr_set_line_width (Val_long (0));
  gr_set_font ((value) "geneva");           /* XXX hack */
  gr_set_text_size (Val_long (12));

  return Val_unit;

  failed:
    if (gworld != NULL){
      DisposeGWorld (gworld);
      gworld = NULL;
    }
    if (winGraphics != NULL) WinCloseGraphics ();
    gr_fail ("open_graph failed (error %d)", (void *) (long) err);
    return Val_unit; /* not reached */
}

value gr_close_graph (value unit)
{
#pragma unused (unit)
  gr_check_open ();
  WinCloseGraphics ();
  DisposeGWorld (gworld);
  gworld = NULL;
  return Val_unit;
}

value gr_sigio_signal (value unit)            /* Not used on MacOS */
{
#pragma unused (unit)
  return Val_unit;
}

value gr_sigio_handler (value unit)           /* Not used on MacOS */
{
#pragma unused (unit)
  return Val_unit;
}

value gr_synchronize (value unit)
{
#pragma unused (unit)
  GrafPtr saveport;
  
  gr_check_open ();
  PushWindowPort (winGraphics);
  GraphUpdate ();
  PopPort;
  return Val_unit;
}

value gr_display_mode (value flag)
{
  grdisplay_mode = Bool_val (flag);
  return Val_unit;
}

value gr_remember_mode (value flag)
{
  grremember_mode = Bool_val (flag);
  return Val_unit;
}

value gr_clear_graph (value unit)
{
#pragma unused (unit)
  gr_check_open ();
  BeginOff
    EraseRect (&maxrect);
  On
    EraseRect (&maxrect);
  EndOffOn
  return unit;
}

value gr_size_x (value unit)
{
#pragma unused (unit)
  gr_check_open ();
  return Val_long (w0);
}

value gr_size_y (value unit)
{
#pragma unused (unit)
  gr_check_open ();
  return Val_long (h0);
}

value gr_set_color (value vrgb)
{
  long rgb = Long_val (vrgb);

  gr_check_open ();
  fgcolor.red = RGB8to16 ((rgb >> 16) & 0xFF);
  fgcolor.green = RGB8to16 ((rgb >> 8) & 0xFF);
  fgcolor.blue = RGB8to16 (rgb & 0xFF);
  BeginOffAlways
    RGBForeColor (&fgcolor);
  OnAlways
    RGBForeColor (&fgcolor);
  EndOffOnAlways
  return Val_unit;
}

value gr_plot (value vx, value vy)
{
  XY;

  gr_check_open ();
  BeginOff
    SetCPixel (Bx (x), By (y) - 1, &fgcolor);
  On
    SetCPixel (Wx (x), Wy (y) - 1, &fgcolor);
  EndOffOn
  return Val_unit;
}

value gr_point_color (value vx, value vy)
{
  XY;
  RGBColor c;

  gr_check_open ();
  if (x < 0 || x >= w0 || y < 0 || y >= h0) return Val_long (-1);
  BeginOffAlways
    GetCPixel (Bx (x), By (y) - 1, &c);
  EndOffAlways
  return Val_long (((c.red & 0xFF00) << 8)
                   | (c.green & 0xFF00)
                   | ((c.blue & 0xFF00) >> 8));
}

value gr_moveto (value vx, value vy)
{
  XY;

  gr_check_open ();
  cur_x = x; cur_y = y;
  return Val_unit;
}

value gr_current_x (value unit)
{
#pragma unused (unit)

  gr_check_open ();
  return Val_long (cur_x);
}

value gr_current_y (value unit)
{
#pragma unused (unit)

  gr_check_open ();
  return Val_long (cur_y);
}

value gr_lineto (value vx, value vy)
{
  XY;
  int delta = cur_width / 2;

  gr_check_open ();
  BeginOff
    MoveTo (Bx (cur_x) - delta, By (cur_y) - delta);
    LineTo (Bx (x) - delta, By (y) - delta);
  On
    MoveTo (Wx (cur_x) - delta, Wy (cur_y) - delta);
    LineTo (Wx (x) - delta, Wy (y) - delta);
  EndOffOn
  cur_x = x; cur_y = y;
  return Val_unit;
}

value gr_draw_rect (value vx, value vy, value vw, value vh)
{
  XY;
  long w = Long_val (vw), h = Long_val (vh);
  Rect r;
  int d1 = cur_width / 2;
  int d2 = cur_width - d1;

  gr_check_open ();
  BeginOff
    SetRect (&r, Bx (x) - d1, By (y+h) - d1, Bx (x+w) + d2, By (y) + d2);
    FrameRect (&r);
  On
    SetRect (&r, Wx (x) - d1, Wy (y+h) - d1, Wx (x+w) + d2, Wy (y) + d2);
    FrameRect (&r);
  EndOffOn
  return Val_unit;
}

value gr_draw_arc (value *argv, int argc)
{
#pragma unused (argc)
  return gr_draw_arc_nat (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
}

value gr_draw_arc_nat (value vx, value vy, value vrx, value vry, value va1,
                       value va2)
{
  XY;
  long rx = Long_val (vrx), ry = Long_val (vry);
  long a1 = Long_val (va1), a2 = Long_val (va2);
  Rect r;
  long qda1 = 90 - a1, qda2 = 90 - a2;
  int d1 = cur_width / 2;
  int d2 = cur_width - d1;

  gr_check_open ();
  BeginOff
    SetRect (&r, Bx(x-rx) - d1, By(y+ry) - d1, Bx(x+rx) + d2, By(y-ry) + d2);
    FrameArc (&r, qda1, qda2 - qda1);
  On
    SetRect (&r, Wx(x-rx) - d1, Wy(y+ry) - d1, Wx(x+rx) + d2, Wy(y-ry) + d2);
    FrameArc (&r, qda1, qda2 - qda1);
  EndOffOn
  return Val_unit;
}

value gr_set_line_width (value vwidth)
{
  short width = Int_val (vwidth);

  if (width == 0) width = 1;
  gr_check_open ();
  BeginOffAlways
    PenSize (width, width);
  OnAlways
    PenSize (width, width);
  EndOffOnAlways
  cur_width = width;
  return Val_unit;
}

value gr_fill_rect (value vx, value vy, value vw, value vh)
{
  XY;
  long w = Long_val (vw), h = Long_val (vh);
  Rect r;

  gr_check_open ();
  BeginOff
    SetRect (&r, Bx (x), By (y+h), Bx (x+w), By (y));
    PaintRect (&r);
  On
    SetRect (&r, Wx (x), Wy (y+h), Wx (x+w), Wy (y));
    PaintRect (&r);
  EndOffOn
  return Val_unit;
}

value gr_fill_poly (value vpoints)
{
  long i, n = Wosize_val (vpoints);
  PolyHandle p;

  #define Bxx(i) Bx (Int_val (Field (Field (vpoints, (i)), 0)))
  #define Byy(i) By (Int_val (Field (Field (vpoints, (i)), 1)))

  gr_check_open ();
  if (n < 1) return Val_unit;

  p = OpenPoly ();
  MoveTo (Bxx (0), Byy (0));
  for (i = 1; i < n; i++) LineTo (Bxx (i), Byy (i));
  ClosePoly ();
  BeginOff
    PaintPoly (p);
  On
    OffsetPoly (p, x0, y0);
    PaintPoly (p);
  EndOffOn
  KillPoly (p);
  return Val_unit;
}

value gr_fill_arc (value *argv, int argc)
{
#pragma unused (argc)
  return gr_fill_arc_nat (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
}

value gr_fill_arc_nat (value vx, value vy, value vrx, value vry, value va1,
                       value va2)
{
  XY;
  long rx = Long_val (vrx), ry = Long_val (vry);
  long a1 = Long_val (va1), a2 = Long_val (va2);
  Rect r;
  long qda1 = 90 - a1, qda2 = 90 - a2;

  gr_check_open ();
  BeginOff
    SetRect (&r, Bx (x-rx), By (y+ry), Bx (x+rx), By (y-ry));
    PaintArc (&r, qda1, qda2 - qda1);
  On
    SetRect (&r, Wx (x-rx), Wy (y+ry), Wx (x+rx), Wy (y-ry));
    PaintArc (&r, qda1, qda2 - qda1);
  EndOffOn
  return Val_unit;
}

static void draw_text (char *txt, unsigned long len)
{
  FontInfo info;
  unsigned long w;
  
  if (len > 32767) len = 32767;

  BeginOffAlways
    GetFontInfo (&info);
    w = TextWidth (txt, 0, len);
  EndOffAlways

  gr_check_open ();
  BeginOff
    MoveTo (Bx (cur_x), By (cur_y) - info.descent);
    DrawText (txt, 0, len);
  On
    MoveTo (Wx (cur_x), Wy (cur_y) - info.descent);
    DrawText (txt, 0, len);
  EndOffOn
  cur_x += w;
}

value gr_draw_char (value vchr)
{
  char c = Int_val (vchr);

  draw_text (&c, 1);
  return Val_unit;
}

value gr_draw_string (value vstr)
{
  mlsize_t len = string_length (vstr);
  char *str = String_val (vstr);

  draw_text (str, len);
  return Val_unit;
}

value gr_set_font (value vfontname)
{
  Str255 pfontname;
  short fontnum;

  gr_check_open ();
  CopyCStringToPascal (String_val (vfontname), pfontname);
  GetFNum (pfontname, &fontnum);
  BeginOffAlways
    TextFont (fontnum);
  OnAlways
    TextFont (fontnum);
  EndOffOnAlways
  cur_font = fontnum;
  return Val_unit;
}

value gr_set_text_size (value vsz)
{
  short sz = Int_val (vsz);

  gr_check_open ();
  BeginOffAlways
    TextSize (sz);
  OnAlways
    TextSize (sz);
  EndOffOnAlways
  cur_size = sz;
  return Val_unit;
}

value gr_text_size (value vstr)
{
  mlsize_t len = string_length (vstr);
  char *str = String_val (vstr);
  value result = alloc_tuple (2);
  FontInfo info;
  long w, h;

  BeginOffAlways
    GetFontInfo (&info);
    w = TextWidth (str, 0, len);
    h = info.ascent + info.descent;
  EndOffAlways
  Field (result, 0) = Val_long (w);
  Field (result, 1) = Val_long (h);
  return result;
}

value gr_make_image (value varray)
{
  long height = Wosize_val (varray);
  long width;
  long x, y;
  GWorldPtr w;
  value result, line;
  long color;
  RGBColor qdcolor;
  int has_transp = 0;
  CGrafPtr saveport;
  GDHandle savegdev;

  gr_check_open ();
  if (height == 0) return alloc_image (0, 0);
  width = Wosize_val (Field (varray, 0));
  for (y = 1; y < height; y++){
    if (Wosize_val (Field (varray, y)) != width){
      gr_fail("make_image: lines of different lengths", NULL);
    }
  }

  result = alloc_image (width, height);
  w = ((struct grimage *) Bp_val (result))->data;

  LockPixels (GetGWorldPixMap (w));
  GetGWorld (&saveport, &savegdev);
  SetGWorld ((CGrafPtr) w, NULL);
  for (y = 0; y < height; y++){
    line = Field (varray, y);
    for (x = 0; x < width; x++){
      color = Long_val (Field (line, x));
      if (color == Transparent) has_transp = 1;
      qdcolor.red = ((color >> 16) & 0xFF) | ((color >> 8) & 0xFF00);
      qdcolor.green = ((color >> 8) & 0xFF) | (color & 0xFF00);
      qdcolor.blue = (color & 0xFF) | ((color << 8) & 0xFF00);
      SetCPixel (x, y, &qdcolor);
    }
  }
  UnlockPixels (GetGWorldPixMap (w));

  if (has_transp){
    Rect r;
    QDErr err;

    SetRect (&r, 0, 0, width, height);
    err = NewGWorld (&w, 1, &r, NULL, NULL, 0);
    if (err != noErr){
      SetGWorld (saveport, savegdev);
      gr_fail ("Cannot allocate image (error code %d)", (void *) err);
    }
    LockPixels (GetGWorldPixMap (w));
    SetGWorld ((CGrafPtr) w, NULL);
    EraseRect (&maxrect);
    qdcolor.red = qdcolor.green = qdcolor.blue = 0;
    for (y = 0; y < height; y++){
      line = Field (varray, y);
      for (x = 0; x < width; x++){
        color = Long_val (Field (line, x));
        if (color != Transparent) SetCPixel (x, y, &qdcolor);
      }
    }
    UnlockPixels (GetGWorldPixMap (w));
    ((struct grimage *) Bp_val (result))->mask = w;
  }

  SetGWorld (saveport, savegdev);

  return result;
}

value gr_dump_image (value vimage)
{
  value result = Val_unit;
  struct grimage *im = (struct grimage *) Bp_val (vimage);
  long width = im->width;
  long height = im->height;
  long x, y;
  GWorldPtr wdata = im->data;
  GWorldPtr wmask = im->mask;
  CGrafPtr saveport;
  GDHandle savegdev;
  RGBColor qdcolor;
  value line;

  gr_check_open ();
  Begin_roots2 (vimage, result);
    result = gr_alloc_int_vect (height);
    for (y = 0; y < height; y++){
      value v = gr_alloc_int_vect (width);
      modify (&Field (result, y), v);
    }
  End_roots ();
  GetGWorld (&saveport, &savegdev);
  LockPixels (GetGWorldPixMap (wdata));
  SetGWorld (wdata, NULL);
  for (y = 0; y < height; y++){
    line = Field (result, y);
    for (x = 0; x < width; x++){
      GetCPixel (x, y, &qdcolor);
      Field (line, x) = Val_long (((qdcolor.red & 0xFF00) << 8)
                                  | (qdcolor.green & 0xFF00)
                                  | ((qdcolor.blue & 0xFF00) >> 8));
    }
  }
  UnlockPixels (GetGWorldPixMap (wdata));
  if (wmask != NULL){
    LockPixels (GetGWorldPixMap (wmask));
    SetGWorld (wmask, NULL);
    for (y = 0; y < height; y++){
      line = Field (result, y);
      for (x = 0; x < width; x++){
        if (!GetPixel (x, y)) Field (line, x) = Val_long (Transparent);
      }
    }
    UnlockPixels (GetGWorldPixMap (wmask));
  }
  SetGWorld (saveport, savegdev);
  return result;
}

value gr_draw_image (value vimage, value vx, value vy)
{
  XY;
  struct grimage *im = (struct grimage *) Bp_val (vimage);
  RGBColor forecolor, backcolor;
  Rect srcrect, dstrect;

  SetRect (&srcrect, 0, 0, im->width, im->height);
  if (im->mask != NULL){
    LockPixels (GetGWorldPixMap (im->data));
    LockPixels (GetGWorldPixMap (im->mask));
    BeginOff
      SetRect (&dstrect, Bx (x), By (y+im->height), Bx (x+im->width), By (y));
      GetBackColor (&backcolor);
      GetForeColor (&forecolor);
      BackColor (whiteColor);
      ForeColor (blackColor);
      CopyMask (&((GrafPtr) im->data)->portBits,
                &((GrafPtr) im->mask)->portBits,
                &((GrafPtr) gworld)->portBits,
                &srcrect, &srcrect, &dstrect);
      RGBBackColor (&backcolor);
      RGBForeColor (&forecolor);
    On
      SetRect (&dstrect, Wx (x), Wy (y+im->height), Wx (x+im->width), Wy (y));
      GetBackColor (&backcolor);
      GetForeColor (&forecolor);
      BackColor (whiteColor);
      ForeColor (blackColor);
      CopyMask (&((GrafPtr) im->data)->portBits,
                &((GrafPtr) im->mask)->portBits,
                &((GrafPtr) winGraphics)->portBits,
                &srcrect, &srcrect, &dstrect);
      RGBBackColor (&backcolor);
      RGBForeColor (&forecolor);
    EndOffOn
    UnlockPixels (GetGWorldPixMap (im->data));
    UnlockPixels (GetGWorldPixMap (im->mask));
  }else{
    LockPixels (GetGWorldPixMap (im->data));
    BeginOff
      SetRect (&dstrect, Bx (x), By (y+im->height), Bx (x+im->width), By (y));
      GetBackColor (&backcolor);
      GetForeColor (&forecolor);
      BackColor (whiteColor);
      ForeColor (blackColor);
      CopyBits (&((GrafPtr) im->data)->portBits, &((GrafPtr) gworld)->portBits,
                &srcrect, &dstrect, srcCopy, NULL);
      RGBBackColor (&backcolor);
      RGBForeColor (&forecolor);
    On
      SetRect (&dstrect, Wx (x), Wy (y+im->height), Wx (x+im->width), Wy (y));
      GetBackColor (&backcolor);
      GetForeColor (&forecolor);
      BackColor (whiteColor);
      ForeColor (blackColor);
      CopyBits (&((GrafPtr) im->data)->portBits,
                &((GrafPtr) winGraphics)->portBits, &srcrect, &dstrect, srcCopy,
                NULL);
      RGBBackColor (&backcolor);
      RGBForeColor (&forecolor);
    EndOffOn
    UnlockPixels (GetGWorldPixMap (im->data));
  }
  return Val_unit;
}

value gr_create_image (value vw, value vh)
{
  return alloc_image (Long_val (vw), Long_val (vh));
}

value gr_blit_image (value vimage, value vx, value vy)
{
  XY;
  struct grimage *im = (struct grimage *) Bp_val (vimage);
  Rect srcrect, dstrect, worldrect;
  CGrafPtr saveport;
  GDHandle savegdev;

  SetRect (&worldrect, 0, 0, w0, h0);
  SetRect (&srcrect, Bx (x), By (y+im->height), Bx (x+im->width), By (y));
  SectRect (&srcrect, &worldrect, &srcrect);
  dstrect = srcrect;
  OffsetRect (&dstrect, -Bx (x), -By (y+im->height));

  LockPixels (GetGWorldPixMap (im->data));
  LockPixels (GetGWorldPixMap (gworld));
  GetGWorld (&saveport, &savegdev);
  SetGWorld (im->data, NULL);
  BackColor (whiteColor);
  ForeColor (blackColor);
  CopyBits (&((GrafPtr) gworld)->portBits, &((GrafPtr) im->data)->portBits,
            &srcrect, &dstrect, srcCopy, NULL);
  SetGWorld (saveport, savegdev);
  UnlockPixels (GetGWorldPixMap (im->data));
  UnlockPixels (GetGWorldPixMap (gworld));
  return Val_unit;
}

int motion_requested = 0;
short motion_oldx, motion_oldy;
/* local coord versions of motion_oldx, motion_oldy */
static Point lastpt = {SHRT_MAX - 1, SHRT_MAX - 1};

#define Button_down_val 0
#define Button_up_val 1
#define Key_pressed_val 2
#define Mouse_motion_val 3
#define Poll_val 4

value gr_wait_event (value veventlist)
{
  int askmousedown = 0, askmouseup = 0, askkey = 0, askmotion = 0, askpoll = 0;
  GrafPtr saveport;
  value result;
  int mouse_x, mouse_y, button, keypressed, key;
  Point pt;
  int i;

  gr_check_open();
  PushWindowPort (winGraphics);

  while (veventlist != Val_int (0)) {
    switch (Int_val(Field (veventlist, 0))) {
    case Button_down_val:  askmousedown = 1; break;
    case Button_up_val:    askmouseup = 1;   break;
    case Key_pressed_val:  askkey = 1;       break;
    case Mouse_motion_val: askmotion = 1;    break;
    case Poll_val:         askpoll = 1;      break;
    default: Assert (0);
    }
    veventlist = Field (veventlist, 1);
  }

  enter_blocking_section ();

  while (1){
    while (graphQlen > 0 && graphQ[0].when + 300 < TickCount ()){
      DequeueEvent (0);
    }
    for (i = graphQlen - 1; i >= 0; i--){
      int what = graphQ[i].what;
      if (askpoll){
        if (what == keyDown || what == autoKey){
          GetMouse (&pt);
          mouse_x = pt.h;
          mouse_y = pt.v;
          button = Button ();
          keypressed = 1;
          key = graphQ[i].message & charCodeMask;
          goto gotevent;
        }
      }else if (   askmousedown && what == mouseDown
                || askmouseup && what == mouseUp){
        mouse_x = graphQ[i].where.h;
        mouse_y = graphQ[i].where.v;
        button = graphQ[i].what == mouseDown;
        keypressed = 0;
        DequeueEvent (i);
        goto gotevent;
      }else if (askkey && (what == keyDown || what == autoKey)){
        mouse_x = graphQ[i].where.h;
        mouse_y = graphQ[i].where.v;
        button = Button ();
        keypressed = 1;
        key = graphQ[i].message & charCodeMask;
        DequeueEvent (i);
        goto gotevent;
      }
    }
    GetMouse (&pt);
    if (askpoll || askmotion && (pt.h != lastpt.h || pt.v != lastpt.v)){
      mouse_x = pt.h;
      mouse_y = pt.v;
      button = Button ();
      keypressed = 0;
      goto gotevent;
    }
    if (askmotion){
      motion_requested = 1;
      pt = lastpt;
      LocalToGlobal (&pt);
      motion_oldx = pt.h;
      motion_oldy = pt.v;
    }
    GetAndProcessEvents (askmotion ? waitMove : waitEvent,
                         motion_oldx, motion_oldy);
  }

  gotevent:
    PopPort;
    leave_blocking_section ();  /* acquire master lock, handle signals */
    lastpt.h = mouse_x;
    lastpt.v = mouse_y;
    motion_requested = 0;
  
    result = alloc_tuple (5);
    Field (result, 0) = Val_int (Cx (mouse_x));
    Field (result, 1) = Val_int (Cy (mouse_y));
    Field (result, 2) = Val_bool (button);
    Field (result, 3) = Val_bool (keypressed);
    Field (result, 4) = Val_int (key);
    return result;
}

value gr_sound (value vfreq, value vdur)
{
  long freq = Long_val (vfreq);
  long dur = Long_val (vdur);
  long scale;
  Handle h;
  OSErr err;

  if (dur <= 0 || freq <= 0) return Val_unit;
  if (dur > 5000) dur = 5000;
  if (freq > 20000) gr_fail ("sound: frequency is too high", NULL);

  if      (freq > 11025) scale =   2;
  else if (freq >  5513) scale =   4;
  else if (freq >  1378) scale =   8;
  else if (freq >   345) scale =  32;
  else if (freq >    86) scale = 128;
  else                   scale = 512;

  h = GetResource ('snd ', 1000 + scale);
  if (h == NULL){
    gr_fail ("sound: resource error (code = %ld)", (void *) (long) ResError ());
  }
  err = HandToHand (&h);
  if (err != noErr) gr_fail ("sound: out of memory", NULL);
  *(unsigned short *)((*h)+kDurationOffset) = dur * 2;
  Assert (scale * freq < 0x10000);
  *(unsigned short *)((*h)+kSampleRateOffset) = scale * freq;
  HLock (h);
  err = SndPlay (NULL, (SndListHandle) h, false);
  HUnlock (h);
  if (err != noErr){
    gr_fail ("sound: cannot play sound (error code %ld)", (void *) (long) err);
  }

  return Val_unit;
}

value gr_set_window_title (value title)
{
  Str255 ptitle;
  
  strcpy ((char *) ptitle, String_val (title));
  c2pstr ((char *) ptitle);
  SetWTitle (winGraphics, ptitle);
  return Val_unit;
}