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

   1 /*** ase-permutation.c -- Permutations
   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-permutation.h"
  45
  46 PROVIDE(ase_permutation);
  47 REQUIRE(ase_permutation, "ase");
  48
  49 Lisp_Object Qase_permutation, Qase_permutationp;
  50 Lisp_Object Qase_identity_permutation;
  51 Lisp_Object Qpermutation_error, Qoverlap_error;
  52 static int sane_small;
  53
  54 \f
  55 /* stuff for the dynacat */
  56 static void
  57 _ase_permutation_prnt_cyc(unsigned long *p, unsigned long idx, Lisp_Object pcf)
  58 {
  59         unsigned long q;
  60
  61         write_fmt_string(pcf, "(%ld", idx+1);
  62         for (q = p[idx]; q != idx; q = p[q])
  63                 write_fmt_str(pcf, " %ld", q+1);
  64         write_c_string(")", pcf);
  65 }
  66
  67 static void
  68 _ase_permutation_prnt(ase_permutation_t n, Lisp_Object pcf)
  69 {
  70         size_t deg = ase_permutation_degree(n);
  71         unsigned long *perm = ase_permutation_perm(n);
  72         size_t i = 0;
  73
  74         if (deg == 0) {
  75                 write_c_string("()", pcf);
  76                 return;
  77         }
  78
  79         for (i = 0; i < deg; i++) {
  80                 /* find the smallest element in this cycle                         */
  81                 unsigned long q = perm[i];
  82                 while (i < q)
  83                         q = perm[q];
  84
  85                 /* if the smallest is the one we started with
  86                  * lets print the cycle */
  87                 if (i == q && perm[i] != i) {
  88                         _ase_permutation_prnt_cyc(perm, i, pcf);
  89                 }
  90         }
  91         return;
  92 }
  93
  94 static void
  95 ase_permutation_prnt(Lisp_Object obj, Lisp_Object pcf, int unused)
  96 {
  97         EMOD_ASE_DEBUG_PERM("p:0x%08x@0x%08x (rc:%d)\n",
  98                            (unsigned int)(XASE_PERMUTATION(obj)),
  99                             (unsigned int)obj, 1);
 100         write_c_string("#<ase:permutation ", pcf);
 101         _ase_permutation_prnt(XASE_PERMUTATION(obj), pcf);
 102         write_c_string(">", pcf);
 103 }
 104
 105 static void
 106 ase_permutation_fini(Lisp_Object obj, int unused)
 107 {
 108         ase_permutation_t free_me = XASE_PERMUTATION(obj);
 109
 110         EMOD_ASE_DEBUG_GC("p:%p@%p (rc:%d) shall be freed...\n",
 111                           free_me, (void*)obj, 1);
 112
 113         xfree(ase_permutation_perm(free_me));
 114         xfree(free_me);
 115         return;
 116 }
 117
 118 static inline void
 119 _ase_permutation_mark(ase_permutation_t SXE_UNUSED(unused))
 120 {
 121         return;
 122 }
 123
 124 static void
 125 ase_permutation_mark(Lisp_Object obj)
 126 {
 127         EMOD_ASE_DEBUG_PERM("p:0x%08x@0x%08x (rc:%d) shall be marked...\n",
 128                             (unsigned int)(XASE_PERMUTATION(obj)),
 129                             (unsigned int)obj, 1);
 130         _ase_permutation_mark(XASE_PERMUTATION(obj));
 131         return;
 132 }
 133
 134 \f
 135 Lisp_Object
 136 _ase_wrap_permutation(ase_permutation_t n)
 137 {
 138         Lisp_Object result;
 139
 140         result = make_dynacat(n);
 141         XDYNACAT(result)->type = Qase_permutation;
 142
 143 #if 0
 144         if (n)
 145                 ase_permutation_incref(n);
 146 #endif
 147         set_dynacat_printer(result, ase_permutation_prnt);
 148         set_dynacat_marker(result, ase_permutation_mark);
 149         set_dynacat_finaliser(result, ase_permutation_fini);
 150
 151         EMOD_ASE_DEBUG_PERM("p:0x%08x (rc:%d) shall be wrapped to 0x%08x...\n",
 152                             (unsigned int)n,
 153                             1, (unsigned int)result);
 154
 155         return result;
 156 }
 157
 158 static inline ase_permutation_t
 159 _ase_make_permutation(size_t deg, unsigned long *perm)
 160 {
 161         ase_permutation_t n = xnew_and_zero(struct ase_permutation_s);
 162
 163         ase_permutation_degree(n) = deg;
 164         ase_permutation_perm(n) = perm;
 165
 166         EMOD_ASE_DEBUG_PERM("p:%p (rc:0, deg:%d) shall be created...\n",
 167                             n, (int)deg);
 168         return n;
 169 }
 170
 171 static inline int
 172 ase_permutation_vecr_id_p(Lisp_Object vec)
 173 {
 174         size_t i = 0, deg = XVECTOR_LENGTH(vec);
 175
 176         while (i < deg) {
 177                 Lisp_Object tmp = XVECTOR_DATA(vec)[i];
 178                 CHECK_NATNUM(tmp);
 179                 if (tmp == Qzero) {
 180                         dead_wrong_type_argument(Qnatnump, tmp);
 181                 }
 182                 if (XUINT(tmp) != ++i)
 183                         return 0;
 184         }
 185         return 1;
 186 }
 187
 188 static inline int
 189 ase_permutation_cycr_id_p(Lisp_Object vec)
 190 {
 191         size_t i, deg = XVECTOR_LENGTH(vec), id_p = 1;
 192
 193         for (i = 0; i < deg; i++) {
 194                 Lisp_Object cyc = XVECTOR_DATA(vec)[i];
 195
 196                 if (NILP(cyc))
 197                         continue;
 198
 199                 CHECK_CONS(cyc);
 200                 id_p = 0;
 201                 while (!NILP(cyc)) {
 202                         Lisp_Object img = XCAR(cyc);
 203                         CHECK_NATNUM(img);
 204                         if (img == Qzero) {
 205                                 dead_wrong_type_argument(Qnatnump, img);
 206                         }
 207                         cyc = XCDR(cyc);
 208                 }
 209         }
 210         return id_p;
 211 }
 212
 213 static inline size_t
 214 ase_permutation_determine_deg(Lisp_Object vec)
 215 {
 216         /* vec is assumed to be in cycle representation */
 217         size_t len = XVECTOR_LENGTH(vec);
 218         size_t i, deg = 0;
 219
 220         for (i = 0; i < len; i++) {
 221                 Lisp_Object cyc = XVECTOR_DATA(vec)[i];
 222
 223                 if (NILP(cyc))
 224                         continue;
 225
 226                 while (!NILP(cyc)) {
 227                         Lisp_Object img = XCAR(cyc);
 228                         if (XUINT(img) > deg)
 229                                 deg = XUINT(img);
 230                         cyc = XCDR(cyc);
 231                 }
 232         }
 233         return deg;
 234 }
 235
 236 static inline void
 237 ase_permutation_init_cycr(size_t deg, unsigned long *p)
 238 {
 239         /* vec is assumed to be in cycle representation */
 240         size_t i;
 241
 242         for (i = 0; i < deg; i++) {
 243                 p[i] = i;
 244         }
 245         return;
 246 }
 247
 248 static inline void
 249 ase_permutation_copy_cycr(unsigned long *p, Lisp_Object vec)
 250 {
 251         /* vec is assumed to be in cycle representation */
 252         size_t len = XVECTOR_LENGTH(vec);
 253         size_t i;
 254
 255         for (i = 0; i < len; i++) {
 256                 Lisp_Object cyc = XVECTOR_DATA(vec)[i];
 257                 Lisp_Object first;
 258
 259                 if (NILP(cyc))
 260                         continue;
 261
 262                 first = XCAR(cyc);
 263                 while (!NILP(XCDR(cyc))) {
 264                         Lisp_Object pre = XCAR(cyc);
 265                         Lisp_Object post = XCAR((cyc = XCDR(cyc)));
 266                         p[XUINT(pre)-1] = XUINT(post)-1;
 267                 }
 268                 /* cyc should now look like (<elm> . nil) */
 269                 p[XUINT(XCAR(cyc))-1] = XUINT(first)-1;
 270         }
 271         return;
 272 }
 273
 274 static inline Lisp_Object
 275 ase_make_permutation_cycr(Lisp_Object vec)
 276 {
 277         ase_permutation_t a = NULL;
 278         size_t deg;
 279         unsigned long *perm;
 280
 281         EMOD_ASE_DEBUG_PERM("Creating perm from cycle representation ...\n");
 282
 283         if (ase_permutation_cycr_id_p(vec))
 284                 return Qase_identity_permutation;
 285
 286         deg = ase_permutation_determine_deg(vec);
 287         perm = xnew_array(unsigned long, deg);
 288         ase_permutation_init_cycr(deg, perm);
 289         ase_permutation_copy_cycr(perm, vec);
 290
 291         a = _ase_make_permutation(deg, perm);
 292         return _ase_wrap_permutation(a);
 293 }
 294
 295 static inline void
 296 ase_permutation_copy_vecr(unsigned long *p, Lisp_Object vec)
 297 {
 298         size_t i, deg = XVECTOR_LENGTH(vec);
 299
 300         for (i = 0; i < deg; i++) {
 301                 Lisp_Object tmp = XVECTOR_DATA(vec)[i];
 302                 unsigned long m = XUINT(tmp)-1;
 303                 p[i] = m;
 304         }
 305 }
 306
 307 static inline Lisp_Object
 308 ase_make_permutation_vecr(Lisp_Object vec)
 309 {
 310         ase_permutation_t a = NULL;
 311         size_t deg;
 312         unsigned long *perm;
 313
 314         EMOD_ASE_DEBUG_PERM("Creating perm from mapping representation ...\n");
 315
 316         if (ase_permutation_vecr_id_p(vec))
 317                 return Qase_identity_permutation;
 318
 319         deg = XVECTOR_LENGTH(vec);
 320         perm = xnew_array(unsigned long, deg);
 321         ase_permutation_copy_vecr(perm, vec);
 322
 323         a = _ase_make_permutation(deg, perm);
 324         return _ase_wrap_permutation(a);
 325 }
 326
 327 static inline int
 328 ase_permutation_cycrep_p(Lisp_Object vec)
 329 {
 330         if (XVECTOR_LENGTH(vec) == 0)
 331                 return 0;
 332         return (CONSP(XVECTOR_DATA(vec)[0]) ||
 333                 NILP(XVECTOR_DATA(vec)[0]));
 334 }
 335
 336 Lisp_Object
 337 ase_make_permutation(Lisp_Object vec)
 338 {
 339         if (ase_permutation_cycrep_p(vec))
 340                 return ase_make_permutation_cycr(vec);
 341         else
 342                 return ase_make_permutation_vecr(vec);
 343 }
 344
 345 /* accessors */
 346
 347
 348 \f
 349 /* lisp level */
 350 DEFUN("ase-permutationp", Fase_permutationp, 1, 1, 0, /*
 351 Return non-`nil' iff OBJECT is an ase permutation.
 352 */
 353       (object))
 354 {
 355         if (ASE_PERMUTATIONP(object))
 356                 return Qt;
 357
 358         return Qnil;
 359 }
 360
 361 /* ###autoload */
 362 DEFUN("ase-permutation", Fase_permutation, 1, 1, 0, /*
 363 Return a permutation around with POINT of radius RADIUS
 364 with respect to METRIC (optional).
 365
 366 If no special metric is given, the supremum metric is used.
 367 */
 368       (vector))
 369 {
 370         return ase_make_permutation(vector);
 371 }
 372
 373
 374 /* accessors */
 375
 376
 377 \f
 378 /* initialiser code */
 379 #define EMODNAME        ase_permutation
 380
 381 void
 382 EMOD_PUBINIT(void)
 383 {
 384         /* constructors */
 385         DEFSUBR(Fase_permutation);
 386         /* predicates */
 387         DEFSUBR(Fase_permutationp);
 388         /* accessors */
 389
 390         defsymbol(&Qase_permutation, "ase:permutation");
 391         defsymbol(&Qase_permutationp, "ase:permutationp");
 392
 393         DEFERROR(Qpermutation_error,
 394                  "Permutation error", Qdomain_error);
 395         DEFERROR(Qoverlap_error,
 396                  "Permutations must not overlap", Qpermutation_error);
 397
 398         Fprovide(intern("ase-permutation"));
 399
 400         DEFVAR_CONST_LISP("ase-identity-permutation",
 401                           &Qase_identity_permutation /*
 402 The identity permutation.
 403                                                      */);
 404         EMOD_PUBREINIT();
 405 }
 406
 407 void
 408 EMOD_PUBREINIT(void)
 409 {
 410         sane_small = (snprintf(NULL, 0, "%ld", EMACS_INT_MAX) + 7) & -3;
 411         Qase_identity_permutation =
 412                 _ase_wrap_permutation(_ase_make_permutation(0, NULL));
 413         /* defined in lread.c, declared in ent.h */
 414         ase_permutation_f = ase_make_permutation;
 415 }
 416
 417 void
 418 EMOD_PUBDEINIT(void)
 419 {
 420         Frevoke(intern("ase-permutation"));
 421 }
 422
 423 /* ase-permutation ends here */