libgeda/src/scheme_complex.c

   1 /* gEDA - GPL Electronic Design Automation
   2  * libgeda - gEDA's library - Scheme API
   3  * Copyright (C) 2010 Peter Brett <peter@peter-b.co.uk>
   4  *
   5  * This program is free software; you can redistribute it and/or modify
   6  * it under the terms of the GNU General Public License as published by
   7  * the Free Software Foundation; either version 2 of the License, or
   8  * (at your option) any later version.
   9  *
  10  * This program is distributed in the hope that it will be useful,
  11  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13  * GNU General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU General Public License
  16  * along with this program; if not, write to the Free Software
  17  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
  18  */
  19
  20 /*!
  21  * \file scheme_complex.c
  22  * \brief Scheme API complex object manipulation procedures.
  23  */
  24
  25 #include <config.h>
  26
  27 #include "libgeda_priv.h"
  28 #include "libgedaguile_priv.h"
  29
  30 /*! \brief Create a new complex object.
  31  * \par Function Description
  32  * Creates a new, empty complex object, with the given \a basename and
  33  * with all other parameters set to default values.  It is initially set
  34  * to be embedded.
  35  *
  36  * \note Scheme API: Implements the %make-complex procedure in the
  37  * (geda core complex) module.
  38  *
  39  * \return a newly-created complex object.
  40  */
  41 SCM_DEFINE (make_complex, "%make-complex", 1, 0, 0,
  42             (SCM basename_s), "Create a new complex object.")
  43 {
  44   SCM_ASSERT (scm_is_string (basename_s), basename_s, SCM_ARG1, s_make_complex);
  45
  46   char *tmp = scm_to_utf8_string (basename_s);
  47   OBJECT *obj = o_complex_new_embedded (edascm_c_current_toplevel (),
  48                                         OBJ_COMPLEX, DEFAULT_COLOR, 0, 0, 0,
  49                                         FALSE, tmp, TRUE);
  50   free (tmp);
  51
  52   SCM result = edascm_from_object (obj);
  53
  54   /* At the moment, the only pointer to the object is owned by the
  55    * smob. */
  56   edascm_c_set_gc (result, TRUE);
  57
  58   return result;
  59 }
  60
  61 /*! \brief Instantiate a complex object from the component library.
  62  * \par Function Description
  63
  64  * Searches the component library for a component with the given \a
  65  * basename.  If found, creates a new complex object by instantiating
  66  * that library component.  It is initially set to be unembedded.  If
  67  * no match is found for \a basename in the library, returns
  68  * SCM_BOOL_F.
  69  *
  70  * \note Scheme API: Implements the %make-complex/library procedure in
  71  * the (geda core complex) module.
  72  *
  73  * \param basename component name to search for in the component
  74  *                 library.
  75  * \return a newly-created complex object.
  76  */
  77 SCM_DEFINE (make_complex_library, "%make-complex/library", 1, 0, 0,
  78             (SCM basename_s),
  79             "Instantiate a complex object from the component library.")
  80 {
  81   SCM_ASSERT (scm_is_string (basename_s), basename_s, SCM_ARG1,
  82               s_make_complex_library);
  83
  84   char *basename = scm_to_utf8_string (basename_s);
  85   scm_dynwind_begin (0);
  86   scm_dynwind_unwind_handler (free, basename, SCM_F_WIND_EXPLICITLY);
  87
  88   SCM result = SCM_BOOL_F;
  89   const CLibSymbol *clib = s_clib_get_symbol_by_name (basename);
  90   if (clib != NULL) {
  91     OBJECT *obj = o_complex_new (edascm_c_current_toplevel (),
  92                                  OBJ_COMPLEX, DEFAULT_COLOR, 0, 0, 0,
  93                                  FALSE, clib, basename, TRUE);
  94
  95     result = edascm_from_object (obj);
  96
  97     /* At the moment, the only pointer to the object is owned by the
  98      * smob. */
  99     edascm_c_set_gc (result, TRUE);
 100   }
 101
 102   scm_dynwind_end ();
 103   return result;
 104 }
 105
 106 /*! \brief Set complex object parameters.
 107  * \par Function Description
 108  * Modifies the complex object \a complex_s by setting its parameters
 109  * to new values.
 110  *
 111  * \note Scheme API: Implements the %set-complex! procedure in the
 112  * (geda core complex) module.
 113  *
 114  * \param complex_s the complex object to modify.
 115  * \param x_s       the new x-coordinate of the complex object.
 116  * \param y_s       the new y-coordinate of the complex object.
 117  * \param angle_s   the new rotation angle.
 118  * \param mirror_s  whether the complex object should be mirrored.
 119  * \param locked_s  whether the complex object should be locked.
 120  *
 121  * \return the modified \a complex_s.
 122  */
 123 SCM_DEFINE (set_complex_x, "%set-complex!", 6, 0, 0,
 124             (SCM complex_s, SCM x_s, SCM y_s, SCM angle_s, SCM mirror_s,
 125              SCM locked_s), "Set complex object parameters")
 126 {
 127   SCM_ASSERT (edascm_is_object_type (complex_s, OBJ_COMPLEX), complex_s,
 128               SCM_ARG1, s_set_complex_x);
 129   SCM_ASSERT (scm_is_integer (x_s),     x_s,     SCM_ARG2, s_set_complex_x);
 130   SCM_ASSERT (scm_is_integer (y_s),     y_s,     SCM_ARG3, s_set_complex_x);
 131   SCM_ASSERT (scm_is_integer (angle_s), angle_s, SCM_ARG4, s_set_complex_x);
 132
 133   TOPLEVEL *toplevel = edascm_c_current_toplevel ();
 134   OBJECT *obj = edascm_to_object (complex_s);
 135
 136   /* Angle */
 137   int angle = scm_to_int (angle_s);
 138   switch (angle) {
 139   case 0:
 140   case 90:
 141   case 180:
 142   case 270:
 143     /* These are all fine. */
 144     break;
 145   default:
 146     /* Otherwise, not fine. */
 147     scm_misc_error (s_set_complex_x,
 148                     _("Invalid complex angle ~A. Must be 0, 90, 180, or 270 degrees"),
 149                     scm_list_1 (angle_s));
 150   }
 151
 152   o_emit_pre_change_notify (toplevel, obj);
 153
 154   int x = scm_to_int (x_s);
 155   int y = scm_to_int (y_s);
 156   o_translate_world (toplevel,
 157                      x - obj->complex->x,
 158                      y - obj->complex->y,
 159                      obj);
 160   obj->complex->angle = angle;
 161   obj->complex->mirror = scm_is_true (mirror_s);
 162   obj->selectable = scm_is_false (locked_s);
 163
 164   o_complex_recalc (toplevel, obj); /* We need to do this explicitly... */
 165
 166   o_emit_change_notify (toplevel, obj);
 167
 168   o_page_changed (toplevel, obj);
 169
 170   return complex_s;
 171 }
 172
 173 /*! \brief Get complex object parameters.
 174  * \par Function Description
 175  * Retrieves the parameters of a complex object. The return value is a
 176  * list of parameters:
 177  *
 178  * -# Basename
 179  * -# Base x-coordinate.
 180  * -# Base y-coordinate.
 181  * -# Rotation angle.
 182  * -# Whether object is mirrored.
 183  * -# Whether object is locked.
 184  *
 185  * \note Scheme API: Implements the %complex-info procedure in the
 186  * (geda core complex) module.
 187  *
 188  * \param complex_s the complex object to inspect.
 189  * \return a list of complex object parameters.
 190  */
 191 SCM_DEFINE (complex_info, "%complex-info", 1, 0, 0,
 192             (SCM complex_s), "Get complex object parameters.")
 193 {
 194   SCM_ASSERT (edascm_is_object_type (complex_s, OBJ_COMPLEX), complex_s,
 195               SCM_ARG1, s_complex_info);
 196
 197   OBJECT *obj = edascm_to_object (complex_s);
 198
 199   return scm_list_n (scm_from_utf8_string (obj->complex_basename),
 200                      scm_from_int (obj->complex->x),
 201                      scm_from_int (obj->complex->y),
 202                      scm_from_int (obj->complex->angle),
 203                      obj->complex->mirror ? SCM_BOOL_T : SCM_BOOL_F,
 204                      obj->selectable ? SCM_BOOL_F : SCM_BOOL_T,
 205                      SCM_UNDEFINED);
 206 }
 207
 208 /*! \brief Get the contents of a complex object.
 209  * \par Function Description
 210  * Retrieves a list of the primitive objects that make up a complex object.
 211  *
 212  * \note Scheme API: Implements the %complex-contents procedure in the
 213  * (geda core complex) module.
 214  *
 215  * \param complex_s a complex object.
 216  * \return a list of primitive objects.
 217  */
 218 SCM_DEFINE (complex_contents, "%complex-contents", 1, 0, 0,
 219             (SCM complex_s), "Get complex object contents.")
 220 {
 221   SCM_ASSERT (edascm_is_object_type (complex_s, OBJ_COMPLEX), complex_s,
 222               SCM_ARG1, s_complex_contents);
 223
 224   OBJECT *obj = edascm_to_object (complex_s);
 225
 226   return edascm_from_object_glist (obj->complex->prim_objs);
 227 }
 228
 229 /*! \brief Add a primitive object to a complex object.
 230  * \par Function Description
 231  * Adds \a obj_s to \a complex_s.  If \a obj_s is already attached to
 232  * another complex object or to a #PAGE, or if \a obj_s is itself a
 233  * complex object, throws a Scheme error.  If \a obj_s is already
 234  * attached to \a complex_s, does nothing.
 235  *
 236  * \note Scheme API: Implements the %complex-append! procedure of the
 237  * (geda core complex) module.
 238  *
 239  * \param complex_s complex object to modify.
 240  * \param obj_s     primitive object to add.
 241  * \return \a obj_s.
 242  */
 243 SCM_DEFINE (complex_append_x, "%complex-append!", 2, 0, 0,
 244             (SCM complex_s, SCM obj_s),
 245             "Add a primitive object to a complex object")
 246 {
 247   /* Ensure that the arguments have the correct types. */
 248   SCM_ASSERT (edascm_is_object_type (complex_s, OBJ_COMPLEX), complex_s,
 249               SCM_ARG1, s_complex_append_x);
 250   SCM_ASSERT ((EDASCM_OBJECTP (obj_s)
 251                && !edascm_is_object_type (obj_s, OBJ_COMPLEX)
 252                && !edascm_is_object_type (obj_s, OBJ_PLACEHOLDER)),
 253               obj_s, SCM_ARG2, s_complex_append_x);
 254
 255   TOPLEVEL *toplevel = edascm_c_current_toplevel ();
 256   OBJECT *parent = edascm_to_object (complex_s);
 257   OBJECT *child = edascm_to_object (obj_s);
 258
 259   /* Check that object is not already attached to a page or a
 260      different complex. */
 261   if ((o_get_page (toplevel, child) != NULL)
 262       || ((child->parent != NULL) && (child->parent != parent))) {
 263     scm_error (edascm_object_state_sym,
 264                s_complex_append_x,
 265                _("Object ~A is already attached to something"),
 266                scm_list_1 (obj_s), SCM_EOL);
 267   }
 268
 269   if (child->parent == parent) return obj_s;
 270
 271   /* Object cleanup now managed by C code. */
 272   edascm_c_set_gc (obj_s, 0);
 273
 274   /* Don't need to emit change notifications for the child because
 275    * it's guaranteed not to be present in a page at this point. */
 276   o_emit_pre_change_notify (toplevel, parent);
 277
 278   parent->complex->prim_objs =
 279     g_list_append (parent->complex->prim_objs, child);
 280   child->parent = parent;
 281
 282   o_complex_recalc (toplevel, parent);
 283
 284   /* We may need to update connections */
 285   s_tile_update_object (toplevel, child);
 286   s_conn_update_object (toplevel, child);
 287
 288   o_emit_change_notify (toplevel, parent);
 289
 290   o_page_changed (toplevel, parent);
 291
 292   return complex_s;
 293 }
 294
 295 /*! \brief Remove a primitive object from a complex object.
 296  * \par Function Description
 297  * Removes \a obj_s from \a complex_s.  If \a obj_s is attached to a
 298  * #PAGE or to a complex object other than \a complex_s, throws a
 299  * Scheme error.  If \a obj_s is unattached, does nothing.
 300  *
 301  * \note Scheme API: Implements the %complex-remove! procedure of the
 302  * (geda core complex) module.
 303  *
 304  * \param complex_s complex object to modify.
 305  * \param obj_s     primitive object to remove.
 306  * \return \a obj_s.
 307  */
 308 SCM_DEFINE (complex_remove_x, "%complex-remove!", 2, 0, 0,
 309             (SCM complex_s, SCM obj_s),
 310             "Remove a primitive object from a complex object")
 311 {
 312   /* Ensure that the arguments have the correct types. */
 313   SCM_ASSERT (edascm_is_object_type (complex_s, OBJ_COMPLEX), complex_s,
 314               SCM_ARG1, s_complex_remove_x);
 315   SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s, SCM_ARG2, s_complex_remove_x);
 316
 317   TOPLEVEL *toplevel = edascm_c_current_toplevel ();
 318   OBJECT *parent = edascm_to_object (complex_s);
 319   OBJECT *child = edascm_to_object (obj_s);
 320   PAGE *child_page = o_get_page (toplevel, child);
 321
 322   /* Check that object is not attached to a different complex. */
 323   if ((child->parent != NULL) && (child->parent != parent)) {
 324     scm_error (edascm_object_state_sym, s_complex_remove_x,
 325                _("Object ~A is attached to a different complex"),
 326                scm_list_1 (obj_s), SCM_EOL);
 327   }
 328
 329   /* Check that object is not attached to a page. */
 330   if ((child->parent == NULL) && (child_page != NULL)) {
 331     scm_error (edascm_object_state_sym, s_complex_remove_x,
 332                _("Object ~A is attached to a page"),
 333                scm_list_1 (obj_s), SCM_EOL);
 334   }
 335
 336   /* Check that object is not attached as an attribute. */
 337   if (child->attached_to != NULL) {
 338     scm_error (edascm_object_state_sym, s_complex_remove_x,
 339                _("Object ~A is attached as an attribute"),
 340                scm_list_1 (obj_s), SCM_EOL);
 341   }
 342
 343   /* Check that object doesn't have attributes. */
 344   if (child->attribs != NULL) {
 345     scm_error (edascm_object_state_sym, s_complex_remove_x,
 346                _("Object ~A has attributes"),
 347                scm_list_1 (obj_s), SCM_EOL);
 348   }
 349
 350   if (child->parent == NULL) return obj_s;
 351
 352   /* Don't need to emit change notifications for the child because
 353    * only the parent will remain in the page. */
 354   o_emit_pre_change_notify (toplevel, parent);
 355
 356   parent->complex->prim_objs =
 357     g_list_remove_all (parent->complex->prim_objs, child);
 358   child->parent = NULL;
 359
 360   /* We may need to update connections */
 361   s_tile_remove_object (child);
 362   s_conn_remove_object (toplevel, child);
 363
 364   o_emit_change_notify (toplevel, parent);
 365
 366   o_page_changed (toplevel, parent);
 367
 368   /* Object cleanup now managed by Guile. */
 369   edascm_c_set_gc (obj_s, 1);
 370   return complex_s;
 371 }
 372
 373 /*!
 374  * \brief Create the (geda core complex) Scheme module.
 375  * \par Function Description
 376  * Defines procedures in the (geda core complex) module. The module can
 377  * be accessed using (use-modules (geda core complex)).
 378  */
 379 static void
 380 init_module_geda_core_complex ()
 381 {
 382   /* Register the functions and symbols */
 383   #include "scheme_complex.x"
 384
 385   /* Add them to the module's public definitions. */
 386   scm_c_export (s_make_complex, s_make_complex_library, s_set_complex_x,
 387                 s_complex_info, s_complex_contents, s_complex_append_x,
 388                 s_complex_remove_x, NULL);
 389 }
 390
 391 /*!
 392  * \brief Initialise the basic gEDA complex object manipulation procedures.
 393  * \par Function Description
 394  * Registers some Scheme procedures for working with complex #OBJECT
 395  * smobs. Should only be called by scheme_api_init().
 396  */
 397 void
 398 edascm_init_complex ()
 399 {
 400   /* Define the (geda core object) module */
 401   scm_c_define_module ("geda core complex",
 402                        init_module_geda_core_complex,
 403                        NULL);
 404 }