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

   1 /*** ase-neighbourhood.c -- Neighbourhood of ASE objects
   2  *
   3  * Copyright (C) 2006 - 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
  38 /* Synched up with: Not in FSF. */
  39
  40 #include "config.h"
  41 #include "sxemacs.h"
  42 #include "ent/ent.h"
  43 #include "ase.h"
  44 #include "ase-neighbourhood.h"
  45
  46 #define EMOD_ASE_DEBUG_NBH(args...)     EMOD_ASE_DEBUG("[NBH]: " args)
  47
  48 #define EMODNAME        ase_neighbourhood
  49
  50 PROVIDE(ase_neighbourhood);
  51 REQUIRE(ase_neighbourhood, "ase", "ase-interval");
  52
  53 Lisp_Object Qase_neighbourhood, Qase_neighbourhoodp;
  54
  55 \f
  56 /* stuff for the dynacat */
  57 static void
  58 _ase_neighbourhood_prnt(ase_neighbourhood_t n, Lisp_Object pcf)
  59 {
  60         write_c_string("{p : (< (d ", pcf);
  61         print_internal(n->point, pcf, 0);
  62         write_c_string(" p) ", pcf);
  63         print_internal(n->radius, pcf, 0);
  64         write_c_string("}", pcf);
  65 }
  66
  67 static void
  68 ase_neighbourhood_prnt(Lisp_Object obj, Lisp_Object pcf, int unused)
  69 {
  70         EMOD_ASE_DEBUG_NBH("n:0x%08x@0x%08x (rc:%d)\n",
  71                            (unsigned int)(XASE_NEIGHBOURHOOD(obj)),
  72                            (unsigned int)obj,
  73                            (XASE_NEIGHBOURHOOD(obj) ?
  74                             XASE_NEIGHBOURHOOD_REFVAL(obj) : 1));
  75         write_c_string("#<ase:neighbourhood ", pcf);
  76         _ase_neighbourhood_prnt(XASE_NEIGHBOURHOOD(obj), pcf);
  77         write_c_string(" wrt supremum metric>", pcf);
  78 }
  79
  80 static void
  81 ase_neighbourhood_fini(Lisp_Object obj, int unused)
  82 {
  83         ase_neighbourhood_t n = XASE_NEIGHBOURHOOD(obj);
  84
  85         EMOD_ASE_DEBUG_GC("n:0x%08x@0x%08x (rc:%d) shall be freed...\n",
  86                           (unsigned int)(n), (unsigned int)obj,
  87                           ase_neighbourhood_refval(n));
  88
  89         if (ase_neighbourhood_decref(n) <= 0) {
  90                 if (n->data)
  91                         xfree(n->data);
  92                 n->data = NULL;
  93                 ase_neighbourhood_fini_refcnt(n);
  94                 xfree(n);
  95         } else {
  96                 EMOD_ASE_DEBUG_GC("VETO! References exist\n");
  97         }
  98         return;
  99 }
 100
 101 static void
 102 _ase_neighbourhood_mark(ase_neighbourhood_t n)
 103 {
 104         if (n == NULL)
 105                 return;
 106
 107         mark_object(n->point);
 108         mark_object(n->radius);
 109         mark_object(n->lebesgue_measure);
 110         mark_object(n->rational_measure);
 111         mark_object(n->colour);
 112
 113         if (n->ldata) {
 114                 mark_object(n->ldata);
 115         }
 116
 117         return;
 118 }
 119
 120 static void
 121 ase_neighbourhood_mark(Lisp_Object obj)
 122 {
 123         EMOD_ASE_DEBUG_NBH("n:0x%08x@0x%08x (rc:%d) shall be marked...\n",
 124                            (unsigned int)(XASE_NEIGHBOURHOOD(obj)),
 125                            (unsigned int)obj,
 126                            (XASE_NEIGHBOURHOOD(obj) ?
 127                             XASE_NEIGHBOURHOOD_REFVAL(obj) : 1));
 128         _ase_neighbourhood_mark(XASE_NEIGHBOURHOOD(obj));
 129         return;
 130 }
 131
 132 \f
 133 Lisp_Object
 134 _ase_wrap_neighbourhood(ase_neighbourhood_t n)
 135 {
 136         Lisp_Object result;
 137
 138         result = make_dynacat(n);
 139         XDYNACAT(result)->type = Qase_neighbourhood;
 140
 141         if (n)
 142                 ase_neighbourhood_incref(n);
 143
 144         set_dynacat_printer(result, ase_neighbourhood_prnt);
 145         set_dynacat_marker(result, ase_neighbourhood_mark);
 146         set_dynacat_finaliser(result, ase_neighbourhood_fini);
 147
 148         EMOD_ASE_DEBUG_NBH("n:0x%08x (rc:%d) shall be wrapped to 0x%08x...\n",
 149                            (unsigned int)n,
 150                            (n ? ase_neighbourhood_refval(n) : 1),
 151                            (unsigned int)result);
 152
 153         return result;
 154 }
 155
 156 static inline Lisp_Object
 157 __ase_make_neighbourhood_intv(Lisp_Object p, Lisp_Object r)
 158 {
 159         Lisp_Object lo, up;
 160         Lisp_Object args[2] = {p, r};
 161
 162         /* special case r == 0 */
 163         if (!NILP(Fzerop(r))) {
 164                 return ase_make_interval(p, p, 0, 0);
 165         }
 166
 167         lo = Fent_binop_diff(countof(args), args);
 168         up = Fent_binop_sum(countof(args), args);
 169
 170         return ase_make_interval(lo, up, 1, 1);
 171 }
 172
 173 static Lisp_Object
 174 __ase_make_neighbourhood_intr(Lisp_Object p, Lisp_Object r)
 175 {
 176         Lisp_Object args[2] = {Qnil, r};
 177         int i, dim = XASE_CARTESIAN_DIMENSION(p);
 178         Lisp_Object *tmp = alloca_array(Lisp_Object, dim);
 179         Lisp_Object *pobjs = XASE_CARTESIAN_OBJECTS(p);
 180
 181         /* special case r == 0 */
 182         if (!NILP(Fzerop(r))) {
 183                 for (i = 0; i < dim; i++) {
 184                         tmp[i] = ase_make_interval(pobjs[i], pobjs[i], 0, 0);
 185                 }
 186                 return ase_make_cartesian(dim, tmp, 1);
 187         }
 188
 189         for (i = 0; i < dim; i++) {
 190                 Lisp_Object lo, up;
 191                 args[0] = pobjs[i];
 192                 lo = Fent_binop_diff(countof(args), args);
 193                 up = Fent_binop_sum(countof(args), args);
 194                 tmp[i] = ase_make_interval(lo, up, 1, 1);
 195         }
 196         return ase_make_cartesian(dim, tmp, 1);
 197 }
 198
 199 static ase_neighbourhood_t
 200 _ase_make_neighbourhood(Lisp_Object p, Lisp_Object r, void *metric)
 201 {
 202         ase_neighbourhood_t n = NULL;
 203
 204         n = xnew(struct ase_neighbourhood_s);
 205
 206         n->open_p = 1;
 207         n->point = p;
 208         n->radius = r;
 209
 210         n->lebesgue_measure = Qnil;
 211         n->rational_measure = Qnil;
 212         n->colour = Qnil;
 213
 214         /* if it's the supremum metric (atm it always is) we use our
 215          * fancy interval implementation */
 216         if (COMPARABLEP(p))
 217                 n->ldata = __ase_make_neighbourhood_intv(p, r);
 218         else if (ASE_CARTESIAN_INTERIOR_P(p))
 219                 n->ldata = __ase_make_neighbourhood_intr(p, r);
 220         n->data = NULL;
 221
 222         /* initialise the reference counter */
 223         ase_neighbourhood_init_refcnt(n);
 224
 225         EMOD_ASE_DEBUG_NBH("n:%p (rc:0) shall be created...\n", n);
 226         return n;
 227 }
 228
 229 inline Lisp_Object
 230 ase_make_neighbourhood(Lisp_Object pt, Lisp_Object rad, Lisp_Object metric)
 231 {
 232         ase_neighbourhood_t a = NULL;
 233         Lisp_Object result = Qnil;
 234
 235         a = _ase_make_neighbourhood(pt, rad, NULL);
 236         XSETASE_NEIGHBOURHOOD(result, a);
 237
 238         return result;
 239 }
 240
 241 /* accessors */
 242 inline Lisp_Object
 243 ase_neighbourhood_point(ase_neighbourhood_t n)
 244 {
 245         return n->point;
 246 }
 247
 248 inline Lisp_Object
 249 ase_neighbourhood_radius(ase_neighbourhood_t n)
 250 {
 251         return n->radius;
 252 }
 253
 254 /* Measures */
 255 static inline void
 256 _ase_neighbourhood_update_lebesgue(ase_neighbourhood_t n)
 257 {
 258         if (n && NILP(n->lebesgue_measure)) {
 259                 Lisp_Object i = n->ldata;
 260                 n->lebesgue_measure = Fase_interval_lebesgue_measure(i);
 261         }
 262         return;
 263 }
 264
 265 static inline Lisp_Object
 266 _ase_neighbourhood_lebesgue(ase_neighbourhood_t n)
 267 {
 268         return n->lebesgue_measure;
 269 }
 270
 271 inline Lisp_Object
 272 ase_neighbourhood_lebesgue_measure(ase_neighbourhood_t n)
 273 {
 274         _ase_neighbourhood_update_lebesgue(n);
 275         return _ase_neighbourhood_lebesgue(n);
 276 }
 277
 278 static inline void
 279 _ase_neighbourhood_update_rational(ase_neighbourhood_t n)
 280 {
 281         if (n && NILP(n->rational_measure)) {
 282                 Lisp_Object i = n->ldata;
 283                 n->rational_measure = Fase_interval_rational_measure(i);
 284         }
 285         return;
 286 }
 287
 288 static inline Lisp_Object
 289 _ase_neighbourhood_rational(ase_neighbourhood_t n)
 290 {
 291         return n->rational_measure;
 292 }
 293
 294 inline Lisp_Object
 295 ase_neighbourhood_rational_measure(ase_neighbourhood_t n)
 296 {
 297         _ase_neighbourhood_update_rational(n);
 298         return _ase_neighbourhood_rational(n);
 299 }
 300
 301 \f
 302 /* lisp level */
 303 DEFUN("ase-neighbourhoodp", Fase_neighbourhoodp, 1, 1, 0, /*
 304 Return non-`nil' iff OBJECT is an ase neighbourhood.
 305 */
 306       (object))
 307 {
 308         if (ASE_NEIGHBOURHOODP(object))
 309                 return Qt;
 310
 311         return Qnil;
 312 }
 313
 314 /* ###autoload */
 315 DEFUN("ase-neighbourhood", Fase_neighbourhood, 2, 3, 0, /*
 316 Return a neighbourhood around with POINT of radius RADIUS
 317 with respect to METRIC (optional).
 318
 319 If no special metric is given, the supremum metric is used.
 320 */
 321       (point, radius, metric))
 322 {
 323         if (!COMPARABLEP(point) &&
 324             !(ASE_CARTESIAN_INTERIOR_P(point))) {
 325                 dead_wrong_type_argument(Qase_cartesian_interior_p, point);
 326         }
 327         CHECK_COMPARABLE(radius);
 328
 329         if (NILP(Fnonnegativep(radius)))
 330                 return wrong_type_argument(Qnonnegativep, radius);
 331
 332         return ase_make_neighbourhood(point, radius, metric);
 333 }
 334
 335 DEFUN("ase-neighbourhood-open-p", Fase_neighbourhood_open_p, 1, 1, 0, /*
 336 Return non-`nil' iff NEIGHBOURHOOD is open with respect to its metric.
 337 */
 338       (neighbourhood))
 339 {
 340         CHECK_ASE_NEIGHBOURHOOD(neighbourhood);
 341
 342         if (ase_neighbourhood_open_p(XASE_NEIGHBOURHOOD(neighbourhood)))
 343                 return Qt;
 344
 345         return Qnil;
 346 }
 347
 348 DEFUN("ase-neighbourhood-closed-p", Fase_neighbourhood_closed_p, 1, 1, 0, /*
 349 Return non-`nil' iff NEIGHBOURHOOD is closed with respect to its metric.
 350 */
 351       (neighbourhood))
 352 {
 353         CHECK_ASE_NEIGHBOURHOOD(neighbourhood);
 354
 355         if (ase_neighbourhood_closed_p(XASE_NEIGHBOURHOOD(neighbourhood)))
 356                 return Qt;
 357
 358         return Qnil;
 359 }
 360
 361 DEFUN("ase-neighbourhood-contains-p", Fase_neighbourhood_contains_p, 2, 2, 0, /*
 362 Return non-`nil' iff NEIGHBOURHOOD contains OBJECT.
 363 OBJECT may also be another neighbourhood under the restriction that
 364 both neighbourhoods must be defined over the same metric space.
 365 */
 366       (neighbourhood, object))
 367 {
 368         CHECK_ASE_NEIGHBOURHOOD(neighbourhood);
 369
 370         if (COMPARABLEP(object)) {
 371                 if (ase_neighbourhood_contains_obj_p(
 372                             XASE_NEIGHBOURHOOD(neighbourhood), object))
 373                         return Qt;
 374         } else if (ASE_NEIGHBOURHOODP(object)) {
 375                 if (ase_neighbourhood_contains_nbh_p(
 376                             XASE_NEIGHBOURHOOD(neighbourhood),
 377                             XASE_NEIGHBOURHOOD(object)))
 378                         return Qt;
 379         }
 380
 381         return Qnil;
 382 }
 383
 384 DEFUN("ase-neighbourhood-equal-p", Fase_neighbourhood_equal_p, 2, 2, 0, /*
 385 Return non-`nil' if N1 and N2 are equal in some sense, equality
 386 hereby means that N1 and N2 contain each other.
 387
 388 In fact, this is just a convenience function and totally equivalent
 389 to
 390   (and (ase-neighbourhood-contains-p n1 n2)
 391        (ase-neighbourhood-contains-p n2 n1))
 392
 393 Both neighbourhoods must be defined over the same metric space.
 394 */
 395       (n1, n2))
 396 {
 397         Lisp_Object n1in2, n2in1;
 398
 399         CHECK_ASE_NEIGHBOURHOOD(n1);
 400         CHECK_ASE_NEIGHBOURHOOD(n2);
 401
 402         n1in2 = Fase_neighbourhood_contains_p(n1, n2);
 403         n2in1 = Fase_neighbourhood_contains_p(n2, n1);
 404
 405         if (!NILP(n1in2) && !NILP(n2in1))
 406                 return Qt;
 407
 408         return Qnil;
 409 }
 410
 411 /* just for now until we can overload <, > and = */
 412 DEFUN("ase-neighbourhood-<", Fase_neighbourhood_lssp, 2, 2, 0, /*
 413 Return (< n1 n2).
 414 */
 415       (n1, n2))
 416 {
 417         int cmp;
 418
 419         CHECK_ASE_NEIGHBOURHOOD_OR_COMPARABLE(n1);
 420         CHECK_ASE_NEIGHBOURHOOD_OR_COMPARABLE(n2);
 421
 422         if (COMPARABLEP(n1) && ASE_NEIGHBOURHOODP(n2)) {
 423                 cmp = ase_neighbourhood_greater_obj_p(
 424                         XASE_NEIGHBOURHOOD(n2), n1);
 425         } else if (COMPARABLEP(n2) && ASE_NEIGHBOURHOODP(n1)) {
 426                 cmp = ase_neighbourhood_less_obj_p(
 427                         XASE_NEIGHBOURHOOD(n1), n2);
 428         } else if (ASE_NEIGHBOURHOODP(n1) && ASE_NEIGHBOURHOODP(n2)) {
 429                 cmp = ase_neighbourhood_less_nbh_p(
 430                         XASE_NEIGHBOURHOOD(n1), XASE_NEIGHBOURHOOD(n2));
 431         } else
 432                 return _ase_less_p(n1, n2);
 433
 434         if (cmp)
 435                 return Qt;
 436
 437         return Qnil;
 438 }
 439
 440 DEFUN("ase-neighbourhood->", Fase_neighbourhood_gtrp, 2, 2, 0, /*
 441 Return (> n1 n2).
 442 */
 443       (n1, n2))
 444 {
 445         int cmp;
 446
 447         CHECK_ASE_NEIGHBOURHOOD_OR_COMPARABLE(n1);
 448         CHECK_ASE_NEIGHBOURHOOD_OR_COMPARABLE(n2);
 449
 450         if (COMPARABLEP(n1) && ASE_NEIGHBOURHOODP(n2)) {
 451                 cmp = ase_neighbourhood_less_obj_p(
 452                         XASE_NEIGHBOURHOOD(n2), n1);
 453         } else if (COMPARABLEP(n2) && ASE_NEIGHBOURHOODP(n1)) {
 454                 cmp = ase_neighbourhood_greater_obj_p(
 455                         XASE_NEIGHBOURHOOD(n1), n2);
 456         } else if (ASE_NEIGHBOURHOODP(n1) && ASE_NEIGHBOURHOODP(n2)) {
 457                 cmp = ase_neighbourhood_greater_nbh_p(
 458                         XASE_NEIGHBOURHOOD(n1), XASE_NEIGHBOURHOOD(n2));
 459         } else
 460                 return _ase_less_p(n2, n1);
 461
 462         if (cmp)
 463                 return Qt;
 464
 465         return Qnil;
 466 }
 467
 468 /* accessors */
 469 DEFUN("ase-neighbourhood-point", Fase_neighbourhood_point, 1, 1, 0, /*
 470 Return the point of NEIGHBOURHOOD which defined it.
 471 */
 472       (neighbourhood))
 473 {
 474         CHECK_ASE_NEIGHBOURHOOD(neighbourhood);
 475
 476         return ase_neighbourhood_point(XASE_NEIGHBOURHOOD(neighbourhood));
 477 }
 478
 479 DEFUN("ase-neighbourhood-radius", Fase_neighbourhood_radius, 1, 1, 0, /*
 480 Return the radius of NEIGHBOURHOOD which defined it.
 481 */
 482       (neighbourhood))
 483 {
 484         CHECK_ASE_NEIGHBOURHOOD(neighbourhood);
 485
 486         return ase_neighbourhood_radius(XASE_NEIGHBOURHOOD(neighbourhood));
 487 }
 488
 489 /* Measures */
 490 DEFUN("ase-neighbourhood-lebesgue-measure", Fase_neighbourhood_lebesgue_measure, 1, 1, 0, /*
 491 Return the Lebesgue measure of NEIGHBOURHOOD.
 492 */
 493       (neighbourhood))
 494 {
 495         CHECK_ASE_NEIGHBOURHOOD(neighbourhood);
 496
 497         return ase_neighbourhood_lebesgue_measure(
 498                 XASE_NEIGHBOURHOOD(neighbourhood));
 499 }
 500
 501 DEFUN("ase-neighbourhood-rational-measure", Fase_neighbourhood_rational_measure, 1, 1, 0, /*
 502 Return the number of rational integers in NEIGHBOURHOOD.
 503 */
 504       (neighbourhood))
 505 {
 506         CHECK_ASE_NEIGHBOURHOOD(neighbourhood);
 507
 508         return ase_neighbourhood_rational_measure(
 509                 XASE_NEIGHBOURHOOD(neighbourhood));
 510 }
 511
 512 \f
 513 /* initialiser code */
 514 void
 515 EMOD_PUBINIT(void)
 516 {
 517         /* constructors */
 518         DEFSUBR(Fase_neighbourhood);
 519         /* predicates */
 520         DEFSUBR(Fase_neighbourhoodp);
 521         DEFSUBR(Fase_neighbourhood_open_p);
 522         DEFSUBR(Fase_neighbourhood_closed_p);
 523         DEFSUBR(Fase_neighbourhood_contains_p);
 524         DEFSUBR(Fase_neighbourhood_equal_p);
 525         DEFSUBR(Fase_neighbourhood_lssp);
 526         DEFSUBR(Fase_neighbourhood_gtrp);
 527         /* accessors */
 528         DEFSUBR(Fase_neighbourhood_point);
 529         DEFSUBR(Fase_neighbourhood_radius);
 530         /* measures */
 531         DEFSUBR(Fase_neighbourhood_lebesgue_measure);
 532         DEFSUBR(Fase_neighbourhood_rational_measure);
 533
 534         defsymbol(&Qase_neighbourhood, "ase:neighbourhood");
 535         defsymbol(&Qase_neighbourhoodp, "ase:neighbourhoodp");
 536
 537         Fprovide(intern("ase-neighbourhood"));
 538 }
 539
 540 void
 541 EMOD_PUBREINIT(void)
 542 {
 543 }
 544
 545 void
 546 EMOD_PUBDEINIT(void)
 547 {
 548         Frevoke(intern("ase-neighbourhood"));
 549 }
 550
 551 /* ase-neighbourhood ends here */