scheme_object.c

Go to the documentation of this file.

/* gEDA - GPL Electronic Design Automation
 * libgeda - gEDA's library - Scheme API
 * Copyright (C) 2010-2012 Peter Brett <peter@peter-b.co.uk>
 *
 * 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 USA
 */

#include <config.h>

#include "libgeda_priv.h"
#include "libgedaguile_priv.h"

SCM_SYMBOL (wrong_type_arg_sym , "wrong-type-arg");
SCM_SYMBOL (line_sym , "line");
SCM_SYMBOL (net_sym , "net");
SCM_SYMBOL (bus_sym , "bus");
SCM_SYMBOL (box_sym , "box");
SCM_SYMBOL (picture_sym , "picture");
SCM_SYMBOL (circle_sym , "circle");
SCM_SYMBOL (complex_sym , "complex");
SCM_SYMBOL (text_sym , "text");
SCM_SYMBOL (path_sym , "path");
SCM_SYMBOL (pin_sym , "pin");
SCM_SYMBOL (arc_sym , "arc");

SCM_SYMBOL (lower_left_sym , "lower-left");
SCM_SYMBOL (middle_left_sym , "middle-left");
SCM_SYMBOL (upper_left_sym , "upper-left");
SCM_SYMBOL (lower_center_sym , "lower-center");
SCM_SYMBOL (middle_center_sym , "middle-center");
SCM_SYMBOL (upper_center_sym , "upper-center");
SCM_SYMBOL (lower_right_sym , "lower-right");
SCM_SYMBOL (middle_right_sym , "middle-right");
SCM_SYMBOL (upper_right_sym , "upper-right");

SCM_SYMBOL (name_sym , "name");
SCM_SYMBOL (value_sym , "value");
SCM_SYMBOL (both_sym , "both");

SCM_SYMBOL (none_sym, "none");
SCM_SYMBOL (square_sym , "square");
SCM_SYMBOL (round_sym , "round");

SCM_SYMBOL (solid_sym , "solid");
SCM_SYMBOL (dotted_sym , "dotted");
SCM_SYMBOL (dashed_sym , "dashed");
SCM_SYMBOL (center_sym , "center");
SCM_SYMBOL (phantom_sym , "phantom");

SCM_SYMBOL (hollow_sym , "hollow");
SCM_SYMBOL (mesh_sym , "mesh");
SCM_SYMBOL (hatch_sym , "hatch");

SCM_SYMBOL (moveto_sym , "moveto");
SCM_SYMBOL (lineto_sym , "lineto");
SCM_SYMBOL (curveto_sym , "curveto");
SCM_SYMBOL (closepath_sym , "closepath");

void o_page_changed (TOPLEVEL *t, OBJECT *o)
{
  PAGE *p = o_get_page (t, o);
  if (p != NULL) p->CHANGED = TRUE;
}

GList *
edascm_to_object_glist (SCM objs, const char *subr)
{
  GList *result = NULL;
  SCM lst;

  SCM_ASSERT (scm_is_true (scm_list_p (objs)), objs, SCM_ARGn, subr);

  scm_dynwind_begin (0);
  scm_dynwind_unwind_handler ((void (*)(void *))g_list_free, result, 0);

  for (lst = objs; lst != SCM_EOL; lst = SCM_CDR (lst)) {
    SCM smob = SCM_CAR (lst);
    result = g_list_prepend (result, (gpointer) edascm_to_object (smob));
  }

  scm_remember_upto_here_1 (lst);

  scm_dynwind_end ();

  return g_list_reverse (result);
}

SCM
edascm_from_object_glist (const GList *objs)
{
  SCM lst = SCM_EOL;
  SCM rlst;
  GList *iter = (GList *) objs;

  while (iter != NULL) {
    lst = scm_cons (edascm_from_object (iter->data), lst);
    iter = g_list_next (iter);
  }

  rlst = scm_reverse (lst);

  scm_remember_upto_here_1 (lst);
  return rlst;
}

int
edascm_is_object_type (SCM smob, int type)
{
  if (!EDASCM_OBJECTP(smob)) return 0;

  OBJECT *obj = edascm_to_object (smob);
  return (obj->type == type);
}

SCM_DEFINE (copy_object, "%copy-object", 1, 0, 0,
            (SCM obj_s), "Copy an object.")
{
  SCM result;
  SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
              SCM_ARG1, s_copy_object);

  TOPLEVEL *toplevel = edascm_c_current_toplevel ();
  OBJECT *obj = edascm_to_object (obj_s);

  result = edascm_from_object (o_object_copy (toplevel, obj));

  /* At the moment, the only pointer to the object is owned by the
   * smob. */
  edascm_c_set_gc (result, TRUE);

  return result;
}

SCM_DEFINE (object_type, "%object-type", 1, 0, 0,
            (SCM obj_s), "Get an object smob's type")
{
  SCM result;

  SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
              SCM_ARG1, s_object_type);

  OBJECT *obj = edascm_to_object (obj_s);
  switch (obj->type) {
  case OBJ_LINE:    result = line_sym;       break;
  case OBJ_NET:     result = net_sym;        break;
  case OBJ_BUS:     result = bus_sym;        break;
  case OBJ_BOX:     result = box_sym;        break;
  case OBJ_PICTURE: result = picture_sym;    break;
  case OBJ_CIRCLE:  result = circle_sym;     break;
  case OBJ_PLACEHOLDER:
  case OBJ_COMPLEX: result = complex_sym;    break;
  case OBJ_TEXT:    result = text_sym;       break;
  case OBJ_PATH:    result = path_sym;       break;
  case OBJ_PIN:     result = pin_sym;        break;
  case OBJ_ARC:     result = arc_sym;        break;
  default:
    scm_misc_error (s_object_type, _("Object ~A has bad type '~A'"),
                    scm_list_2 (obj_s,
                                scm_integer_to_char (scm_from_int (obj->type))));
  }

  return result;
}

SCM_DEFINE (object_bounds, "%object-bounds", 0, 0, 1,
            (SCM rst_s), "Get the bounds of a list of objects")
{
  TOPLEVEL *toplevel = edascm_c_current_toplevel ();

  GList *obj_list = edascm_to_object_glist (rst_s, s_object_bounds);

  int success, left, top, right, bottom;
  if (toplevel->show_hidden_text) {
    success = world_get_object_glist_bounds (toplevel, obj_list,
                                             &left, &top, &right, &bottom);
  } else {
    toplevel->show_hidden_text = TRUE;
    o_recalc_object_glist (toplevel, obj_list);

    success = world_get_object_glist_bounds (toplevel, obj_list,
                                             &left, &top, &right, &bottom);

    toplevel->show_hidden_text = FALSE;
    o_recalc_object_glist (toplevel, obj_list);
  }

  SCM result = SCM_BOOL_F;
  if (success) {
    result = scm_cons (scm_cons (scm_from_int (min(left, right)),
                                 scm_from_int (max(top, bottom))),
                       scm_cons (scm_from_int (max(left, right)),
                                 scm_from_int (min(top, bottom))));
  }

  scm_remember_upto_here_1 (rst_s);
  return result;
}


SCM_DEFINE (object_stroke, "%object-stroke", 1, 0, 0,
            (SCM obj_s), "Get the stroke properties of an object.")
{
  SCM_ASSERT ((edascm_is_object_type (obj_s, OBJ_LINE)
               || edascm_is_object_type (obj_s, OBJ_BOX)
               || edascm_is_object_type (obj_s, OBJ_CIRCLE)
               || edascm_is_object_type (obj_s, OBJ_ARC)
               || edascm_is_object_type (obj_s, OBJ_PATH)),
              obj_s, SCM_ARG1, s_object_stroke);

  OBJECT *obj = edascm_to_object (obj_s);

  int end, type, width, length, space;
  o_get_line_options (obj, (OBJECT_END *) &end, (OBJECT_TYPE *) &type, &width,
                      &length, &space);

  SCM width_s = scm_from_int (width);
  SCM length_s = scm_from_int (length);
  SCM space_s = scm_from_int (space);

  SCM cap_s;
  switch (end) {
  case END_NONE: cap_s = none_sym; break;
  case END_SQUARE: cap_s = square_sym; break;
  case END_ROUND: cap_s = round_sym; break;
  default:
    scm_misc_error (s_object_stroke,
                    _("Object ~A has invalid stroke cap style ~A"),
                    scm_list_2 (obj_s, scm_from_int (end)));
  }

  SCM dash_s;
  switch (type) {
  case TYPE_SOLID: dash_s = solid_sym; break;
  case TYPE_DOTTED: dash_s = dotted_sym; break;
  case TYPE_DASHED: dash_s = dashed_sym; break;
  case TYPE_CENTER: dash_s = center_sym; break;
  case TYPE_PHANTOM: dash_s = phantom_sym; break;
  default:
    scm_misc_error (s_object_stroke,
                    _("Object ~A has invalid stroke dash style ~A"),
                    scm_list_2 (obj_s, scm_from_int (type)));
  }

  switch (type) {
  case TYPE_DASHED:
  case TYPE_CENTER:
  case TYPE_PHANTOM:
    return scm_list_5 (width_s, cap_s, dash_s, space_s, length_s);
  case TYPE_DOTTED:
    return scm_list_4 (width_s, cap_s, dash_s, space_s);
  default:
    return scm_list_3 (width_s, cap_s, dash_s);
  }
}

SCM_DEFINE (set_object_stroke_x, "%set-object-stroke!", 4, 2, 0,
            (SCM obj_s, SCM width_s, SCM cap_s, SCM dash_s, SCM space_s,
             SCM length_s), "Set the stroke properties of an object.")
{
  SCM_ASSERT ((edascm_is_object_type (obj_s, OBJ_LINE)
               || edascm_is_object_type (obj_s, OBJ_BOX)
               || edascm_is_object_type (obj_s, OBJ_CIRCLE)
               || edascm_is_object_type (obj_s, OBJ_ARC)
               || edascm_is_object_type (obj_s, OBJ_PATH)),
              obj_s, SCM_ARG1, s_set_object_stroke_x);

  TOPLEVEL *toplevel = edascm_c_current_toplevel ();
  OBJECT *obj = edascm_to_object (obj_s);
  int cap, type, width, length = -1, space = -1;

  SCM_ASSERT (scm_is_integer (width_s), width_s,
              SCM_ARG2, s_set_object_stroke_x);
  SCM_ASSERT (scm_is_symbol (cap_s), cap_s,
              SCM_ARG3, s_set_object_stroke_x);
  SCM_ASSERT (scm_is_symbol (dash_s), dash_s,
              SCM_ARG4, s_set_object_stroke_x);

  width = scm_to_int (width_s);

  if      (cap_s == none_sym)   { cap = END_NONE;   }
  else if (cap_s == square_sym) { cap = END_SQUARE; }
  else if (cap_s == round_sym)  { cap = END_ROUND;  }
  else {
    scm_misc_error (s_set_object_stroke_x,
                    _("Invalid stroke cap style ~A."),
                    scm_list_1 (cap_s));
  }

  if      (dash_s == solid_sym)   { type = TYPE_SOLID;   }
  else if (dash_s == dotted_sym)  { type = TYPE_DOTTED;  }
  else if (dash_s == dashed_sym)  { type = TYPE_DASHED;  }
  else if (dash_s == center_sym)  { type = TYPE_CENTER;  }
  else if (dash_s == phantom_sym) { type = TYPE_PHANTOM; }
  else {
    scm_misc_error (s_set_object_stroke_x,
                    _("Invalid stroke dash style ~A."),
                    scm_list_1 (dash_s));
  }

  switch (type) {
  case TYPE_DASHED:
  case TYPE_CENTER:
  case TYPE_PHANTOM:
    if (length_s == SCM_UNDEFINED) {
      scm_misc_error (s_set_object_stroke_x,
                      _("Missing dash length parameter for dash style ~A."),
                      scm_list_1 (length_s));
    }
    SCM_ASSERT (scm_is_integer (length_s), length_s,
                SCM_ARG6, s_set_object_stroke_x);
    length = scm_to_int (length_s);
    /* This case intentionally falls through */
  case TYPE_DOTTED:
    if (space_s == SCM_UNDEFINED) {
      scm_misc_error (s_set_object_stroke_x,
                      _("Missing dot/dash space parameter for dash style ~A."),
                      scm_list_1 (space_s));
    }
    SCM_ASSERT (scm_is_integer (space_s), space_s,
                SCM_ARG5, s_set_object_stroke_x);
    space = scm_to_int (space_s);
    /* This case intentionally falls through */
  }

  o_set_line_options (toplevel, obj, cap, type, width, length, space);
  o_page_changed (toplevel, obj);

  return obj_s;
}

SCM_DEFINE (object_fill, "%object-fill", 1, 0, 0,
            (SCM obj_s), "Get the fill properties of an object.")
{
  SCM_ASSERT ((edascm_is_object_type (obj_s, OBJ_BOX)
               || edascm_is_object_type (obj_s, OBJ_CIRCLE)
               || edascm_is_object_type (obj_s, OBJ_PATH)),
              obj_s, SCM_ARG1, s_object_fill);

  OBJECT *obj = edascm_to_object (obj_s);

  int type, width, pitch1, angle1, pitch2, angle2;
  o_get_fill_options (obj, (OBJECT_FILLING *) &type, &width, &pitch1, &angle1,
                      &pitch2, &angle2);

  SCM width_s = scm_from_int (width);
  SCM pitch1_s = scm_from_int (pitch1);
  SCM angle1_s = scm_from_int (angle1);
  SCM pitch2_s = scm_from_int (pitch2);
  SCM angle2_s = scm_from_int (angle2);

  SCM type_s;
  switch (type) {
  case FILLING_HOLLOW: type_s = hollow_sym; break;
  case FILLING_FILL: type_s = solid_sym; break;
  case FILLING_MESH: type_s = mesh_sym; break;
  case FILLING_HATCH: type_s = hatch_sym; break;
  default:
    scm_misc_error (s_object_fill,
                    _("Object ~A has invalid fill style ~A"),
                    scm_list_2 (obj_s, scm_from_int (type)));
  }

  switch (type) {
  case FILLING_MESH:
    return scm_list_n (type_s, width_s, pitch1_s, angle1_s, pitch2_s, angle2_s,
                       SCM_UNDEFINED);
  case FILLING_HATCH:
    return scm_list_4 (type_s, width_s, pitch1_s, angle1_s);
  default:
    return scm_list_1 (type_s);
  }
}

SCM_DEFINE (set_object_fill_x, "%set-object-fill!", 2, 5, 0,
            (SCM obj_s, SCM type_s, SCM width_s, SCM space1_s, SCM angle1_s,
             SCM space2_s, SCM angle2_s),
            "Set the fill properties of an object.")
{
  SCM_ASSERT ((edascm_is_object_type (obj_s, OBJ_BOX)
               || edascm_is_object_type (obj_s, OBJ_CIRCLE)
               || edascm_is_object_type (obj_s, OBJ_PATH)),
              obj_s, SCM_ARG1, s_set_object_fill_x);

  TOPLEVEL *toplevel = edascm_c_current_toplevel ();
  OBJECT *obj = edascm_to_object (obj_s);
  int type, width = -1, angle1 = -1, space1 = -1, angle2 = -1, space2 = -1;

  if      (type_s == hollow_sym)   { type = FILLING_HOLLOW;   }
  else if (type_s == solid_sym) { type = FILLING_FILL; }
  else if (type_s == hatch_sym)  { type = FILLING_HATCH;  }
  else if (type_s == mesh_sym)  { type = FILLING_MESH;  }
  else {
    scm_misc_error (s_set_object_fill_x,
                    _("Invalid fill style ~A."),
                    scm_list_1 (type_s));
  }

  switch (type) {
  case FILLING_MESH:
    if (space2_s == SCM_UNDEFINED) {
      scm_misc_error (s_set_object_fill_x,
                      _("Missing second space parameter for fill style ~A."),
                      scm_list_1 (space2_s));
    }
    SCM_ASSERT (scm_is_integer (space2_s), space2_s,
                SCM_ARG6, s_set_object_fill_x);
    space2 = scm_to_int (space2_s);

    if (angle2_s == SCM_UNDEFINED) {
      scm_misc_error (s_set_object_fill_x,
                      _("Missing second angle parameter for fill style ~A."),
                      scm_list_1 (angle2_s));
    }
    SCM_ASSERT (scm_is_integer (angle2_s), angle2_s,
                SCM_ARG7, s_set_object_fill_x);
    angle2 = scm_to_int (angle2_s);
    /* This case intentionally falls through */
  case FILLING_HATCH:
    if (width_s == SCM_UNDEFINED) {
      scm_misc_error (s_set_object_fill_x,
                      _("Missing stroke width parameter for fill style ~A."),
                      scm_list_1 (width_s));
    }
    SCM_ASSERT (scm_is_integer (width_s), width_s,
                SCM_ARG3, s_set_object_fill_x);
    width = scm_to_int (width_s);

    if (space1_s == SCM_UNDEFINED) {
      scm_misc_error (s_set_object_fill_x,
                      _("Missing space parameter for fill style ~A."),
                      scm_list_1 (space1_s));
    }
    SCM_ASSERT (scm_is_integer (space1_s), space1_s,
                SCM_ARG4, s_set_object_fill_x);
    space1 = scm_to_int (space1_s);

    if (angle1_s == SCM_UNDEFINED) {
      scm_misc_error (s_set_object_fill_x,
                      _("Missing angle parameter for fill style ~A."),
                      scm_list_1 (angle1_s));
    }
    SCM_ASSERT (scm_is_integer (angle1_s), angle1_s,
                SCM_ARG5, s_set_object_fill_x);
    angle1 = scm_to_int (angle1_s);
    /* This case intentionally falls through */
  }

  o_set_fill_options (toplevel, obj, type, width,
                      space1, angle1, space2, angle2);
  o_page_changed (toplevel, obj);

  return obj_s;
}

SCM_DEFINE (object_color, "%object-color", 1, 0, 0,
            (SCM obj_s), "Get the color of an object.")
{
  SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
              SCM_ARG1, s_object_color);

  OBJECT *obj = edascm_to_object (obj_s);
  return scm_from_int (obj->color);
}

SCM_DEFINE (set_object_color_x, "%set-object-color!", 2, 0, 0,
            (SCM obj_s, SCM color_s), "Set the color of an object.")
{
  SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
              SCM_ARG1, s_set_object_color_x);
  SCM_ASSERT (scm_is_integer (color_s), color_s,
              SCM_ARG2, s_set_object_color_x);

  TOPLEVEL *toplevel = edascm_c_current_toplevel ();
  OBJECT *obj = edascm_to_object (obj_s);
  o_set_color (toplevel, obj, scm_to_int (color_s));

  o_page_changed (toplevel, obj);

  return obj_s;
}

SCM_DEFINE (make_line, "%make-line", 0, 0, 0,
            (), "Create a new line object.")
{
  OBJECT *obj = o_line_new (edascm_c_current_toplevel (),
                            OBJ_LINE, DEFAULT_COLOR,
                            0, 0, 0, 0);

  SCM result = edascm_from_object (obj);

  /* At the moment, the only pointer to the object is owned by the
   * smob. */
  edascm_c_set_gc (result, TRUE);

  return result;
}

SCM_DEFINE (set_line_x, "%set-line!", 6, 0, 0,
            (SCM line_s, SCM x1_s, SCM y1_s, SCM x2_s, SCM y2_s, SCM color_s),
            "Set line parameters.")
{
  SCM_ASSERT ((edascm_is_object_type (line_s, OBJ_LINE)
               || edascm_is_object_type (line_s, OBJ_NET)
               || edascm_is_object_type (line_s, OBJ_BUS)
               || edascm_is_object_type (line_s, OBJ_PIN)),
              line_s, SCM_ARG1, s_set_line_x);

  SCM_ASSERT (scm_is_integer (x1_s),    x1_s,    SCM_ARG2, s_set_line_x);
  SCM_ASSERT (scm_is_integer (y1_s),    y1_s,    SCM_ARG3, s_set_line_x);
  SCM_ASSERT (scm_is_integer (x2_s),    x2_s,    SCM_ARG4, s_set_line_x);
  SCM_ASSERT (scm_is_integer (y2_s),    y2_s,    SCM_ARG5, s_set_line_x);
  SCM_ASSERT (scm_is_integer (color_s), color_s, SCM_ARG6, s_set_line_x);

  TOPLEVEL *toplevel = edascm_c_current_toplevel ();
  OBJECT *obj = edascm_to_object (line_s);
  int x1 = scm_to_int (x1_s);
  int y1 = scm_to_int (y1_s);
  int x2 = scm_to_int (x2_s);
  int y2 = scm_to_int (y2_s);

  /* We may need to update connectivity. */
  s_conn_remove_object (toplevel, obj);

  switch (obj->type) {
  case OBJ_LINE:
    o_line_modify (toplevel, obj, x1, y1, LINE_END1);
    o_line_modify (toplevel, obj, x2, y2, LINE_END2);
    break;
  case OBJ_NET:
    o_net_modify (toplevel, obj, x1, y1, 0);
    o_net_modify (toplevel, obj, x2, y2, 1);
    break;
  case OBJ_BUS:
    o_bus_modify (toplevel, obj, x1, y1, 0);
    o_bus_modify (toplevel, obj, x2, y2, 1);
    break;
  case OBJ_PIN:
    /* Swap ends according to pin's whichend flag. */
    o_pin_modify (toplevel, obj, x1, y1, obj->whichend ? 1 : 0);
    o_pin_modify (toplevel, obj, x2, y2, obj->whichend ? 0 : 1);
    break;
  default:
    return line_s;
  }
  o_set_color (toplevel, obj, scm_to_int (color_s));

  /* We may need to update connectivity. */
  s_tile_update_object (toplevel, obj);
  s_conn_update_object (toplevel, obj);

  o_page_changed (toplevel, obj);

  return line_s;
}

SCM_DEFINE (line_info, "%line-info", 1, 0, 0,
            (SCM line_s), "Get line parameters.")
{
  SCM_ASSERT ((edascm_is_object_type (line_s, OBJ_LINE)
               || edascm_is_object_type (line_s, OBJ_NET)
               || edascm_is_object_type (line_s, OBJ_BUS)
               || edascm_is_object_type (line_s, OBJ_PIN)),
              line_s, SCM_ARG1, s_line_info);

  OBJECT *obj = edascm_to_object (line_s);
  SCM x1 = scm_from_int (obj->line->x[0]);
  SCM y1 = scm_from_int (obj->line->y[0]);
  SCM x2 = scm_from_int (obj->line->x[1]);
  SCM y2 = scm_from_int (obj->line->y[1]);
  SCM color = scm_from_int (obj->color);

  /* Swap ends according to pin's whichend flag. */
  if ((obj->type == OBJ_PIN) && obj->whichend) {
    SCM s;
    s = x1; x1 = x2; x2 = s;
    s = y1; y1 = y2; y2 = s;
  }

  return scm_list_n (x1, y1, x2, y2, color, SCM_UNDEFINED);
}

SCM_DEFINE (make_net, "%make-net", 0, 0, 0,
            (), "Create a new net object.")
{
  OBJECT *obj;
  SCM result;

  obj = o_net_new (edascm_c_current_toplevel (),
                   OBJ_NET, NET_COLOR, 0, 0, 0, 0);


  result = edascm_from_object (obj);

  /* At the moment, the only pointer to the object is owned by the
   * smob. */
  edascm_c_set_gc (result, 1);

  return result;
}

SCM_DEFINE (make_bus, "%make-bus", 0, 0, 0,
            (), "Create a new bus object.")
{
  OBJECT *obj;
  SCM result;

  obj = o_bus_new (edascm_c_current_toplevel (),
                   OBJ_BUS, BUS_COLOR, 0, 0, 0, 0,
                   0); /* Bus ripper direction */

  result = edascm_from_object (obj);

  /* At the moment, the only pointer to the object is owned by the
   * smob. */
  edascm_c_set_gc (result, 1);

  return result;
}

SCM_DEFINE (make_pin, "%make-pin", 1, 0, 0,
            (SCM type_s), "Create a new pin object.")
{
  SCM_ASSERT (scm_is_symbol (type_s),
              type_s, SCM_ARG1, s_make_pin);

  int type;
  if (type_s == net_sym) {
    type = PIN_TYPE_NET;
  } else if (type_s == bus_sym) {
    type = PIN_TYPE_BUS;
  } else {
    scm_misc_error (s_make_pin,
                    _("Invalid pin type ~A, must be 'net or 'bus"),
                    scm_list_1 (type_s));
  }

  OBJECT *obj = o_pin_new (edascm_c_current_toplevel (),
                           OBJ_PIN, PIN_COLOR, 0, 0, 0, 0, type, 0);
  SCM result = edascm_from_object (obj);

  /* At the moment, the only pointer to the object is owned by the
   * smob. */
  edascm_c_set_gc (result, 1);

  return result;
}

SCM_DEFINE (pin_type, "%pin-type", 1, 0, 0,
            (SCM pin_s), "Get the type of a pin object.")
{
  SCM_ASSERT (edascm_is_object_type (pin_s, OBJ_PIN), pin_s,
              SCM_ARG1, s_pin_type);

  OBJECT *obj = edascm_to_object (pin_s);
  SCM result;

  switch (obj->pin_type) {
  case PIN_TYPE_NET:
    result = net_sym;
    break;
  case PIN_TYPE_BUS:
    result = bus_sym;
    break;
  default:
    scm_misc_error (s_make_pin,
                    _("Object ~A has invalid pin type."),
                    scm_list_1 (pin_s));
  }

  return result;
}

SCM_DEFINE (make_box, "%make-box", 0, 0, 0,
            (), "Create a new box object.")
{
  OBJECT *obj = o_box_new (edascm_c_current_toplevel (),
                           OBJ_BOX, DEFAULT_COLOR,
                           0, 0, 0, 0);

  SCM result = edascm_from_object (obj);

  /* At the moment, the only pointer to the object is owned by the
   * smob. */
  edascm_c_set_gc (result, 1);

  return result;
}

SCM_DEFINE (set_box_x, "%set-box!", 6, 0, 0,
            (SCM box_s, SCM x1_s, SCM y1_s, SCM x2_s, SCM y2_s, SCM color_s),
            "Set box parameters.")
{
  SCM_ASSERT (edascm_is_object_type (box_s, OBJ_BOX), box_s,
              SCM_ARG1, s_set_box_x);
  SCM_ASSERT (scm_is_integer (x1_s),    x1_s,    SCM_ARG2, s_set_box_x);
  SCM_ASSERT (scm_is_integer (y1_s),    y1_s,    SCM_ARG3, s_set_box_x);
  SCM_ASSERT (scm_is_integer (x2_s),    x2_s,    SCM_ARG4, s_set_box_x);
  SCM_ASSERT (scm_is_integer (y2_s),    y2_s,    SCM_ARG5, s_set_box_x);
  SCM_ASSERT (scm_is_integer (color_s), color_s, SCM_ARG6, s_set_box_x);

  TOPLEVEL *toplevel = edascm_c_current_toplevel ();
  OBJECT *obj = edascm_to_object (box_s);
  o_box_modify_all (toplevel, obj,
                    scm_to_int (x1_s), scm_to_int (y1_s),
                    scm_to_int (x2_s), scm_to_int (y2_s));
  o_set_color (toplevel, obj, scm_to_int (color_s));

  o_page_changed (toplevel, obj);

  return box_s;
}

SCM_DEFINE (box_info, "%box-info", 1, 0, 0,
            (SCM box_s), "Get box parameters.")
{
  SCM_ASSERT (edascm_is_object_type (box_s, OBJ_BOX), box_s,
              SCM_ARG1, s_box_info);

  OBJECT *obj = edascm_to_object (box_s);

  return scm_list_n (scm_from_int (obj->box->upper_x),
                     scm_from_int (obj->box->upper_y),
                     scm_from_int (obj->box->lower_x),
                     scm_from_int (obj->box->lower_y),
                     scm_from_int (obj->color),
                     SCM_UNDEFINED);
}

SCM_DEFINE (make_circle, "%make-circle", 0, 0, 0,
            (), "Create a new circle object.")
{
  OBJECT *obj = o_circle_new (edascm_c_current_toplevel (),
                              OBJ_CIRCLE, DEFAULT_COLOR,
                              0, 0, 1);

  SCM result = edascm_from_object (obj);

  /* At the moment, the only pointer to the object is owned by the
   * smob. */
  edascm_c_set_gc (result, 1);

  return result;
}

SCM_DEFINE (set_circle_x, "%set-circle!", 5, 0, 0,
            (SCM circle_s, SCM x_s, SCM y_s, SCM r_s, SCM color_s),
            "Set circle parameters")
{
  SCM_ASSERT (edascm_is_object_type (circle_s, OBJ_CIRCLE), circle_s,
              SCM_ARG1, s_set_circle_x);
  SCM_ASSERT (scm_is_integer (x_s),     x_s,     SCM_ARG2, s_set_circle_x);
  SCM_ASSERT (scm_is_integer (y_s),     y_s,     SCM_ARG3, s_set_circle_x);
  SCM_ASSERT (scm_is_integer (r_s),     r_s,     SCM_ARG4, s_set_circle_x);
  SCM_ASSERT (scm_is_integer (color_s), color_s, SCM_ARG5, s_set_circle_x);

  TOPLEVEL *toplevel = edascm_c_current_toplevel ();
  OBJECT *obj = edascm_to_object (circle_s);
  o_circle_modify (toplevel, obj, scm_to_int(x_s), scm_to_int(y_s),
                   CIRCLE_CENTER);
  o_circle_modify (toplevel, obj, scm_to_int(r_s), 0, CIRCLE_RADIUS);
  o_set_color (toplevel, obj, scm_to_int (color_s));

  o_page_changed (toplevel, obj);

  return circle_s;
}

SCM_DEFINE (circle_info, "%circle-info", 1, 0, 0,
            (SCM circle_s), "Get circle parameters.")
{
  SCM_ASSERT (edascm_is_object_type (circle_s, OBJ_CIRCLE),
              circle_s, SCM_ARG1, s_circle_info);

  OBJECT *obj = edascm_to_object (circle_s);

  return scm_list_n (scm_from_int (obj->circle->center_x),
                     scm_from_int (obj->circle->center_y),
                     scm_from_int (obj->circle->radius),
                     scm_from_int (obj->color),
                     SCM_UNDEFINED);
}

SCM_DEFINE (make_arc, "%make-arc", 0, 0, 0,
            (), "Create a new arc object.")
{
  OBJECT *obj = o_arc_new (edascm_c_current_toplevel (),
                              OBJ_ARC, DEFAULT_COLOR,
                           0, 0, 1, 0, 0);

  SCM result = edascm_from_object (obj);

  /* At the moment, the only pointer to the object is owned by the
   * smob. */
  edascm_c_set_gc (result, 1);

  return result;
}

SCM_DEFINE (set_arc_x, "%set-arc!", 7, 0, 0,
            (SCM arc_s, SCM x_s, SCM y_s, SCM r_s, SCM start_angle_s,
             SCM end_angle_s, SCM color_s),
            "Set arc parameters")
{
  SCM_ASSERT (edascm_is_object_type (arc_s, OBJ_ARC), arc_s,
              SCM_ARG1, s_set_arc_x);
  SCM_ASSERT (scm_is_integer (x_s),     x_s,     SCM_ARG2, s_set_arc_x);
  SCM_ASSERT (scm_is_integer (y_s),     y_s,     SCM_ARG3, s_set_arc_x);
  SCM_ASSERT (scm_is_integer (r_s),     r_s,     SCM_ARG4, s_set_arc_x);
  SCM_ASSERT (scm_is_integer (color_s), color_s, SCM_ARG7, s_set_arc_x);
  SCM_ASSERT (scm_is_integer (start_angle_s),
                                  start_angle_s, SCM_ARG5, s_set_arc_x);
  SCM_ASSERT (scm_is_integer (end_angle_s),
                                  end_angle_s, SCM_ARG6, s_set_arc_x);

  TOPLEVEL *toplevel = edascm_c_current_toplevel ();
  OBJECT *obj = edascm_to_object (arc_s);
  o_arc_modify (toplevel, obj, scm_to_int(x_s), scm_to_int(y_s),
                   ARC_CENTER);
  o_arc_modify (toplevel, obj, scm_to_int(r_s), 0, ARC_RADIUS);
  o_arc_modify (toplevel, obj, scm_to_int(start_angle_s), 0, ARC_START_ANGLE);
  o_arc_modify (toplevel, obj, scm_to_int(end_angle_s), 0, ARC_END_ANGLE);
  o_set_color (toplevel, obj, scm_to_int (color_s));

  o_page_changed (toplevel, obj);

  return arc_s;
}

SCM_DEFINE (arc_info, "%arc-info", 1, 0, 0,
            (SCM arc_s), "Get arc parameters.")
{
  SCM_ASSERT (edascm_is_object_type (arc_s, OBJ_ARC),
              arc_s, SCM_ARG1, s_arc_info);

  OBJECT *obj = edascm_to_object (arc_s);

  return scm_list_n (scm_from_int (obj->arc->x),
                     scm_from_int (obj->arc->y),
                     scm_from_int (obj->arc->width / 2),
                     scm_from_int (obj->arc->start_angle),
                     scm_from_int (obj->arc->end_angle),
                     scm_from_int (obj->color),
                     SCM_UNDEFINED);
}

SCM_DEFINE (make_text, "%make-text", 0, 0, 0,
            (), "Create a new text object.")
{
  OBJECT *obj = o_text_new (edascm_c_current_toplevel (),
                            OBJ_TEXT, DEFAULT_COLOR,
                            0, 0, LOWER_LEFT, 0, "", 10,
                            VISIBLE, SHOW_NAME_VALUE);

  SCM result = edascm_from_object (obj);

  /* At the moment, the only pointer to the object is owned by the
   * smob. */
  edascm_c_set_gc (result, 1);

  return result;
}

SCM_DEFINE (set_text_x, "%set-text!", 10, 0, 0,
            (SCM text_s, SCM x_s, SCM y_s, SCM align_s, SCM angle_s,
             SCM string_s, SCM size_s, SCM visible_s, SCM show_s, SCM color_s),
            "Set text parameters")
{
  SCM_ASSERT (edascm_is_object_type (text_s, OBJ_TEXT), text_s,
              SCM_ARG1, s_set_text_x);
  SCM_ASSERT (scm_is_integer (x_s),     x_s,      SCM_ARG2, s_set_text_x);
  SCM_ASSERT (scm_is_integer (y_s),     y_s,      SCM_ARG3, s_set_text_x);
  SCM_ASSERT (scm_is_symbol (align_s),  align_s,  SCM_ARG4, s_set_text_x);
  SCM_ASSERT (scm_is_integer (angle_s), angle_s,  SCM_ARG5, s_set_text_x);
  SCM_ASSERT (scm_is_string (string_s), string_s, SCM_ARG6, s_set_text_x);
  SCM_ASSERT (scm_is_integer (size_s),  size_s,   SCM_ARG7, s_set_text_x);

  SCM_ASSERT (scm_is_symbol (show_s),    show_s,     9, s_set_text_x);
  SCM_ASSERT (scm_is_integer (color_s),  color_s,   10, s_set_text_x);

  TOPLEVEL *toplevel = edascm_c_current_toplevel ();
  OBJECT *obj = edascm_to_object (text_s);

  /* Alignment. Sadly we can't switch on pointers. :-( */
  int align;
  if      (align_s == lower_left_sym)    { align = LOWER_LEFT;    }
  else if (align_s == middle_left_sym)   { align = MIDDLE_LEFT;   }
  else if (align_s == upper_left_sym)    { align = UPPER_LEFT;    }
  else if (align_s == lower_center_sym)  { align = LOWER_MIDDLE;  }
  else if (align_s == middle_center_sym) { align = MIDDLE_MIDDLE; }
  else if (align_s == upper_center_sym)  { align = UPPER_MIDDLE;  }
  else if (align_s == lower_right_sym)   { align = LOWER_RIGHT;   }
  else if (align_s == middle_right_sym)  { align = MIDDLE_RIGHT;  }
  else if (align_s == upper_right_sym)   { align = UPPER_RIGHT;   }
  else {
    scm_misc_error (s_set_text_x,
                    _("Invalid text alignment ~A."),
                    scm_list_1 (align_s));
  }

  /* Angle */
  int angle = scm_to_int (angle_s);
  switch (angle) {
  case 0:
  case 90:
  case 180:
  case 270:
    /* These are all fine. */
    break;
  default:
    /* Otherwise, not fine. */
    scm_misc_error (s_set_text_x,
                    _("Invalid text angle ~A. Must be 0, 90, 180, or 270 degrees"),
                    scm_list_1 (angle_s));
  }

  /* Visibility */
  int visibility;
  if (scm_is_false (visible_s)) {
    visibility = INVISIBLE;
  } else {
    visibility = VISIBLE;
  }

  /* Name/value visibility */
  int show;
  if      (show_s == name_sym)  { show = SHOW_NAME;       }
  else if (show_s == value_sym) { show = SHOW_VALUE;      }
  else if (show_s == both_sym)  { show = SHOW_NAME_VALUE; }
  else {
    scm_misc_error (s_set_text_x,
                    _("Invalid text name/value visibility ~A."),
                    scm_list_1 (show_s));
  }

  /* Actually make changes */
  o_emit_pre_change_notify (toplevel, obj);

  obj->text->x = scm_to_int (x_s);
  obj->text->y = scm_to_int (y_s);
  obj->text->alignment = align;
  obj->text->angle = angle;

  obj->text->size = scm_to_int (size_s);
  obj->visibility = visibility;
  obj->show_name_value = show;

  o_emit_change_notify (toplevel, obj);

  char *tmp = scm_to_utf8_string (string_s);
  o_text_set_string (toplevel, obj, tmp);
  free (tmp);

  o_text_recreate (toplevel, obj);

  /* Color */
  o_set_color (toplevel, obj, scm_to_int (color_s));

  o_page_changed (toplevel, obj);

  return text_s;
}

SCM_DEFINE (text_info, "%text-info", 1, 0, 0,
            (SCM text_s), "Get text parameters.")
{
  SCM_ASSERT (edascm_is_object_type (text_s, OBJ_TEXT),
              text_s, SCM_ARG1, s_text_info);

  TOPLEVEL *toplevel = edascm_c_current_toplevel ();
  OBJECT *obj = edascm_to_object (text_s);
  SCM align_s, visible_s, show_s;

  switch (obj->text->alignment) {
  case LOWER_LEFT:    align_s = lower_left_sym;    break;
  case MIDDLE_LEFT:   align_s = middle_left_sym;   break;
  case UPPER_LEFT:    align_s = upper_left_sym;    break;
  case LOWER_MIDDLE:  align_s = lower_center_sym;  break;
  case MIDDLE_MIDDLE: align_s = middle_center_sym; break;
  case UPPER_MIDDLE:  align_s = upper_center_sym;  break;
  case LOWER_RIGHT:   align_s = lower_right_sym;   break;
  case MIDDLE_RIGHT:  align_s = middle_right_sym;  break;
  case UPPER_RIGHT:   align_s = upper_right_sym;   break;
  default:
    scm_misc_error (s_text_info,
                    _("Text object ~A has invalid text alignment ~A"),
                    scm_list_2 (text_s, scm_from_int (obj->text->alignment)));
  }

  switch (obj->visibility) {
  case VISIBLE:   visible_s = SCM_BOOL_T; break;
  case INVISIBLE: visible_s = SCM_BOOL_F; break;
  default:
    scm_misc_error (s_text_info,
                    _("Text object ~A has invalid visibility ~A"),
                    scm_list_2 (text_s, scm_from_int (obj->visibility)));
  }

  switch (obj->show_name_value) {
  case SHOW_NAME:       show_s = name_sym;  break;
  case SHOW_VALUE:      show_s = value_sym; break;
  case SHOW_NAME_VALUE: show_s = both_sym;  break;
  default:
    scm_misc_error (s_text_info,
                    _("Text object ~A has invalid text attribute visibility ~A"),
                    scm_list_2 (text_s, scm_from_int (obj->show_name_value)));
  }

  return scm_list_n (scm_from_int (obj->text->x),
                     scm_from_int (obj->text->y),
                     align_s,
                     scm_from_int (obj->text->angle),
                     scm_from_utf8_string (o_text_get_string (toplevel, obj)),
                     scm_from_int (obj->text->size),
                     visible_s,
                     show_s,
                     scm_from_int (obj->color),
                     SCM_UNDEFINED);
}

SCM_DEFINE (object_connections, "%object-connections", 1, 0, 0,
            (SCM obj_s), "Get objects that are connected to an object.")
{
  /* Ensure that the argument is an object smob */
  SCM_ASSERT (edascm_is_object (obj_s), obj_s,
              SCM_ARG1, s_object_connections);

  TOPLEVEL *toplevel = edascm_c_current_toplevel ();
  OBJECT *obj = edascm_to_object (obj_s);
  if (o_get_page (toplevel, obj) == NULL) {
    scm_error (edascm_object_state_sym,
               s_object_connections,
               _("Object ~A is not included in a page."),
               scm_list_1 (obj_s), SCM_EOL);
  }

  GList *lst = s_conn_return_others (NULL, obj);
  SCM result = edascm_from_object_glist (lst);
  g_list_free (lst);
  return result;
}

SCM_DEFINE (object_complex, "%object-complex", 1, 0, 0,
            (SCM obj_s), "Get containing complex object of an object.")
{
  /* Ensure that the argument is an object smob */
  SCM_ASSERT (edascm_is_object (obj_s), obj_s,
              SCM_ARG1, s_object_complex);

  TOPLEVEL *toplevel = edascm_c_current_toplevel ();
  OBJECT *obj = edascm_to_object (obj_s);
  OBJECT *parent = o_get_parent (toplevel, obj);

  if (parent == NULL) return SCM_BOOL_F;

  return edascm_from_object (parent);
}

SCM_DEFINE (make_path, "%make-path", 0, 0, 0,
            (), "Create a new path object")
{
  OBJECT *obj = o_path_new (edascm_c_current_toplevel (),
                            OBJ_PATH, DEFAULT_COLOR, "");

  SCM result = edascm_from_object (obj);

  /* At the moment, the only pointer to the object is owned by the
   * smob. */
  edascm_c_set_gc (result, TRUE);

  return result;
}

SCM_DEFINE (path_length, "%path-length", 1, 0, 0,
            (SCM obj_s), "Get number of elements in a path object.")
{
  /* Ensure that the argument is a path object */
  SCM_ASSERT (edascm_is_object_type (obj_s, OBJ_PATH), obj_s,
              SCM_ARG1, s_path_length);

  OBJECT *obj = edascm_to_object (obj_s);
  return scm_from_int (obj->path->num_sections);
}

SCM_DEFINE (path_ref, "%path-ref", 2, 0, 0,
            (SCM obj_s, SCM index_s),
            "Get a path element from a path object.")
{
  /* Ensure that the arguments are a path object and integer */
  SCM_ASSERT (edascm_is_object_type (obj_s, OBJ_PATH), obj_s,
              SCM_ARG1, s_path_ref);
  SCM_ASSERT (scm_is_integer (index_s), index_s, SCM_ARG2, s_path_ref);

  OBJECT *obj = edascm_to_object (obj_s);
  int idx = scm_to_int (index_s);

  /* Check index is valid for path */
  if ((idx < 0) || (idx >= obj->path->num_sections)) {
    scm_out_of_range (s_path_ref, index_s);
  }

  PATH_SECTION *section = &obj->path->sections[idx];

  switch (section->code) {
  case PATH_MOVETO:
  case PATH_MOVETO_OPEN:
    return scm_list_3 (moveto_sym,
                       scm_from_int (section->x3),
                       scm_from_int (section->y3));
  case PATH_LINETO:
    return scm_list_3 (lineto_sym,
                       scm_from_int (section->x3),
                       scm_from_int (section->y3));
  case PATH_CURVETO:
    return scm_list_n (curveto_sym,
                       scm_from_int (section->x1),
                       scm_from_int (section->y1),
                       scm_from_int (section->x2),
                       scm_from_int (section->y2),
                       scm_from_int (section->x3),
                       scm_from_int (section->y3),
                       SCM_UNDEFINED);
  case PATH_END:
    return scm_list_1 (closepath_sym);
  default:
    scm_misc_error (s_path_ref,
                    _("Path object ~A has invalid element type ~A at index ~A"),
                    scm_list_3 (obj_s, scm_from_int (section->code), index_s));
  }

}

SCM_DEFINE (path_remove_x, "%path-remove!", 2, 0, 0,
            (SCM obj_s, SCM index_s),
            "Remove a path element from a path object.")
{
  /* Ensure that the arguments are a path object and integer */
  SCM_ASSERT (edascm_is_object_type (obj_s, OBJ_PATH), obj_s,
              SCM_ARG1, s_path_ref);
  SCM_ASSERT (scm_is_integer (index_s), index_s, SCM_ARG2, s_path_ref);

  TOPLEVEL *toplevel = edascm_c_current_toplevel ();
  OBJECT *obj = edascm_to_object (obj_s);
  int idx = scm_to_int (index_s);

  if ((idx < 0) || (idx >= obj->path->num_sections)) {
    /* Index is valid for path */
    scm_out_of_range (s_path_ref, index_s);

  }

  o_emit_pre_change_notify (toplevel, obj);

  if (idx + 1 == obj->path->num_sections) {
    /* Section is last in path */
    obj->path->num_sections--;

  } else {
    /* Remove section at index by moving all sections above index one
     * location down. */
    memmove (&obj->path->sections[idx],
             &obj->path->sections[idx+1],
             sizeof (PATH_SECTION) * (obj->path->num_sections - idx - 1));
    obj->path->num_sections--;
  }

  o_emit_change_notify (toplevel, obj);
  o_page_changed (toplevel, obj);

  return obj_s;
}

SCM_DEFINE (path_insert_x, "%path-insert", 3, 6, 0,
            (SCM obj_s, SCM index_s, SCM type_s,
             SCM x1_s, SCM y1_s, SCM x2_s, SCM y2_s, SCM x3_s, SCM y3_s),
            "Insert a path element into a path object.")
{
  SCM_ASSERT (edascm_is_object_type (obj_s, OBJ_PATH), obj_s,
              SCM_ARG1, s_path_insert_x);
  SCM_ASSERT (scm_is_integer (index_s), index_s, SCM_ARG2, s_path_insert_x);
  SCM_ASSERT (scm_is_symbol (type_s), type_s, SCM_ARG3, s_path_insert_x);

  TOPLEVEL *toplevel = edascm_c_current_toplevel ();
  OBJECT *obj = edascm_to_object (obj_s);
  PATH *path = obj->path;
  PATH_SECTION section = {0, 0, 0, 0, 0, 0, 0};

  /* Check & extract path element type. */
  if      (type_s == closepath_sym) { section.code = PATH_END;     }
  else if (type_s == moveto_sym)    { section.code = PATH_MOVETO;  }
  else if (type_s == lineto_sym)    { section.code = PATH_LINETO;  }
  else if (type_s == curveto_sym)   { section.code = PATH_CURVETO; }
  else {
    scm_misc_error (s_path_insert_x,
                    _("Invalid path element type ~A."),
                    scm_list_1 (type_s));
  }

  /* Check the right number of coordinates have been provided. */
  switch (section.code) {
  case PATH_CURVETO:
    SCM_ASSERT (scm_is_integer (x1_s), x1_s, SCM_ARG4, s_path_insert_x);
    section.x1 = scm_to_int (x1_s);
    SCM_ASSERT (scm_is_integer (y1_s), y1_s, SCM_ARG5, s_path_insert_x);
    section.y1 = scm_to_int (y1_s);
    SCM_ASSERT (scm_is_integer (x2_s), x2_s, SCM_ARG6, s_path_insert_x);
    section.x2 = scm_to_int (x2_s);
    SCM_ASSERT (scm_is_integer (y2_s), y2_s, SCM_ARG7, s_path_insert_x);
    section.y2 = scm_to_int (y2_s);
    SCM_ASSERT (scm_is_integer (x3_s), x3_s, 8, s_path_insert_x);
    section.x3 = scm_to_int (x3_s);
    SCM_ASSERT (scm_is_integer (y3_s), y3_s, 9, s_path_insert_x);
    section.y3 = scm_to_int (y3_s);
    break;
  case PATH_MOVETO:
  case PATH_MOVETO_OPEN:
  case PATH_LINETO:
    SCM_ASSERT (scm_is_integer (x1_s), x1_s, SCM_ARG4, s_path_insert_x);
    section.x3 = scm_to_int (x1_s);
    SCM_ASSERT (scm_is_integer (y1_s), y1_s, SCM_ARG5, s_path_insert_x);
    section.y3 = scm_to_int (y1_s);
    break;
  case PATH_END:
    break;
  }

  /* Start making changes */
  o_emit_pre_change_notify (toplevel, obj);

  /* Make sure there's enough space for the new element */
  if (path->num_sections == path->num_sections_max) {
    path->sections = g_realloc (path->sections,
                                (path->num_sections_max <<= 1) * sizeof (PATH_SECTION));
  }

  /* Move path contents to make a gap in the right place. */
  int idx = scm_to_int (index_s);

  if ((idx < 0) || (idx > path->num_sections)) {
    idx = path->num_sections;
  } else {
    memmove (&path->sections[idx+1], &path->sections[idx],
             sizeof (PATH_SECTION) * (path->num_sections - idx));
  }

  path->num_sections++;
  path->sections[idx] = section;

  o_emit_change_notify (toplevel, obj);
  o_page_changed (toplevel, obj);

  return obj_s;
}

SCM_DEFINE (make_picture, "%make-picture", 0, 0, 0, (),
            "Create a new picture object")
{
  OBJECT *obj = o_picture_new (edascm_c_current_toplevel (),
                               NULL, 0, NULL, OBJ_PICTURE,
                               0, 0, 0, 0, 0, FALSE, TRUE);
  SCM result = edascm_from_object (obj);

  /* At the moment, the only pointer to the object is owned by the
   * smob. */
  edascm_c_set_gc (result, 1);

  return result;
}

SCM_DEFINE (picture_info, "%picture-info", 1, 0, 0,
            (SCM obj_s), "Get picture object parameters")
{
  SCM_ASSERT (edascm_is_object_type (obj_s, OBJ_PICTURE), obj_s,
              SCM_ARG1, s_picture_info);

  TOPLEVEL *toplevel = edascm_c_current_toplevel ();
  OBJECT *obj = edascm_to_object (obj_s);
  const gchar *filename = o_picture_get_filename (toplevel, obj);

  SCM filename_s = SCM_BOOL_F;
  if (filename != NULL) {
    filename_s = scm_from_utf8_string (filename);
  }

  return scm_list_n (filename_s,
                     scm_from_int (obj->picture->upper_x),
                     scm_from_int (obj->picture->upper_y),
                     scm_from_int (obj->picture->lower_x),
                     scm_from_int (obj->picture->lower_y),
                     scm_from_int (obj->picture->angle),
                     (obj->picture->mirrored ? SCM_BOOL_T : SCM_BOOL_F),
                     SCM_UNDEFINED);
}

/* \brief Set picture object parameters.
 * \par Function Description
 * Sets the parameters of the picture object \a obj_s.
 *
 * \note Scheme API: Implements the %set-picture! procedure in the
 * (geda core object) module.
 *
 * \param obj_s       the picture object to modify
 * \param x1_s  the new x-coordinate of the top left of the picture.
 * \param y1_s  the new y-coordinate of the top left of the picture.
 * \param x2_s  the new x-coordinate of the bottom right of the picture.
 * \param y2_s  the new y-coordinate of the bottom right of the picture.
 * \param angle_s     the new rotation angle.
 * \param mirror_s    whether the picture object should be mirrored.
 * \return the modify \a obj_s.
 */
SCM_DEFINE (set_picture_x, "%set-picture!", 7, 0, 0,
            (SCM obj_s, SCM x1_s, SCM y1_s, SCM x2_s, SCM y2_s, SCM angle_s,
             SCM mirror_s), "Set picture object parameters")
{
  SCM_ASSERT (edascm_is_object_type (obj_s, OBJ_PICTURE), obj_s,
              SCM_ARG1, s_set_picture_x);
  SCM_ASSERT (scm_is_integer (x1_s), x1_s, SCM_ARG2, s_set_picture_x);
  SCM_ASSERT (scm_is_integer (y1_s), x1_s, SCM_ARG3, s_set_picture_x);
  SCM_ASSERT (scm_is_integer (x2_s), x1_s, SCM_ARG4, s_set_picture_x);
  SCM_ASSERT (scm_is_integer (y2_s), x1_s, SCM_ARG5, s_set_picture_x);
  SCM_ASSERT (scm_is_integer (angle_s), angle_s, SCM_ARG6, s_set_picture_x);

  TOPLEVEL *toplevel = edascm_c_current_toplevel ();
  OBJECT *obj = edascm_to_object (obj_s);

  /* Angle */
  int angle = scm_to_int (angle_s);
  switch (angle) {
  case 0:
  case 90:
  case 180:
  case 270:
    /* These are all fine. */
    break;
  default:
    /* Otherwise, not fine. */
    scm_misc_error (s_set_picture_x,
                    _("Invalid picture angle ~A. Must be 0, 90, 180, or 270 degrees"),
                    scm_list_1 (angle_s));
  }

  o_emit_pre_change_notify (toplevel, obj);

  obj->picture->angle = scm_to_int (angle_s);
  obj->picture->mirrored = scm_is_true (mirror_s);
  o_picture_modify_all (toplevel, obj,
                        scm_to_int (x1_s), scm_to_int (y1_s),
                        scm_to_int (x2_s), scm_to_int (y2_s));

  o_emit_change_notify (toplevel, obj);
  return obj_s;
}

SCM_DEFINE (set_picture_data_vector_x, "%set-picture-data/vector!",
            3, 0, 0, (SCM obj_s, SCM data_s, SCM filename_s),
            "Set a picture object's data from a vector.")
{
  SCM vec_s = scm_any_to_s8vector (data_s);
  /* Check argument types */
  SCM_ASSERT (edascm_is_object_type (obj_s, OBJ_PICTURE), obj_s,
              SCM_ARG1, s_set_picture_data_vector_x);
  SCM_ASSERT (scm_is_true (scm_s8vector_p (vec_s)), data_s, SCM_ARG2,
              s_set_picture_data_vector_x);
  SCM_ASSERT (scm_is_string (filename_s), filename_s, SCM_ARG3,
              s_set_picture_data_vector_x);

  scm_dynwind_begin (0);

  /* Convert vector to contiguous buffer */
  scm_t_array_handle handle;
  size_t len;
  ssize_t inc;
  const scm_t_int8 *elt = scm_s8vector_elements (vec_s, &handle, &len, &inc);
  gchar *buf = g_malloc (len);
  int i;

  scm_dynwind_unwind_handler (g_free, buf, SCM_F_WIND_EXPLICITLY);

  for (i = 0; i < len; i++, elt += inc) {
    buf[i] = (gchar) *elt;
  }
  scm_array_handle_release (&handle);

  gboolean status;
  GError *error = NULL;
  TOPLEVEL *toplevel = edascm_c_current_toplevel ();
  OBJECT *obj = edascm_to_object (obj_s);
  gchar *filename = scm_to_utf8_string (filename_s);
  scm_dynwind_unwind_handler (g_free, filename, SCM_F_WIND_EXPLICITLY);

  status = o_picture_set_from_buffer (toplevel, obj, filename,
                                      buf, len, &error);

  if (!status) {
    scm_dynwind_unwind_handler ((void (*)(void *)) g_error_free, error,
                                SCM_F_WIND_EXPLICITLY);
    scm_misc_error (s_set_picture_data_vector_x,
                    "Failed to set picture image data from vector: ~S",
                    scm_list_1 (scm_from_utf8_string (error->message)));
  }

  o_page_changed (toplevel, obj);
  scm_dynwind_end ();
  return obj_s;
}



SCM_DEFINE (translate_object_x, "%translate-object!", 3, 0, 0,
            (SCM obj_s, SCM dx_s, SCM dy_s), "Translate an object.")
{
  /* Check argument types */
  SCM_ASSERT (edascm_is_object (obj_s), obj_s,
              SCM_ARG1, s_translate_object_x);
  SCM_ASSERT (scm_is_integer (dx_s), dx_s,
              SCM_ARG2, s_translate_object_x);
  SCM_ASSERT (scm_is_integer (dy_s), dy_s,
              SCM_ARG3, s_translate_object_x);

  TOPLEVEL *toplevel = edascm_c_current_toplevel ();
  OBJECT *obj = edascm_to_object (obj_s);
  int dx = scm_to_int (dx_s);
  int dy = scm_to_int (dy_s);

  o_emit_pre_change_notify (toplevel, obj);
  o_translate_world (toplevel, dx, dy, obj);
  o_emit_change_notify (toplevel, obj);
  o_page_changed (toplevel, obj);

  return obj_s;
}

SCM_DEFINE (rotate_object_x, "%rotate-object!", 4, 0, 0,
            (SCM obj_s, SCM x_s, SCM y_s, SCM angle_s),
            "Rotate an object.")
{
  /* Check argument types */
  SCM_ASSERT (edascm_is_object (obj_s), obj_s,
              SCM_ARG1, s_rotate_object_x);
  SCM_ASSERT (scm_is_integer (x_s), x_s,
              SCM_ARG2, s_rotate_object_x);
  SCM_ASSERT (scm_is_integer (y_s), y_s,
              SCM_ARG3, s_rotate_object_x);
  SCM_ASSERT (scm_is_integer (angle_s), angle_s,
              SCM_ARG4, s_rotate_object_x);

  TOPLEVEL *toplevel = edascm_c_current_toplevel ();
  OBJECT *obj = edascm_to_object (obj_s);
  int x = scm_to_int (x_s);
  int y = scm_to_int (y_s);
  int angle = scm_to_int (angle_s);

  /* FIXME Work around horribly broken libgeda behaviour.  Some
   * libgeda functions treat a rotation of -90 degrees as a rotation
   * of +90 degrees, etc., which is not sane. */
  while (angle < 0) angle += 360;
  while (angle >= 360) angle -= 360;
  SCM_ASSERT (angle % 90 == 0, angle_s,
              SCM_ARG4, s_rotate_object_x);

  o_emit_pre_change_notify (toplevel, obj);
  o_rotate_world (toplevel, x, y, angle, obj);
  o_emit_change_notify (toplevel, obj);
  o_page_changed (toplevel, obj);

  return obj_s;
}

SCM_DEFINE (mirror_object_x, "%mirror-object!", 2, 0, 0,
            (SCM obj_s, SCM x_s),
            "Mirror an object.")
{
  /* Check argument types */
  SCM_ASSERT (edascm_is_object (obj_s), obj_s,
              SCM_ARG1, s_mirror_object_x);
  SCM_ASSERT (scm_is_integer (x_s), x_s,
              SCM_ARG2, s_mirror_object_x);

  TOPLEVEL *toplevel = edascm_c_current_toplevel ();
  OBJECT *obj = edascm_to_object (obj_s);
  int x = scm_to_int (x_s);

  o_emit_pre_change_notify (toplevel, obj);
  o_mirror_world (toplevel, x, 0, obj);
  o_emit_change_notify (toplevel, obj);
  o_page_changed (toplevel, obj);

  return obj_s;
}

static void
init_module_geda_core_object ()
{
  /* Register the functions and symbols */
  #include "scheme_object.x"

  /* Add them to the module's public definitions. */
  scm_c_export (s_object_type, s_copy_object, s_object_bounds,
                s_object_stroke, s_set_object_stroke_x,
                s_object_fill, s_set_object_fill_x,
                s_object_color, s_set_object_color_x,
                s_make_line, s_make_net, s_make_bus,
                s_make_pin, s_pin_type,
                s_set_line_x, s_line_info,
                s_make_box, s_set_box_x, s_box_info,
                s_make_circle, s_set_circle_x, s_circle_info,
                s_make_arc, s_set_arc_x, s_arc_info,
                s_make_text, s_set_text_x, s_text_info,
                s_object_connections, s_object_complex,
                s_make_path, s_path_length, s_path_ref,
                s_path_remove_x, s_path_insert_x,
                s_make_picture, s_picture_info, s_set_picture_x,
                s_set_picture_data_vector_x,
                s_translate_object_x, s_rotate_object_x,
                s_mirror_object_x,
                NULL);
}

void
edascm_init_object ()
{
  /* Define the (geda core object) module */
  scm_c_define_module ("geda core object",
                       init_module_geda_core_object,
                       NULL);
}