cgit.sxemacs.org Git - sxemacs/blob - modules/ase/ase-cartesian.c

   1 /*
   2   ase-cartesian.c -- Cartesian (exterior) product for ASE objects
   3   Copyright (C) 2006, 2007, 2008 Sebastian Freundt
   4
   5   Author:  Sebastian Freundt <hroptatyr@sxemacs.org>
   6
   7   * This file is part of SXEmacs.
   8   *
   9   * Redistribution and use in source and binary forms, with or without
  10   * modification, are permitted provided that the following conditions
  11   * are met:
  12   *
  13   * 1. Redistributions of source code must retain the above copyright
  14   *    notice, this list of conditions and the following disclaimer.
  15   *
  16   * 2. Redistributions in binary form must reproduce the above copyright
  17   *    notice, this list of conditions and the following disclaimer in the
  18   *    documentation and/or other materials provided with the distribution.
  19   *
  20   * 3. Neither the name of the author nor the names of any contributors
  21   *    may be used to endorse or promote products derived from this
  22   *    software without specific prior written permission.
  23   *
  24   * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
  25   * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  26   * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  27   * DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
  28   * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  29   * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  30   * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
  31   * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  32   * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
  33   * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
  34   * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  35   */
  36
  37 /* Synched up with: Not in FSF. */
  38
  39 #include "config.h"
  40 #include "sxemacs.h"
  41 #include "ent/ent.h"
  42 #include "ase.h"
  43 #include "ase-cartesian.h"
  44
  45 PROVIDE(ase_cartesian);
  46 REQUIRE(ase_cartesian, "ase");
  47
  48 Lisp_Object Qase_cartesian, Qase_cartesianp;
  49 Lisp_Object Qase_cartesian_interior, Qase_cartesian_interior_p;
  50 Lisp_Object Qembed_error, Qinterior_error;
  51
  52 \f
  53 /* stuff for the dynacat */
  54 static int
  55 _ase_cartesian_prnt_ase_object(Lisp_Object o, Lisp_Object pcf)
  56 {
  57         dynacat_intprinter_f prfun = NULL;
  58
  59         if (!DYNACATP(o))
  60                 return 0;
  61
  62         prfun = get_dynacat_intprinter(o);
  63         if (prfun == NULL)
  64                 return 0;
  65
  66         prfun(get_dynacat(o), pcf);
  67         return 1;
  68 }
  69
  70 static void
  71 _ase_cartesian_prnt(ase_cartesian_t n, Lisp_Object pcf)
  72 {
  73         Lisp_Object *objs;
  74         int i;
  75
  76         objs = n->objects;
  77         for (i = 0; i < n->dimension; i++) {
  78                 Lisp_Object obji = objs[i];
  79                 if (!_ase_cartesian_prnt_ase_object(obji, pcf)) {
  80                         print_internal(objs[i], pcf, 0);
  81                 }
  82                 if (i+1 < n->dimension)
  83                         write_c_string(" x ", pcf);
  84         }
  85 }
  86
  87 static void
  88 ase_cartesian_prnt(Lisp_Object obj, Lisp_Object pcf, int unused)
  89 {
  90         EMOD_ASE_DEBUG_CART("n:0x%08x@0x%08x (rc:%d)\n",
  91                             (unsigned int)(XASE_CARTESIAN(obj)),
  92                             (unsigned int)obj, 1);
  93         write_c_string("#<", pcf);
  94         print_internal(XDYNACAT_TYPE(obj), pcf, unused);
  95         if (!NILP(XASE_CARTESIAN_INTERIOR_TYPE(obj))) {
  96                 print_internal(XASE_CARTESIAN_INTERIOR_TYPE(obj), pcf, unused);
  97         }
  98         write_fmt_str(pcf, " of dimension %d, ",
  99                       XASE_CARTESIAN_DIMENSION(obj));
 100         _ase_cartesian_prnt(XASE_CARTESIAN(obj), pcf);
 101
 102         write_c_string(">", pcf);
 103 }
 104
 105 static void
 106 ase_cartesian_fini(Lisp_Object obj, int unused)
 107 {
 108         ase_cartesian_t n = XASE_CARTESIAN(obj);
 109
 110         EMOD_ASE_DEBUG_GC("n:0x%08x@0x%08x (rc:%d) shall be freed...\n",
 111                           (unsigned int)(n), (unsigned int)obj, 1);
 112
 113         if (ase_cartesian_decref(n) <= 0) {
 114                 ase_cartesian_fini_refcnt(n);
 115                 xfree(n->objects);
 116                 xfree(n);
 117         } else {
 118                 EMOD_ASE_DEBUG_GC("VETO! References exist\n");
 119         }
 120         return;
 121 }
 122
 123 static inline void
 124 _ase_cartesian_mark(ase_cartesian_t n)
 125 {
 126         int i;
 127
 128         if (n == NULL)
 129                 return;
 130
 131         for (i = 0; i < n->dimension; i++)
 132                 mark_object(n->objects[i]);
 133
 134         mark_object(n->lebesgue_measure);
 135         mark_object(n->rational_measure);
 136         mark_object(n->colour);
 137         mark_object(n->interior_type);
 138         return;
 139 }
 140
 141 static void
 142 ase_cartesian_mark(Lisp_Object obj)
 143 {
 144         EMOD_ASE_DEBUG_CART("n:0x%08x@0x%08x (rc:%d) shall be marked...\n",
 145                             (unsigned int)(XASE_CARTESIAN(obj)),
 146                             (unsigned int)obj, 1);
 147         _ase_cartesian_mark(XASE_CARTESIAN(obj));
 148         return;
 149 }
 150
 151 \f
 152 Lisp_Object
 153 _ase_wrap_cartesian(ase_cartesian_t n)
 154 {
 155         Lisp_Object result;
 156
 157         result = make_dynacat(n);
 158         XDYNACAT_TYPE(result) = Qase_cartesian;
 159
 160         if (n)
 161                 ase_cartesian_incref(n);
 162
 163         set_dynacat_printer(result, ase_cartesian_prnt);
 164         set_dynacat_marker(result, ase_cartesian_mark);
 165         set_dynacat_finaliser(result, ase_cartesian_fini);
 166         set_dynacat_intprinter(
 167                 result, (dynacat_intprinter_f)_ase_cartesian_prnt);
 168
 169         EMOD_ASE_DEBUG_CART("n:0x%08x (rc:%d) shall be wrapped to 0x%08x...\n",
 170                             (unsigned int)n, 1, (unsigned int)result);
 171
 172         return result;
 173 }
 174
 175 Lisp_Object
 176 _ase_wrap_cartesian_interior(ase_cartesian_t n)
 177 {
 178         Lisp_Object result;
 179
 180         result = make_dynacat(n);
 181         XDYNACAT_TYPE(result) = Qase_cartesian_interior;
 182
 183         if (n)
 184                 ase_cartesian_incref(n);
 185
 186         set_dynacat_printer(result, ase_cartesian_prnt);
 187         set_dynacat_marker(result, ase_cartesian_mark);
 188         set_dynacat_finaliser(result, ase_cartesian_fini);
 189         set_dynacat_intprinter(
 190                 result, (dynacat_intprinter_f)_ase_cartesian_prnt);
 191
 192         EMOD_ASE_DEBUG_CART("n:0x%08x (rc:%d) shall be wrapped to 0x%08x...\n",
 193                             (unsigned int)n, 1, (unsigned int)result);
 194
 195         return result;
 196 }
 197
 198 Lisp_Object
 199 ase_make_cartesian(int nargs, Lisp_Object *args, int interiorp)
 200 {
 201         ase_cartesian_t c = NULL;
 202         Lisp_Object result = Qnil;
 203         int i;
 204
 205         /* We're in ZFC! So refuse to generate cartesian sets with
 206          * empty set consituents, in terms: A x ( ) -> ( ) */
 207 #if 1
 208         for (i = 0; i < nargs; i++) {
 209                 WITH_DLLIST_TRAVERSE(
 210                         ase_empty_sets,
 211                         if ((void*)args[i] == dllist_item) {
 212                                 RETURN_FROM_DLLIST_TRAVERSE(
 213                                         ase_empty_sets, args[i]);
 214                         }
 215                         );
 216         }
 217 #else
 218         for (i = 0; i < nargs; i++) {
 219                 if (DYNACATP(args[i])) {
 220                         ase_object_t obj = get_dynacat(args[i]);
 221                         EMOD_ASE_CRITICAL("obj cat 0x%lx\n",
 222                                           (long unsigned int)obj->category);
 223                 }
 224         }
 225 #endif  /* 0 */
 226         c = _ase_make_cartesian(nargs, args, interiorp);
 227         if (!interiorp)
 228                 XSETASE_CARTESIAN(result, c);
 229         else
 230                 XSETASE_CARTESIAN_INTERIOR(result, c);
 231
 232         return result;
 233 }
 234
 235 /* accessors */
 236
 237
 238 DOESNT_RETURN ase_cartesian_embedding_error(Lisp_Object o1, Lisp_Object o2)
 239 {
 240         signal_error(Qembed_error, list2(o1, o2));
 241         return;
 242 }
 243
 244 \f
 245 /* lisp level */
 246 DEFUN("ase-cartesianp", Fase_cartesianp, 1, 1, 0, /*
 247 Return non-`nil' iff OBJECT is a cartesian product of objects.
 248 */
 249       (object))
 250 {
 251         if (ASE_CARTESIANP(object))
 252                 return Qt;
 253
 254         return Qnil;
 255 }
 256
 257 DEFUN("ase-cartesian*p", Fase_cartesianXp, 1, 1, 0, /*
 258 Return non-`nil' iff OBJECT is an interior cartesian product of objects.
 259 */
 260       (object))
 261 {
 262         if (ASE_CARTESIAN_INTERIOR_P(object))
 263                 return Qt;
 264
 265         return Qnil;
 266 }
 267
 268 /* ###autoload */
 269 DEFUN("ase-cartesian", Fase_cartesian, 0, MANY, 0, /*
 270 Return a cartesian (exterior) product of OBJECTS.
 271 */
 272       (int nargs, Lisp_Object *args))
 273 {
 274         if (nargs == 0)
 275                 return Qnil;
 276         else if (nargs == 1)
 277                 return args[0];
 278
 279         return ase_make_cartesian(nargs, args, 0);
 280 }
 281
 282 /* ###autoload */
 283 DEFUN("ase-cartesian*", Fase_cartesianX, 0, MANY, 0, /*
 284 Return an interior cartesian product of OBJECTS.
 285 */
 286       (int nargs, Lisp_Object *args))
 287 {
 288         Lisp_Object tmp;
 289         int i;
 290
 291         if (nargs == 0)
 292                 return Qnil;
 293         else if (nargs == 1)
 294                 return args[0];
 295
 296         tmp = Ftype_of(args[0]);
 297         for (i = 1; i < nargs; i++) {
 298                 Lisp_Object tmpi;
 299                 if (!EQ(tmp, (tmpi = Ftype_of(args[i]))))
 300                         signal_error(Qinterior_error, list2(tmp, tmpi));
 301         }
 302
 303         return ase_make_cartesian(nargs, args, 1);
 304 }
 305
 306 /* accessors */
 307 DEFUN("ase-cartesian-ground-domain", Fase_cartesian_ground_domain, 1, 1, 0, /*
 308 Return the ground domain (the type) of an interior product OBJECT.
 309 */
 310       (object))
 311 {
 312         CHECK_ASE_CARTESIAN_INTERIOR(object);
 313         return XASE_CARTESIAN_INTERIOR_TYPE(object);
 314 }
 315
 316 DEFUN("ase-cartesian-projection", Fase_cartesian_projection, 2, 2, 0, /*
 317 Return the projection of CARTESIAN onto the DIMENSION-th component.
 318 */
 319       (cartesian, dimension))
 320 {
 321         CHECK_ASE_UBERCARTESIAN(cartesian);
 322         CHECK_NATNUM(dimension);
 323         if (XINT(dimension) == 0 ||
 324             XINT(dimension) > XASE_CARTESIAN_DIMENSION(cartesian)) {
 325                 args_out_of_range(cartesian, dimension);
 326                 return Qnil;
 327         }
 328         return XASE_CARTESIAN_OBJECTS(cartesian)[XINT(dimension)-1];
 329 }
 330
 331 DEFUN("ase-cartesian-embed", Fase_cartesian_embed, 2, 2, 0, /*
 332 Return the embedding of CARTESIAN according to the DIMENSION vector.
 333 Use dimension indexes in DIMENSION vector to embed the specified
 334 dimension, use 0 to denote a free subspace.
 335 */
 336       (cartesian, dimension))
 337 {
 338         int i, dim, newdim;
 339         Lisp_Object *newos, *oldos, *vec;
 340
 341         CHECK_ASE_UBERCARTESIAN(cartesian);
 342         CHECK_VECTOR(dimension);
 343
 344         dim = XASE_CARTESIAN_DIMENSION(cartesian);
 345         newdim = XVECTOR_LENGTH(dimension);
 346         newos = alloca_array(Lisp_Object, newdim);
 347         oldos = XASE_CARTESIAN_OBJECTS(cartesian);
 348         vec = XVECTOR_DATA(dimension);
 349
 350         for (i = 0; i < newdim; i++) {
 351                 Lisp_Object c = vec[i];
 352                 CHECK_NATNUM(c);
 353
 354                 if (XINT(c) > 0 && XINT(c) <= dim) {
 355                         newos[i] = oldos[XINT(c)-1];
 356                 } else {
 357                         newos[i] = Qzero;
 358                         /* should be Fzero(itype) */
 359                 }
 360         }
 361
 362         return ase_make_cartesian(newdim, newos, 0);
 363 }
 364
 365 \f
 366 #define EMODNAME        ase_cartesian
 367
 368 void
 369 EMOD_PUBINIT(void)
 370 {
 371         /* constructors */
 372         DEFSUBR(Fase_cartesian);
 373         DEFSUBR(Fase_cartesianX);
 374         /* predicates */
 375         DEFSUBR(Fase_cartesianp);
 376         DEFSUBR(Fase_cartesianXp);
 377         /* accessors */
 378         DEFSUBR(Fase_cartesian_ground_domain);
 379         DEFSUBR(Fase_cartesian_projection);
 380         DEFSUBR(Fase_cartesian_embed);
 381
 382         defsymbol(&Qase_cartesian, "ase:cartesian");
 383         defsymbol(&Qase_cartesianp, "ase:cartesianp");
 384         defsymbol(&Qase_cartesian_interior, "ase:cartesian/");
 385         defsymbol(&Qase_cartesian_interior_p, "ase:cartesian/...-p");
 386
 387         DEFERROR(Qembed_error,
 388                  "Cannot embed domain unambiguously", Qdomain_error);
 389         DEFERROR(Qinterior_error,
 390                  "Cannot find an interior product, "
 391                  "types of objects must coincide", Qdomain_error);
 392
 393         Fprovide(intern("ase-cartesian"));
 394         return;
 395 }
 396
 397 void
 398 EMOD_PUBREINIT(void)
 399 {
 400         return;
 401 }
 402
 403 void
 404 EMOD_PUBDEINIT(void)
 405 {
 406         /* constructors */
 407         UNDEFSUBR(Fase_cartesian);
 408         UNDEFSUBR(Fase_cartesianX);
 409         /* predicates */
 410         UNDEFSUBR(Fase_cartesianp);
 411         UNDEFSUBR(Fase_cartesianXp);
 412         /* accessors */
 413         UNDEFSUBR(Fase_cartesian_ground_domain);
 414         UNDEFSUBR(Fase_cartesian_projection);
 415         UNDEFSUBR(Fase_cartesian_embed);
 416
 417         Frevoke(intern("ase-cartesian"));
 418         return;
 419 }
 420
 421 /* ase-cartesian ends here */