2 ase-cartesian.c -- Cartesian (exterior) product for ASE objects
3 Copyright (C) 2006, 2007, 2008 Sebastian Freundt
5 Author: Sebastian Freundt <hroptatyr@sxemacs.org>
7 * This file is part of SXEmacs.
9 * Redistribution and use in source and binary forms, with or without
10 * modification, are permitted provided that the following conditions
13 * 1. Redistributions of source code must retain the above copyright
14 * notice, this list of conditions and the following disclaimer.
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.
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.
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.
37 /* Synched up with: Not in FSF. */
43 #include "ase-cartesian.h"
45 PROVIDE(ase_cartesian);
46 REQUIRE(ase_cartesian, "ase");
48 Lisp_Object Qase_cartesian, Qase_cartesianp;
49 Lisp_Object Qase_cartesian_interior, Qase_cartesian_interior_p;
50 Lisp_Object Qembed_error, Qinterior_error;
53 /* stuff for the dynacat */
55 _ase_cartesian_prnt_ase_object(Lisp_Object o, Lisp_Object pcf)
57 dynacat_intprinter_f prfun = NULL;
62 prfun = get_dynacat_intprinter(o);
66 prfun(get_dynacat(o), pcf);
71 _ase_cartesian_prnt(ase_cartesian_t n, Lisp_Object pcf)
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);
82 if (i+1 < n->dimension)
83 write_c_string(" x ", pcf);
88 ase_cartesian_prnt(Lisp_Object obj, Lisp_Object pcf, int unused)
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);
98 write_fmt_str(pcf, " of dimension %d, ",
99 XASE_CARTESIAN_DIMENSION(obj));
100 _ase_cartesian_prnt(XASE_CARTESIAN(obj), pcf);
102 write_c_string(">", pcf);
106 ase_cartesian_fini(Lisp_Object obj, int unused)
108 ase_cartesian_t n = XASE_CARTESIAN(obj);
110 EMOD_ASE_DEBUG_GC("n:0x%08x@0x%08x (rc:%d) shall be freed...\n",
111 (unsigned int)(n), (unsigned int)obj, 1);
113 if (ase_cartesian_decref(n) <= 0) {
114 ase_cartesian_fini_refcnt(n);
118 EMOD_ASE_DEBUG_GC("VETO! References exist\n");
124 _ase_cartesian_mark(ase_cartesian_t n)
131 for (i = 0; i < n->dimension; i++)
132 mark_object(n->objects[i]);
134 mark_object(n->lebesgue_measure);
135 mark_object(n->rational_measure);
136 mark_object(n->colour);
137 mark_object(n->interior_type);
142 ase_cartesian_mark(Lisp_Object obj)
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));
153 _ase_wrap_cartesian(ase_cartesian_t n)
157 result = make_dynacat(n);
158 XDYNACAT_TYPE(result) = Qase_cartesian;
161 ase_cartesian_incref(n);
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);
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);
176 _ase_wrap_cartesian_interior(ase_cartesian_t n)
180 result = make_dynacat(n);
181 XDYNACAT_TYPE(result) = Qase_cartesian_interior;
184 ase_cartesian_incref(n);
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);
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);
199 ase_make_cartesian(int nargs, Lisp_Object *args, int interiorp)
201 ase_cartesian_t c = NULL;
202 Lisp_Object result = Qnil;
205 /* We're in ZFC! So refuse to generate cartesian sets with
206 * empty set consituents, in terms: A x ( ) -> ( ) */
208 for (i = 0; i < nargs; i++) {
209 WITH_DLLIST_TRAVERSE(
211 if ((void*)args[i] == dllist_item) {
212 RETURN_FROM_DLLIST_TRAVERSE(
213 ase_empty_sets, args[i]);
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);
226 c = _ase_make_cartesian(nargs, args, interiorp);
228 XSETASE_CARTESIAN(result, c);
230 XSETASE_CARTESIAN_INTERIOR(result, c);
238 DOESNT_RETURN ase_cartesian_embedding_error(Lisp_Object o1, Lisp_Object o2)
240 signal_error(Qembed_error, list2(o1, o2));
246 DEFUN("ase-cartesianp", Fase_cartesianp, 1, 1, 0, /*
247 Return non-`nil' iff OBJECT is a cartesian product of objects.
251 if (ASE_CARTESIANP(object))
257 DEFUN("ase-cartesian*p", Fase_cartesianXp, 1, 1, 0, /*
258 Return non-`nil' iff OBJECT is an interior cartesian product of objects.
262 if (ASE_CARTESIAN_INTERIOR_P(object))
269 DEFUN("ase-cartesian", Fase_cartesian, 0, MANY, 0, /*
270 Return a cartesian (exterior) product of OBJECTS.
272 (int nargs, Lisp_Object *args))
279 return ase_make_cartesian(nargs, args, 0);
283 DEFUN("ase-cartesian*", Fase_cartesianX, 0, MANY, 0, /*
284 Return an interior cartesian product of OBJECTS.
286 (int nargs, Lisp_Object *args))
296 tmp = Ftype_of(args[0]);
297 for (i = 1; i < nargs; i++) {
299 if (!EQ(tmp, (tmpi = Ftype_of(args[i]))))
300 signal_error(Qinterior_error, list2(tmp, tmpi));
303 return ase_make_cartesian(nargs, args, 1);
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.
312 CHECK_ASE_CARTESIAN_INTERIOR(object);
313 return XASE_CARTESIAN_INTERIOR_TYPE(object);
316 DEFUN("ase-cartesian-projection", Fase_cartesian_projection, 2, 2, 0, /*
317 Return the projection of CARTESIAN onto the DIMENSION-th component.
319 (cartesian, dimension))
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);
328 return XASE_CARTESIAN_OBJECTS(cartesian)[XINT(dimension)-1];
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.
336 (cartesian, dimension))
339 Lisp_Object *newos, *oldos, *vec;
341 CHECK_ASE_UBERCARTESIAN(cartesian);
342 CHECK_VECTOR(dimension);
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);
350 for (i = 0; i < newdim; i++) {
351 Lisp_Object c = vec[i];
354 if (XINT(c) > 0 && XINT(c) <= dim) {
355 newos[i] = oldos[XINT(c)-1];
358 /* should be Fzero(itype) */
362 return ase_make_cartesian(newdim, newos, 0);
366 #define EMODNAME ase_cartesian
372 DEFSUBR(Fase_cartesian);
373 DEFSUBR(Fase_cartesianX);
375 DEFSUBR(Fase_cartesianp);
376 DEFSUBR(Fase_cartesianXp);
378 DEFSUBR(Fase_cartesian_ground_domain);
379 DEFSUBR(Fase_cartesian_projection);
380 DEFSUBR(Fase_cartesian_embed);
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");
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);
393 Fprovide(intern("ase-cartesian"));
407 UNDEFSUBR(Fase_cartesian);
408 UNDEFSUBR(Fase_cartesianX);
410 UNDEFSUBR(Fase_cartesianp);
411 UNDEFSUBR(Fase_cartesianXp);
413 UNDEFSUBR(Fase_cartesian_ground_domain);
414 UNDEFSUBR(Fase_cartesian_projection);
415 UNDEFSUBR(Fase_cartesian_embed);
417 Frevoke(intern("ase-cartesian"));
421 /* ase-cartesian ends here */