cgit.sxemacs.org Git - sxemacs/blob - src/ent/ent-quatern.c

   1 /*
   2   ent-quatern.c -- Numeric types for SXEmacs
   3   Copyright (C) 2005, 2006 Sebastian Freundt
   4
   5   Author:  Sebastian Freundt
   6
   7 This file is part of SXEmacs
   8
   9 SXEmacs is free software: you can redistribute it and/or modify
  10 it under the terms of the GNU General Public License as published by
  11 the Free Software Foundation, either version 3 of the License, or
  12 (at your option) any later version.
  13
  14 SXEmacs is distributed in the hope that it will be useful,
  15 but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 GNU General Public License for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with this program.  If not, see <http://www.gnu.org/licenses/>. */
  21
  22
  23 #include <config.h>
  24 #include <limits.h>
  25 #include <math.h>
  26 #include "lisp.h"
  27 #include "sysproc.h"    /* For qxe_getpid */
  28
  29 #include "ent-quatern.h"
  30
  31 quatern ent_scratch_quatern;
  32 Lisp_Object Qquatern;
  33 static ase_nullary_operation_f Qent_quatern_zero, Qent_quatern_one;
  34
  35 \f
  36 static void
  37 quatern_print(Lisp_Object obj, Lisp_Object printcharfun, int UNUSED(escapeflag))
  38 {
  39         Bufbyte *fstr = quatern_to_string(XQUATERN_DATA(obj), 10);
  40         write_c_string((char*)fstr, printcharfun);
  41         xfree(fstr);
  42         fstr = (Bufbyte *)NULL;
  43         return;
  44 }
  45
  46 static int
  47 quatern_equal(Lisp_Object obj1, Lisp_Object obj2, int UNUSED(depth))
  48 {
  49         return quatern_eql(XQUATERN_DATA(obj1), XQUATERN_DATA(obj2));
  50 }
  51
  52 static unsigned long
  53 quatern_hash(Lisp_Object obj, int UNUSED(depth))
  54 {
  55         return quatern_hashcode(XQUATERN_DATA(obj));
  56 }
  57
  58 static Lisp_Object
  59 quatern_mark(Lisp_Object UNUSED(obj))
  60 {
  61         return Qnil;
  62 }
  63
  64 static void
  65 quatern_finalise(void *unused, int for_disksave)
  66 {
  67         if (for_disksave) {
  68                 signal_simple_error(
  69                         "Can't dump an emacs containing "
  70                         "quaternionic objects", Qt);
  71         }
  72 }
  73
  74 static const struct lrecord_description quatern_description[] = {
  75         { XD_OPAQUE_DATA_PTR, offsetof(Lisp_Quatern, data) },
  76         { XD_END }
  77 };
  78
  79 DEFINE_BASIC_LRECORD_IMPLEMENTATION("quatern", quatern,
  80                                     quatern_mark, quatern_print,
  81                                     quatern_finalise,
  82                                     quatern_equal, quatern_hash,
  83                                     quatern_description, Lisp_Quatern);
  84
  85 \f
  86 /* basic functions */
  87 void quatern_init(quatern g)
  88 {
  89         bigz_init(quatern_z(g));
  90         bigz_init(quatern_i(g));
  91         bigz_init(quatern_j(g));
  92         bigz_init(quatern_k(g));
  93 }
  94
  95 void quatern_fini(quatern g)
  96 {
  97         bigz_fini(quatern_z(g));
  98         bigz_fini(quatern_i(g));
  99         bigz_fini(quatern_j(g));
 100         bigz_fini(quatern_k(g));
 101 }
 102
 103 unsigned long quatern_hashcode(quatern g)
 104 {
 105         return (bigz_hashcode(quatern_z(g)) ^
 106                 bigz_hashcode(quatern_i(g)) ^
 107                 bigz_hashcode(quatern_j(g)) ^
 108                 bigz_hashcode(quatern_k(g)));
 109 }
 110
 111 Bufbyte *quatern_to_string(quatern g, int base)
 112 {
 113         Bufbyte *z_str, *i_str, *j_str, *k_str;
 114         int z_len, i_len, j_len, k_len;
 115         int sign_i, sign_j, sign_k, neg_i, neg_j, neg_k;
 116
 117         z_str = (Bufbyte*)bigz_to_string(quatern_z(g), base);
 118         i_str = (Bufbyte*)bigz_to_string(quatern_i(g), base);
 119         j_str = (Bufbyte*)bigz_to_string(quatern_j(g), base);
 120         k_str = (Bufbyte*)bigz_to_string(quatern_k(g), base);
 121
 122         z_len = strlen((char*)z_str);
 123         i_len = strlen((char*)i_str);
 124         j_len = strlen((char*)j_str);
 125         k_len = strlen((char*)k_str);
 126
 127         sign_i = bigz_sign(quatern_i(g));
 128         sign_j = bigz_sign(quatern_j(g));
 129         sign_k = bigz_sign(quatern_k(g));
 130         neg_i = (sign_i >= 0) ? 1 : 0;
 131         neg_j = (sign_j >= 0) ? 1 : 0;
 132         neg_k = (sign_k >= 0) ? 1 : 0;
 133
 134         /* now append the imaginary string */
 135         XREALLOC_ARRAY(z_str, Bufbyte, z_len +
 136                        neg_i + i_len +
 137                        neg_j + j_len +
 138                        neg_k + k_len + 4);
 139         if (neg_i)
 140                 z_str[z_len] = '+';
 141         if (neg_j)
 142                 z_str[z_len+neg_i+i_len+1] = '+';
 143         if (neg_k)
 144                 z_str[z_len+neg_i+i_len+1+neg_j+j_len+1] = '+';
 145         memmove(&z_str[z_len + neg_i],
 146                 &i_str[0],
 147                 i_len);
 148         memmove(&z_str[z_len + neg_i+i_len+1 + neg_j],
 149                 &j_str[0],
 150                 j_len);
 151         memmove(&z_str[z_len + neg_i+i_len+1 + neg_j+j_len+1 + neg_k],
 152                 &k_str[0],
 153                 k_len);
 154         z_str[z_len+neg_i+i_len] = 'i';
 155         z_str[z_len+neg_i+i_len+1+neg_j+j_len] = 'j';
 156         z_str[z_len+neg_i+i_len+1+neg_j+j_len+1+neg_k+k_len] = 'k';
 157         z_str[z_len+neg_i+i_len+1+neg_j+j_len+1+neg_k+k_len+1] = '\0';
 158         free(i_str);
 159
 160         return z_str;
 161 }
 162
 163 /***** Quatern: converting assignments *****/
 164 void quatern_set(quatern g1,quatern g2)
 165 {
 166         bigz_set(quatern_z(g1), quatern_z(g2));
 167         bigz_set(quatern_i(g1), quatern_i(g2));
 168         bigz_set(quatern_j(g1), quatern_j(g2));
 169         bigz_set(quatern_k(g1), quatern_k(g2));
 170 }
 171
 172 void quatern_set_long(quatern g, long l)
 173 {
 174         bigz_set_long(quatern_z(g), l);
 175         bigz_set_long(quatern_i(g), 0L);
 176         bigz_set_long(quatern_j(g), 0L);
 177         bigz_set_long(quatern_k(g), 0L);
 178 }
 179
 180 void quatern_set_long_long_long_long(
 181         quatern g, long l1, long l2, long l3, long l4)
 182 {
 183         bigz_set_long(quatern_z(g), l1);
 184         bigz_set_long(quatern_i(g), l2);
 185         bigz_set_long(quatern_j(g), l3);
 186         bigz_set_long(quatern_k(g), l4);
 187 }
 188
 189 void quatern_set_ulong(quatern g, unsigned long ul)
 190 {
 191         bigz_set_ulong(quatern_z(g), ul);
 192         bigz_set_ulong(quatern_i(g), 0UL);
 193         bigz_set_ulong(quatern_j(g), 0UL);
 194         bigz_set_ulong(quatern_k(g), 0UL);
 195 }
 196
 197 void quatern_set_ulong_ulong_ulong_ulong(
 198         quatern g, unsigned long ul1, unsigned long ul2,
 199         unsigned long ul3, unsigned long ul4)
 200 {
 201         bigz_set_ulong(quatern_z(g), ul1);
 202         bigz_set_ulong(quatern_i(g), ul2);
 203         bigz_set_ulong(quatern_j(g), ul3);
 204         bigz_set_ulong(quatern_k(g), ul4);
 205 }
 206
 207 void quatern_set_bigz(quatern g, bigz z)
 208 {
 209         bigz_set(quatern_z(g), z);
 210         bigz_set_long(quatern_i(g), 0L);
 211         bigz_set_long(quatern_j(g), 0L);
 212         bigz_set_long(quatern_k(g), 0L);
 213 }
 214
 215 void quatern_set_bigz_bigz_bigz_bigz(
 216         quatern g, bigz z1, bigz z2, bigz z3, bigz z4)
 217 {
 218         bigz_set(quatern_z(g), z1);
 219         bigz_set(quatern_i(g), z2);
 220         bigz_set(quatern_j(g), z3);
 221         bigz_set(quatern_k(g), z4);
 222 }
 223
 224 /* void bigc_set_quatern(bigc c, quatern g)
 225  * {
 226  *      bigc_set_bigfr_bigfr(quatern_z(g), z1);
 227  * }
 228  */
 229
 230 /***** Quatern: comparisons *****/
 231 int quatern_eql(quatern g1, quatern g2)
 232 {
 233         return ((bigz_eql(quatern_z(g1), quatern_z(g2))) &&
 234                 (bigz_eql(quatern_i(g1), quatern_i(g2))) &&
 235                 (bigz_eql(quatern_j(g1), quatern_j(g2))) &&
 236                 (bigz_eql(quatern_k(g1), quatern_k(g2))));
 237 }
 238
 239 /***** Quatern: arithmetic *****/
 240 #ifdef HAVE_MPFR
 241 void quatern_abs(bigfr res, quatern g)
 242 {
 243 /* NOT DONE */
 244         /* the absolute archimedean valuation of a+bi is defined as:
 245          * (a^2 + b^2 + c^2 + d^2)^(1/2)
 246          */
 247         bigz accu1, accu2, bz;
 248         bigz_init(accu1);
 249         bigz_init(accu2);
 250         bigz_init(bz);
 251
 252         bigz_mul(accu1, quatern_z(g), quatern_z(g));
 253         bigz_mul(accu2, quatern_i(g), quatern_i(g));
 254         bigz_add(bz, accu1, accu2);
 255
 256         bigfr_set_bigz(res, bz);
 257         bigfr_sqrt(res, res);
 258
 259         bigz_fini(accu1);
 260         bigz_fini(accu2);
 261         bigz_fini(bz);
 262 }
 263 #endif
 264
 265 void quatern_norm(bigz res, quatern g)
 266 {
 267         /* norm is the product of g and conj(g) */
 268         quatern_conj(ent_scratch_quatern, g);
 269         quatern_mul(ent_scratch_quatern, g, ent_scratch_quatern);
 270         bigz_set(res, quatern_z(ent_scratch_quatern));
 271 }
 272
 273 void quatern_neg(quatern res, quatern g)
 274 {
 275         /* negation is defined point-wise */
 276         bigz_neg(quatern_z(res), quatern_z(g));
 277         bigz_neg(quatern_i(res), quatern_i(g));
 278         bigz_neg(quatern_j(res), quatern_j(g));
 279         bigz_neg(quatern_k(res), quatern_k(g));
 280 }
 281
 282 void quatern_conj(quatern res, quatern g)
 283 {
 284         bigz_set(quatern_z(res), quatern_z(g));
 285         bigz_neg(quatern_i(res), quatern_i(g));
 286         bigz_neg(quatern_j(res), quatern_j(g));
 287         bigz_neg(quatern_k(res), quatern_k(g));
 288 }
 289
 290 void quatern_add(quatern res, quatern g1, quatern g2)
 291 {
 292         quatern accu;
 293         quatern_init(accu);
 294
 295         /* addition is defined point-wise */
 296         bigz_add(quatern_z(accu), quatern_z(g1), quatern_z(g2));
 297         bigz_add(quatern_i(accu), quatern_i(g1), quatern_i(g2));
 298         bigz_add(quatern_j(accu), quatern_j(g1), quatern_j(g2));
 299         bigz_add(quatern_k(accu), quatern_k(g1), quatern_k(g2));
 300
 301         quatern_set(res, accu);
 302         quatern_fini(accu);
 303 }
 304
 305 void quatern_sub(quatern res, quatern g1, quatern g2)
 306 {
 307         quatern accu;
 308         quatern_init(accu);
 309
 310         /* subtraction is defined point-wise */
 311         bigz_sub(quatern_z(accu), quatern_z(g1), quatern_z(g2));
 312         bigz_sub(quatern_i(accu), quatern_i(g1), quatern_i(g2));
 313         bigz_sub(quatern_j(accu), quatern_j(g1), quatern_j(g2));
 314         bigz_sub(quatern_k(accu), quatern_k(g1), quatern_k(g2));
 315
 316         quatern_set(res, accu);
 317         quatern_fini(accu);
 318 }
 319
 320 void quatern_mul(quatern res, quatern g1, quatern g2)
 321 {
 322         /* multiplication is defined as:
 323          * (a + bi + cj + dk)*(e + fi + gj + hk) = <too complex ;)>
 324          */
 325         bigz accu1, accu2, accu3, accu4;
 326         quatern accu;
 327         bigz_init(accu1);
 328         bigz_init(accu2);
 329         bigz_init(accu3);
 330         bigz_init(accu4);
 331         quatern_init(accu);
 332
 333         /* compute the integral part */
 334         bigz_mul(accu1, quatern_z(g1), quatern_z(g2));
 335         bigz_mul(accu2, quatern_i(g1), quatern_i(g2));
 336         bigz_mul(accu3, quatern_j(g1), quatern_j(g2));
 337         bigz_mul(accu4, quatern_k(g1), quatern_k(g2));
 338
 339         bigz_sub(accu1, accu1, accu2);
 340         bigz_sub(accu1, accu1, accu3);
 341         bigz_sub(accu1, accu1, accu4);
 342         bigz_set(quatern_z(accu), accu1);
 343
 344         /* compute the i part */
 345         bigz_mul(accu1, quatern_z(g1), quatern_i(g2));
 346         bigz_mul(accu2, quatern_i(g1), quatern_z(g2));
 347         bigz_mul(accu3, quatern_j(g1), quatern_k(g2));
 348         bigz_mul(accu4, quatern_k(g1), quatern_j(g2));
 349
 350         bigz_add(accu1, accu1, accu2);
 351         bigz_add(accu1, accu1, accu3);
 352         bigz_sub(accu1, accu1, accu4);
 353         bigz_set(quatern_i(accu), accu1);
 354
 355         /* compute the j part */
 356         bigz_mul(accu1, quatern_z(g1), quatern_j(g2));
 357         bigz_mul(accu2, quatern_i(g1), quatern_k(g2));
 358         bigz_mul(accu3, quatern_j(g1), quatern_z(g2));
 359         bigz_mul(accu4, quatern_k(g1), quatern_i(g2));
 360
 361         bigz_sub(accu1, accu1, accu2);
 362         bigz_add(accu1, accu1, accu3);
 363         bigz_add(accu1, accu1, accu4);
 364         bigz_set(quatern_j(accu), accu1);
 365
 366         /* compute the k part */
 367         bigz_mul(accu1, quatern_z(g1), quatern_k(g2));
 368         bigz_mul(accu2, quatern_i(g1), quatern_j(g2));
 369         bigz_mul(accu3, quatern_j(g1), quatern_i(g2));
 370         bigz_mul(accu4, quatern_k(g1), quatern_z(g2));
 371
 372         bigz_add(accu1, accu1, accu2);
 373         bigz_sub(accu1, accu1, accu3);
 374         bigz_add(accu1, accu1, accu4);
 375         bigz_set(quatern_k(accu), accu1);
 376
 377         quatern_set(res, accu);
 378
 379         quatern_fini(accu);
 380         bigz_fini(accu1);
 381         bigz_fini(accu2);
 382         bigz_fini(accu3);
 383         bigz_fini(accu4);
 384 }
 385
 386 void quatern_div(quatern res, quatern g1, quatern g2)
 387 {
 388         /* division is defined as:
 389          * (a + bi + cj + dk) div (a'+b'i+c'j+d'k) =
 390          * ((a+bi+cj+dk)*conj(a'+b'i+c'j+d'k)) div (a'^2 + b^2 + c^2 + d^2)
 391          */
 392         /* frob the norm */
 393         quatern_norm(ent_scratch_bigz, g2);
 394
 395         /* do normal multiplication with conjugate of g2 */
 396         quatern_conj(ent_scratch_quatern, g2);
 397         quatern_mul(res, g1, ent_scratch_quatern);
 398
 399         /* now divide (g1*conj(g2)) by |g2| (point-wise) */
 400         bigz_div(quatern_z(res), quatern_z(res), ent_scratch_bigz);
 401         bigz_div(quatern_i(res), quatern_i(res), ent_scratch_bigz);
 402         bigz_div(quatern_j(res), quatern_j(res), ent_scratch_bigz);
 403         bigz_div(quatern_k(res), quatern_k(res), ent_scratch_bigz);
 404 }
 405
 406 void quatern_mod(quatern res, quatern g1, quatern g2)
 407 {
 408 /* NOT DONE */
 409         /* the modulo relation is defined as:
 410          * (a + bi) mod (c + di) ~
 411          * (a+bi) - ((a+bi) div (c-di)) * (c+di)
 412          */
 413         quatern accug;
 414         quatern_init(accug);
 415
 416         /* do normal division */
 417         quatern_div(accug, g1, g2);
 418
 419         /* now re-multiply g2 */
 420         quatern_mul(accug, accug, g2);
 421
 422         /* and find the difference */
 423         quatern_sub(res, g1, accug);
 424
 425         quatern_fini(accug);
 426 }
 427
 428 void quatern_pow(quatern res, quatern g1, unsigned long g2)
 429 {
 430 #if defined(HAVE_MPZ) && defined(WITH_GMP)
 431 /* NOT DONE */
 432         unsigned long i;
 433         bigz bin, resintg, resimag, tmpbz1, tmpbz2, tmpbz3, intg, imag;
 434
 435         bigz_init(bin);
 436         bigz_init(resintg);
 437         bigz_init(resimag);
 438         bigz_init(intg);
 439         bigz_init(imag);
 440         bigz_init(tmpbz1);
 441         bigz_init(tmpbz2);
 442         bigz_init(tmpbz3);
 443
 444         bigz_set_long(resintg, 0L);
 445         bigz_set_long(resimag, 0L);
 446
 447         bigz_set(intg, quatern_z(g1));
 448         bigz_set(imag, quatern_i(g1));
 449
 450         /* we compute using the binomial coefficients */
 451         for (i=0; i<=g2; i++) {
 452                 mpz_bin_uiui(bin, g2, i);
 453                 if (i % 2 == 0) {
 454                         /* real part changes */
 455                         bigz_pow(tmpbz1, intg, g2-i);
 456                         bigz_pow(tmpbz2, imag, i);
 457                         bigz_mul(tmpbz3, tmpbz1, tmpbz2);
 458                         bigz_mul(bin, bin, tmpbz3);
 459                         if (i % 4 == 0) {
 460                                 bigz_add(resintg, resintg, bin);
 461                         } else if (i % 4 == 2) {
 462                                 bigz_sub(resintg, resintg, bin);
 463                         }
 464                 } else {
 465                         /* imag part changes */
 466                         bigz_pow(tmpbz1, intg, g2-i);
 467                         bigz_pow(tmpbz2, imag, i);
 468                         bigz_mul(tmpbz3, tmpbz1, tmpbz2);
 469                         bigz_mul(bin, bin, tmpbz3);
 470                         if (i % 4 == 1) {
 471                                 bigz_add(resimag, resimag, bin);
 472                         } else if (i % 4 == 3) {
 473                                 bigz_sub(resimag, resimag, bin);
 474                         }
 475                 }
 476         }
 477
 478         quatern_set_bigz_bigz_bigz_bigz(res, resintg, resimag, resimag, resimag);
 479
 480         bigz_fini(bin);
 481         bigz_fini(intg);
 482         bigz_fini(imag);
 483         bigz_init(resintg);
 484         bigz_init(resimag);
 485         bigz_fini(tmpbz1);
 486         bigz_fini(tmpbz2);
 487         bigz_fini(tmpbz3);
 488 #else
 489         quatern_set_long_long(res, 0L, 0L);
 490 #endif
 491 }
 492
 493 \f
 494
 495 #define Z_INT 1
 496 #define I_UNARY_SYMBOL 2
 497 #define I_INT 4
 498 #define I_CHAR 8
 499 #define J_UNARY_SYMBOL 16
 500 #define J_INT 32
 501 #define J_CHAR 64
 502 #define K_UNARY_SYMBOL 128
 503 #define K_INT 256
 504 #define K_CHAR 512
 505
 506 int isquatern_string (const char *cp)
 507 {
 508         int state;
 509         const Bufbyte *ucp = (const Bufbyte *)cp;
 510
 511
 512         /* parse the z-part */
 513         state = 0;
 514         if (*ucp == '+' || *ucp == '-')
 515                 ucp++;
 516
 517         if (*ucp >= '0' && *ucp <= '9') {
 518                 state |= Z_INT;
 519                 while (*ucp >= '0' && *ucp <= '9')
 520                         ucp++;
 521         }
 522
 523         /* check if we had a int number until here */
 524         if (!(state == (Z_INT)))
 525                 return 0;
 526
 527         /* now parse i-part */
 528         state = 0;
 529         if (*ucp == '+' || *ucp == '-') {
 530                 state |= I_UNARY_SYMBOL;
 531                 ucp++;
 532         }
 533
 534         if (*ucp >= '0' && *ucp <= '9') {
 535                 state |= I_INT;
 536                 while (*ucp >= '0' && *ucp <= '9')
 537                         ucp++;
 538         }
 539         if (*ucp == 'i' || *ucp == 'I') {
 540                 state |= I_CHAR;
 541                 ucp++;
 542         }
 543         /* check if we had a quatern number until here */
 544         if (!(state == (I_UNARY_SYMBOL | I_INT | I_CHAR) ||
 545               state == (I_UNARY_SYMBOL | I_CHAR)))
 546                 return 0;
 547
 548         /* now parse j-part */
 549         state = 0;
 550         if (*ucp == '+' || *ucp == '-') {
 551                 state |= J_UNARY_SYMBOL;
 552                 ucp++;
 553         }
 554
 555         if (*ucp >= '0' && *ucp <= '9') {
 556                 state |= J_INT;
 557                 while (*ucp >= '0' && *ucp <= '9')
 558                         ucp++;
 559         }
 560         if (*ucp == 'j' || *ucp == 'J') {
 561                 state |= J_CHAR;
 562                 ucp++;
 563         }
 564         /* check if we had a quatern number until here */
 565         if (!(state == (J_UNARY_SYMBOL | J_INT | J_CHAR) ||
 566               state == (J_UNARY_SYMBOL | J_CHAR)))
 567                 return 0;
 568
 569         /* now parse k-part */
 570         state = 0;
 571         if (*ucp == '+' || *ucp == '-') {
 572                 state |= K_UNARY_SYMBOL;
 573                 ucp++;
 574         }
 575
 576         if (*ucp >= '0' && *ucp <= '9') {
 577                 state |= K_INT;
 578                 while (*ucp >= '0' && *ucp <= '9')
 579                         ucp++;
 580         }
 581         if (*ucp == 'k' || *ucp == 'K') {
 582                 state |= K_CHAR;
 583                 ucp++;
 584         }
 585         /* check if we had a quatern number until here */
 586         if (!(state == (K_UNARY_SYMBOL | K_INT | K_CHAR) ||
 587               state == (K_UNARY_SYMBOL | K_CHAR)))
 588                 return 0;
 589
 590         return (((*ucp == 0) || (*ucp == ' ') || (*ucp == '\t') ||
 591                  (*ucp == '\n') || (*ucp == '\r') || (*ucp == '\f')));
 592 }
 593
 594 Lisp_Object read_quatern_string(char *cp)
 595 {
 596         bigz bz_z, bz_i, bz_j, bz_k;
 597         int sign;
 598         Lisp_Object result;
 599         Bufbyte *end;
 600         Bufbyte tmp;
 601
 602         bigz_init(bz_z);
 603         bigz_init(bz_i);
 604         bigz_init(bz_j);
 605         bigz_init(bz_k);
 606
 607         /* MPZ bigz_set_string has no effect
 608          * with initial + sign */
 609         if (*cp == '+')
 610                 cp++;
 611
 612         end = (Bufbyte *)cp;
 613
 614         if (*cp == '-') {
 615                 /* jump over a leading minus */
 616                 cp++;
 617         }
 618
 619         while ((*cp >= '0' && *cp <= '9'))
 620                 cp++;
 621
 622         /* MPZ cannot read numbers with characters after them.
 623          * See limitations below in convert GMP-MPZ strings
 624          */
 625         tmp = (Bufbyte)*cp;
 626         *cp = '\0';
 627         bigz_set_string(bz_z, (char *)end, 0);
 628         *cp = tmp;
 629
 630         /* read the i-part */
 631         sign = 0;
 632         if (*cp == '+') {
 633                 cp++;
 634                 sign = 1;
 635         }
 636         if (*cp == '-') {
 637                 cp++;
 638                 sign = -1;
 639         }
 640         if ((*cp == 'i' || *cp == 'I') && (sign == 1)) {
 641                 /* expand +i to +1i */
 642                 bigz_set_long(bz_i, 1L);
 643         } else if ((*cp == 'i' || *cp == 'I') && (sign == -1)) {
 644                 /* expand -i to -1i */
 645                 bigz_set_long(bz_i, -1L);
 646         } else {
 647                 end = (Bufbyte*)cp;
 648                 if (sign == -1)
 649                         end--;
 650                 while ((*cp >= '0' && *cp <= '9'))
 651                         cp++;
 652                 tmp = (Bufbyte)*cp;
 653                 *cp = '\0';
 654                 bigz_set_string(bz_i, (char *)end, 0);
 655                 *cp = tmp;
 656         }
 657         /* read over i */
 658         if (*cp == 'i' || *cp == 'I')
 659                 cp++;
 660
 661         /* read the j-part */
 662         sign = 0;
 663         if (*cp == '+') {
 664                 cp++;
 665                 sign = 1;
 666         }
 667         if (*cp == '-') {
 668                 cp++;
 669                 sign = -1;
 670         }
 671         if ((*cp == 'j' || *cp == 'J') && (sign == 1)) {
 672                 /* expand +j to +1j */
 673                 bigz_set_long(bz_j, 1L);
 674         } else if ((*cp == 'j' || *cp == 'J') && (sign == -1)) {
 675                 /* expand -j to -1j */
 676                 bigz_set_long(bz_j, -1L);
 677         } else {
 678                 end = (Bufbyte*)cp;
 679                 if (sign == -1)
 680                         end--;
 681                 while ((*cp >= '0' && *cp <= '9'))
 682                         cp++;
 683                 tmp = (Bufbyte)*cp;
 684                 *cp = '\0';
 685                 bigz_set_string(bz_j, (char *)end, 0);
 686                 *cp = tmp;
 687         }
 688         /* read over j */
 689         if (*cp == 'j' || *cp == 'J')
 690                 cp++;
 691
 692         /* read the k-part */
 693         sign = 0;
 694         if (*cp == '+') {
 695                 cp++;
 696                 sign = 1;
 697         }
 698         if (*cp == '-') {
 699                 cp++;
 700                 sign = -1;
 701         }
 702         if ((*cp == 'k' || *cp == 'K') && (sign == 1)) {
 703                 /* expand +k to +1k */
 704                 bigz_set_long(bz_k, 1L);
 705         } else if ((*cp == 'k' || *cp == 'K') && (sign == -1)) {
 706                 /* expand -k to -1k */
 707                 bigz_set_long(bz_k, -1L);
 708         } else {
 709                 end = (Bufbyte*)cp;
 710                 if (sign == -1)
 711                         end--;
 712                 while ((*cp >= '0' && *cp <= '9'))
 713                         cp++;
 714                 tmp = (Bufbyte)*cp;
 715                 *cp = '\0';
 716                 bigz_set_string(bz_k, (char *)end, 0);
 717                 *cp = tmp;
 718         }
 719         /* read over k */
 720         if (*cp == 'k' || *cp == 'K')
 721                 cp++;
 722
 723         result = make_quatern_bz(bz_z, bz_i, bz_j, bz_k);
 724
 725         bigz_fini(bz_z);
 726         bigz_fini(bz_i);
 727         bigz_fini(bz_j);
 728         bigz_fini(bz_k);
 729         return result;
 730 }
 731 \f
 732 /* quatern ops */
 733 static inline int
 734 ent_quatern_zerop(Lisp_Object o)
 735 {
 736         return (bigz_sign(quatern_z(XQUATERN_DATA(o))) == 0 &&
 737                 bigz_sign(quatern_i(XQUATERN_DATA(o))) == 0 &&
 738                 bigz_sign(quatern_j(XQUATERN_DATA(o))) == 0 &&
 739                 bigz_sign(quatern_k(XQUATERN_DATA(o))) == 0);
 740 }
 741
 742 static inline int
 743 ent_quatern_onep(Lisp_Object o)
 744 {
 745         return ((bigz_fits_long_p(quatern_z(XQUATERN_DATA(o))) &&
 746                  bigz_to_long(quatern_z(XQUATERN_DATA(o))) == 1L) &&
 747                 bigz_sign(quatern_i(XQUATERN_DATA(o))) == 0 &&
 748                 bigz_sign(quatern_j(XQUATERN_DATA(o))) == 0 &&
 749                 bigz_sign(quatern_k(XQUATERN_DATA(o))) == 0);
 750 }
 751
 752 static inline int
 753 ent_quatern_unitp(Lisp_Object o)
 754 {
 755         return (!ent_quatern_zerop(o) &&
 756                 (bigz_fits_long_p(quatern_z(XQUATERN_DATA(o))) &&
 757                  (bigz_to_long(quatern_z(XQUATERN_DATA(o))) == 0L ||
 758                   bigz_to_long(quatern_z(XQUATERN_DATA(o))) == 1L ||
 759                   bigz_to_long(quatern_z(XQUATERN_DATA(o))) == -1L)) &&
 760                 (bigz_fits_long_p(quatern_i(XQUATERN_DATA(o))) &&
 761                  (bigz_to_long(quatern_i(XQUATERN_DATA(o))) == 0L ||
 762                   bigz_to_long(quatern_i(XQUATERN_DATA(o))) == 1L ||
 763                   bigz_to_long(quatern_i(XQUATERN_DATA(o))) == -1L)) &&
 764                 (bigz_fits_long_p(quatern_j(XQUATERN_DATA(o))) &&
 765                  (bigz_to_long(quatern_j(XQUATERN_DATA(o))) == 0L ||
 766                   bigz_to_long(quatern_j(XQUATERN_DATA(o))) == 1L ||
 767                   bigz_to_long(quatern_j(XQUATERN_DATA(o))) == -1L)) &&
 768                 (bigz_fits_long_p(quatern_k(XQUATERN_DATA(o))) &&
 769                  (bigz_to_long(quatern_k(XQUATERN_DATA(o))) == 0L ||
 770                   bigz_to_long(quatern_k(XQUATERN_DATA(o))) == 1L ||
 771                   bigz_to_long(quatern_k(XQUATERN_DATA(o))) == -1L)));
 772 }
 773
 774 static inline Lisp_Object
 775 ent_sum_QUATERN_T(Lisp_Object l, Lisp_Object r)
 776 {
 777         quatern_add(ent_scratch_quatern, XQUATERN_DATA(l), XQUATERN_DATA(r));
 778         return make_quatern_qu(ent_scratch_quatern);
 779 }
 780 static inline Lisp_Object
 781 ent_sum_QUATERN_T_INT_T(Lisp_Object l, Lisp_Object r)
 782 {
 783         quatern_set_long(ent_scratch_quatern, ent_int(r));
 784         quatern_add(ent_scratch_quatern, XQUATERN_DATA(l), ent_scratch_quatern);
 785         return make_quatern_qu(ent_scratch_quatern);
 786 }
 787 static inline Lisp_Object
 788 ent_sum_INT_T_QUATERN_T(Lisp_Object l, Lisp_Object r)
 789 {
 790         quatern_set_long(ent_scratch_quatern, ent_int(l));
 791         quatern_add(ent_scratch_quatern, ent_scratch_quatern, XQUATERN_DATA(r));
 792         return make_quatern_qu(ent_scratch_quatern);
 793 }
 794 static inline Lisp_Object
 795 ent_sum_QUATERN_T_BIGZ_T(Lisp_Object l, Lisp_Object r)
 796 {
 797         quatern_set_bigz(ent_scratch_quatern, XBIGZ_DATA(r));
 798         quatern_add(ent_scratch_quatern, XQUATERN_DATA(l), ent_scratch_quatern);
 799         return make_quatern_qu(ent_scratch_quatern);
 800 }
 801 static inline Lisp_Object
 802 ent_sum_BIGZ_T_QUATERN_T(Lisp_Object l, Lisp_Object r)
 803 {
 804         quatern_set_bigz(ent_scratch_quatern, XBIGZ_DATA(l));
 805         quatern_add(ent_scratch_quatern, ent_scratch_quatern, XQUATERN_DATA(r));
 806         return make_quatern_qu(ent_scratch_quatern);
 807 }
 808
 809 static inline Lisp_Object
 810 ent_diff_QUATERN_T(Lisp_Object l, Lisp_Object r)
 811 {
 812         quatern_sub(ent_scratch_quatern, XQUATERN_DATA(l), XQUATERN_DATA(r));
 813         return make_quatern_qu(ent_scratch_quatern);
 814 }
 815 static inline Lisp_Object
 816 ent_diff_QUATERN_T_INT_T(Lisp_Object l, Lisp_Object r)
 817 {
 818         quatern_set_long(ent_scratch_quatern, ent_int(r));
 819         quatern_sub(ent_scratch_quatern, XQUATERN_DATA(l), ent_scratch_quatern);
 820         return make_quatern_qu(ent_scratch_quatern);
 821 }
 822 static inline Lisp_Object
 823 ent_diff_INT_T_QUATERN_T(Lisp_Object l, Lisp_Object r)
 824 {
 825         quatern_set_long(ent_scratch_quatern, ent_int(l));
 826         quatern_sub(ent_scratch_quatern, ent_scratch_quatern, XQUATERN_DATA(r));
 827         return make_quatern_qu(ent_scratch_quatern);
 828 }
 829 static inline Lisp_Object
 830 ent_diff_QUATERN_T_BIGZ_T(Lisp_Object l, Lisp_Object r)
 831 {
 832         quatern_set_bigz(ent_scratch_quatern, XBIGZ_DATA(r));
 833         quatern_sub(ent_scratch_quatern, XQUATERN_DATA(l), ent_scratch_quatern);
 834         return make_quatern_qu(ent_scratch_quatern);
 835 }
 836 static inline Lisp_Object
 837 ent_diff_BIGZ_T_QUATERN_T(Lisp_Object l, Lisp_Object r)
 838 {
 839         quatern_set_bigz(ent_scratch_quatern, XBIGZ_DATA(l));
 840         quatern_sub(ent_scratch_quatern, ent_scratch_quatern, XQUATERN_DATA(r));
 841         return make_quatern_qu(ent_scratch_quatern);
 842 }
 843
 844 static inline Lisp_Object
 845 ent_neg_QUATERN_T(Lisp_Object l)
 846 {
 847         quatern_neg(ent_scratch_quatern, XQUATERN_DATA(l));
 848         return make_quatern_qu(ent_scratch_quatern);
 849 }
 850 static inline Lisp_Object
 851 ent_prod_QUATERN_T(Lisp_Object l, Lisp_Object r)
 852 {
 853         quatern_mul(ent_scratch_quatern, XQUATERN_DATA(l), XQUATERN_DATA(r));
 854         return make_quatern_qu(ent_scratch_quatern);
 855 }
 856 static inline Lisp_Object
 857 ent_prod_QUATERN_T_INT_T(Lisp_Object l, Lisp_Object r)
 858 {
 859         quatern_set_long(ent_scratch_quatern, ent_int(r));
 860         quatern_mul(ent_scratch_quatern, XQUATERN_DATA(l), XQUATERN_DATA(r));
 861         return make_quatern_qu(ent_scratch_quatern);
 862 }
 863 static inline Lisp_Object
 864 ent_prod_INT_T_QUATERN_T(Lisp_Object l, Lisp_Object r)
 865 {
 866         quatern_set_long(ent_scratch_quatern, ent_int(l));
 867         quatern_mul(ent_scratch_quatern, XQUATERN_DATA(l), XQUATERN_DATA(r));
 868         return make_quatern_qu(ent_scratch_quatern);
 869 }
 870 static inline Lisp_Object
 871 ent_prod_QUATERN_T_BIGZ_T(Lisp_Object l, Lisp_Object r)
 872 {
 873         quatern_set_bigz(ent_scratch_quatern, XBIGZ_DATA(r));
 874         quatern_mul(ent_scratch_quatern, XQUATERN_DATA(l), XQUATERN_DATA(r));
 875         return make_quatern_qu(ent_scratch_quatern);
 876 }
 877 static inline Lisp_Object
 878 ent_prod_BIGZ_T_QUATERN_T(Lisp_Object l, Lisp_Object r)
 879 {
 880         quatern_set_bigz(ent_scratch_quatern, XBIGZ_DATA(l));
 881         quatern_mul(ent_scratch_quatern, XQUATERN_DATA(l), XQUATERN_DATA(r));
 882         return make_quatern_qu(ent_scratch_quatern);
 883 }
 884
 885 static inline Lisp_Object
 886 ent_div_QUATERN_T(Lisp_Object l, Lisp_Object r)
 887 {
 888         if (ent_quatern_zerop(r)) {
 889                 if (!ent_quatern_zerop(l)) {
 890                         return make_indef(COMPLEX_INFINITY);
 891                 } else {
 892                         return make_indef(NOT_A_NUMBER);
 893                 }
 894         }
 895         quatern_div(ent_scratch_quatern, XQUATERN_DATA(l), XQUATERN_DATA(r));
 896         return make_quatern_qu(ent_scratch_quatern);
 897 }
 898 #if defined(HAVE_MPC) && 0
 899 /* this does not work yet, our quaternions are the integral ring of the division
 900    algebra usually known as quaternions
 901 */
 902 static inline Lisp_Object
 903 ent_quo_QUATERN_T(Lisp_Object l, Lisp_Object r)
 904 {
 905         if (ent_quatern_zerop(r)) {
 906                 if (!ent_quatern_zerop(l)) {
 907                         return make_indef(COMPLEX_INFINITY);
 908                 } else {
 909                         return make_indef(NOT_A_NUMBER);
 910                 }
 911         }
 912         bigc_set_prec(ent_scratch_bigc, internal_get_precision(Qnil));
 913         bigc_div(ent_scratch_bigc,
 914                  XBIGC_DATA(Fcoerce_number(l, Qbigc, Qnil)),
 915                  XBIGC_DATA(Fcoerce_number(r, Qbigc, Qnil)));
 916         return make_bigc_bc(ent_scratch_bigc);
 917 }
 918 #endif
 919 static inline Lisp_Object
 920 ent_inv_QUATERN_T(Lisp_Object r)
 921 {
 922         if (ent_quatern_zerop(r)) {
 923                 return make_indef(COMPLEX_INFINITY);
 924         }
 925         quatern_set_long(ent_scratch_quatern, 1L);
 926         quatern_div(ent_scratch_quatern, ent_scratch_quatern, XQUATERN_DATA(r));
 927         return make_quatern_qu(ent_scratch_quatern);
 928 }
 929 static inline Lisp_Object
 930 ent_rem_QUATERN_T(Lisp_Object l, Lisp_Object r)
 931 {
 932         if (ent_quatern_zerop(r)) {
 933                 return Qent_quatern_zero;
 934         }
 935         quatern_mod(ent_scratch_quatern, XQUATERN_DATA(l), XQUATERN_DATA(r));
 936         return make_quatern_qu(ent_scratch_quatern);
 937 }
 938 static inline Lisp_Object
 939 ent_pow_QUATERN_T_integer(Lisp_Object l, Lisp_Object r)
 940 {
 941         unsigned long expo;
 942
 943         if (INTP(r))
 944                 expo = ent_int(r);
 945         else if (BIGZP(r)) {
 946                 if (bigz_fits_ulong_p(XBIGZ_DATA(r)))
 947                         expo = bigz_to_ulong(XBIGZ_DATA(r));
 948                 else
 949                         Fsignal(Qarith_error, r);
 950         } else
 951                 Fsignal(Qdomain_error, r);
 952
 953         quatern_pow(ent_scratch_quatern, XQUATERN_DATA(l), expo);
 954         return make_quatern_qu(ent_scratch_quatern);
 955 }
 956
 957 /* relations */
 958 static inline int
 959 ent_eq_quatern(Lisp_Object l, Lisp_Object r)
 960 {
 961         return (bigz_eql(quatern_z(XQUATERN_DATA(l)),
 962                          quatern_z(XQUATERN_DATA(r))) &&
 963                 bigz_eql(quatern_i(XQUATERN_DATA(l)),
 964                          quatern_i(XQUATERN_DATA(r))) &&
 965                 bigz_eql(quatern_j(XQUATERN_DATA(l)),
 966                          quatern_j(XQUATERN_DATA(r))) &&
 967                 bigz_eql(quatern_k(XQUATERN_DATA(l)),
 968                          quatern_k(XQUATERN_DATA(r))));
 969 }
 970
 971 static inline int
 972 ent_ne_quatern(Lisp_Object l, Lisp_Object r)
 973 {
 974         return (bigz_eql(quatern_z(XQUATERN_DATA(l)),
 975                          quatern_z(XQUATERN_DATA(r))) &&
 976                 bigz_eql(quatern_i(XQUATERN_DATA(l)),
 977                          quatern_i(XQUATERN_DATA(r))) &&
 978                 bigz_eql(quatern_j(XQUATERN_DATA(l)),
 979                          quatern_j(XQUATERN_DATA(r))) &&
 980                 bigz_eql(quatern_k(XQUATERN_DATA(l)),
 981                          quatern_k(XQUATERN_DATA(r))));
 982 }
 983
 984 #if 0
 985 static inline Lisp_Object
 986 ent_vallt_QUATERN_T(Lisp_Object l, Lisp_Object r)
 987 {
 988         bigz b2;
 989         int result;
 990
 991         bigz_init(b2);
 992         quatern_norm(ent_scratch_bigz, XQUATERN_DATA(l));
 993         quatern_norm(b2, XQUATERN_DATA(r));
 994         result = bigz_lt(ent_scratch_bigz, b2);
 995
 996         bigz_fini(b2);
 997         return (result) ? Qt : Qnil;
 998 }
 999 static inline Lisp_Object
1000 ent_valgt_QUATERN_T(Lisp_Object l, Lisp_Object r)
1001 {
1002         bigz b2;
1003         int result;
1004
1005         bigz_init(b2);
1006         quatern_norm(ent_scratch_bigz, XQUATERN_DATA(l));
1007         quatern_norm(b2, XQUATERN_DATA(r));
1008         result = bigz_gt(ent_scratch_bigz, b2);
1009
1010         bigz_fini(b2);
1011         return (result) ? Qt : Qnil;
1012 }
1013 static inline Lisp_Object
1014 ent_valeq_QUATERN_T(Lisp_Object l, Lisp_Object r)
1015 {
1016         bigz b2;
1017         int result;
1018
1019         bigz_init(b2);
1020         quatern_norm(ent_scratch_bigz, XQUATERN_DATA(l));
1021         quatern_norm(b2, XQUATERN_DATA(r));
1022         result = bigz_eql(ent_scratch_bigz, b2);
1023
1024         bigz_fini(b2);
1025         return (result) ? Qt : Qnil;
1026 }
1027 static inline Lisp_Object
1028 ent_valne_QUATERN_T(Lisp_Object l, Lisp_Object r)
1029 {
1030         bigz b2;
1031         int result;
1032
1033         bigz_init(b2);
1034         quatern_norm(ent_scratch_bigz, XQUATERN_DATA(l));
1035         quatern_norm(b2, XQUATERN_DATA(r));
1036         result = bigz_eql(ent_scratch_bigz, b2);
1037
1038         bigz_fini(b2);
1039         return (result) ? Qnil : Qt;
1040 }
1041 #endif
1042
1043 /* lifts */
1044 static inline Lisp_Object
1045 ent_lift_all_QUATERN_T(Lisp_Object number, ent_lift_args_t UNUSED(la))
1046 {
1047         number = ent_lift(number, BIGZ_T, NULL);
1048         bigz_set_long(ent_scratch_bigz, 0L);
1049         return make_quatern_bz(XBIGZ_DATA(number),
1050                                ent_scratch_bigz,
1051                                ent_scratch_bigz,
1052                                ent_scratch_bigz);
1053 }
1054
1055 #ifdef HAVE_MPZ
1056 static Lisp_Object
1057 ent_lift_COMPLEX_QUATERN_T(Lisp_Object number, ent_lift_args_t UNUSED(la))
1058 {
1059         Lisp_Object z, i;
1060
1061         z = Freal_part(number);
1062         i = Fimaginary_part(number);
1063
1064         z = ent_lift(z, BIGZ_T, NULL);
1065         i = ent_lift(i, BIGZ_T, NULL);
1066
1067         bigz_set_long(ent_scratch_bigz, 0L);
1068         return make_quatern_bz(XBIGZ_DATA(z), XBIGZ_DATA(i),
1069                                ent_scratch_bigz,
1070                                ent_scratch_bigz);
1071 }
1072 #endif
1073
1074 \f
1075 static inline void
1076 ent_quatern_nullary_optable_init(void)
1077 {
1078         Qent_quatern_zero = make_quatern(0L, 0L, 0L, 0L);
1079         Qent_quatern_one = make_quatern(1L, 0L, 0L, 0L);
1080         staticpro(&Qent_quatern_zero);
1081         staticpro(&Qent_quatern_one);
1082
1083         ent_nullop_register(ASE_NULLARY_OP_ZERO, QUATERN_T, Qent_quatern_zero);
1084         ent_nullop_register(ASE_NULLARY_OP_ONE, QUATERN_T, Qent_quatern_one);
1085 }
1086
1087 static inline void
1088 ent_quatern_unary_optable_init(void)
1089 {
1090         ent_unop_register(ASE_UNARY_OP_NEG, QUATERN_T, ent_neg_QUATERN_T);
1091         ent_unop_register(ASE_UNARY_OP_INV, QUATERN_T, ent_inv_QUATERN_T);
1092 }
1093
1094 static inline void
1095 ent_quatern_binary_optable_init(void)
1096 {
1097         /* sums */
1098         ent_binop_register(ASE_BINARY_OP_SUM,
1099                            QUATERN_T, QUATERN_T, ent_sum_QUATERN_T);
1100         ent_binop_register(ASE_BINARY_OP_SUM,
1101                            QUATERN_T, INT_T, ent_sum_QUATERN_T_INT_T);
1102         ent_binop_register(ASE_BINARY_OP_SUM,
1103                            INT_T, QUATERN_T, ent_sum_INT_T_QUATERN_T);
1104         ent_binop_register(ASE_BINARY_OP_SUM,
1105                            QUATERN_T, BIGZ_T, ent_sum_QUATERN_T_BIGZ_T);
1106         ent_binop_register(ASE_BINARY_OP_SUM,
1107                            BIGZ_T, QUATERN_T, ent_sum_BIGZ_T_QUATERN_T);
1108         /* diffs */
1109         ent_binop_register(ASE_BINARY_OP_DIFF,
1110                            QUATERN_T, QUATERN_T, ent_diff_QUATERN_T);
1111         ent_binop_register(ASE_BINARY_OP_DIFF,
1112                            QUATERN_T, INT_T, ent_diff_QUATERN_T_INT_T);
1113         ent_binop_register(ASE_BINARY_OP_DIFF,
1114                            INT_T, QUATERN_T, ent_diff_INT_T_QUATERN_T);
1115         ent_binop_register(ASE_BINARY_OP_DIFF,
1116                            QUATERN_T, BIGZ_T, ent_diff_QUATERN_T_BIGZ_T);
1117         ent_binop_register(ASE_BINARY_OP_DIFF,
1118                            BIGZ_T, QUATERN_T, ent_diff_BIGZ_T_QUATERN_T);
1119         /* prods */
1120         ent_binop_register(ASE_BINARY_OP_PROD,
1121                            QUATERN_T, QUATERN_T, ent_prod_QUATERN_T);
1122         ent_binop_register(ASE_BINARY_OP_PROD,
1123                            QUATERN_T, INT_T, ent_prod_QUATERN_T_INT_T);
1124         ent_binop_register(ASE_BINARY_OP_PROD,
1125                            INT_T, QUATERN_T, ent_prod_INT_T_QUATERN_T);
1126         ent_binop_register(ASE_BINARY_OP_PROD,
1127                            QUATERN_T, BIGZ_T, ent_prod_QUATERN_T_BIGZ_T);
1128         ent_binop_register(ASE_BINARY_OP_PROD,
1129                            BIGZ_T, QUATERN_T, ent_prod_BIGZ_T_QUATERN_T);
1130
1131         /* divisions and quotients */
1132         ent_binop_register(ASE_BINARY_OP_DIV,
1133                            QUATERN_T, QUATERN_T, ent_div_QUATERN_T);
1134 #if 0
1135         ent_binop_register(ASE_BINARY_OP_DIV,
1136                            QUATERN_T, INT_T, ent_div_QUATERN_T_INT_T);
1137         ent_binop_register(ASE_BINARY_OP_DIV,
1138                            INT_T, QUATERN_T, ent_div_INT_T_QUATERN_T);
1139         ent_binop_register(ASE_BINARY_OP_DIV,
1140                            QUATERN_T, BIGZ_T, ent_div_QUATERN_T_BIGZ_T);
1141         ent_binop_register(ASE_BINARY_OP_DIV,
1142                            BIGZ_T, QUATERN_T, ent_div_BIGZ_T_QUATERN_T);
1143 #endif
1144
1145         ent_binop_register(ASE_BINARY_OP_QUO,
1146                            QUATERN_T, QUATERN_T, ent_div_QUATERN_T);
1147 #if 0
1148         ent_binop_register(ASE_BINARY_OP_QUO,
1149                            QUATERN_T, INT_T, ent_quo_QUATERN_T_INT_T);
1150         ent_binop_register(ASE_BINARY_OP_QUO,
1151                            INT_T, QUATERN_T, ent_quo_INT_T_QUATERN_T);
1152         ent_binop_register(ASE_BINARY_OP_DIV,
1153                            QUATERN_T, BIGZ_T, ent_div_QUATERN_T_BIGZ_T);
1154         ent_binop_register(ASE_BINARY_OP_DIV,
1155                            BIGZ_T, QUATERN_T, ent_div_BIGZ_T_QUATERN_T);
1156 #endif
1157
1158 #if 0                           /* not implemented yet */
1159         ent_binop_register(ASE_BINARY_OP_REM,
1160                            QUATERN_T, QUATERN_T, ent_rem_QUATERN_T);
1161         ent_binop_register(ASE_BINARY_OP_MOD,
1162                            QUATERN_T, QUATERN_T, ent_rem_QUATERN_T);
1163
1164         ent_binop_register(ASE_BINARY_OP_POW,
1165                            QUATERN_T, INT_T, ent_pow_QUATERN_T_integer);
1166         ent_binop_register(ASE_BINARY_OP_POW,
1167                            QUATERN_T, BIGZ_T, ent_pow_QUATERN_T_integer);
1168 #endif
1169 }
1170
1171 static inline void
1172 ent_quatern_unary_reltable_init(void)
1173 {
1174         ent_unrel_register(ASE_UNARY_REL_ZEROP, QUATERN_T, ent_quatern_zerop);
1175         ent_unrel_register(ASE_UNARY_REL_ONEP, QUATERN_T, ent_quatern_onep);
1176         ent_unrel_register(ASE_UNARY_REL_UNITP, QUATERN_T, ent_quatern_unitp);
1177 }
1178
1179 static inline void
1180 ent_quatern_binary_reltable_init(void)
1181 {
1182         ent_binrel_register(ASE_BINARY_REL_EQUALP,
1183                             QUATERN_T, QUATERN_T, ent_eq_quatern);
1184         ent_binrel_register(ASE_BINARY_REL_NEQP,
1185                             QUATERN_T, QUATERN_T, ent_ne_quatern);
1186 }
1187
1188 static inline void
1189 ent_quatern_lifttable_init(void)
1190 {
1191         ent_lift_register(INT_T, QUATERN_T, ent_lift_all_QUATERN_T);
1192         ent_lift_register(BIGZ_T, BIGC_T, ent_lift_all_QUATERN_T);
1193 #ifdef HAVE_MPQ
1194         ent_lift_register(BIGQ_T, QUATERN_T, ent_lift_all_QUATERN_T);
1195 #endif
1196 #ifdef HAVE_MPF
1197         ent_lift_register(BIGF_T, QUATERN_T, ent_lift_all_QUATERN_T);
1198 #endif
1199 #ifdef HAVE_MPFR
1200         ent_lift_register(BIGFR_T, QUATERN_T, ent_lift_all_QUATERN_T);
1201 #endif
1202 #ifdef HAVE_FPFLOAT
1203         ent_lift_register(FLOAT_T, QUATERN_T, ent_lift_all_QUATERN_T);
1204 #endif
1205 #ifdef HAVE_PSEUG
1206         ent_lift_register(BIGG_T, QUATERN_T, ent_lift_COMPLEX_QUATERN_T);
1207 #endif
1208 #ifdef HAVE_MPC
1209         ent_lift_register(BIGC_T, QUATERN_T, ent_lift_COMPLEX_QUATERN_T);
1210 #endif
1211 }
1212
1213 void init_optables_QUATERN_T(void)
1214 {
1215         ent_quatern_nullary_optable_init();
1216         ent_quatern_unary_optable_init();
1217         ent_quatern_binary_optable_init();
1218         ent_quatern_unary_reltable_init();
1219         ent_quatern_binary_reltable_init();
1220         ent_quatern_lifttable_init();
1221 }
1222
1223 \f
1224 DEFUN ("make-quatern", Fmake_quatern, 4, 4, 0, /*
1225 Return the Quaternion whose z-component is Z,
1226 whose i-, j-, and k-components are I, J and K, respectively.
1227 */
1228        (z, i, j, k))
1229 {
1230         Lisp_Object tmp_z, tmp_i, tmp_j, tmp_k;
1231
1232         CHECK_COMPARABLE(z);
1233         CHECK_COMPARABLE(i);
1234         CHECK_COMPARABLE(j);
1235         CHECK_COMPARABLE(k);
1236
1237         tmp_z = Fcoerce_number(z, Qbigz, Qnil);
1238         tmp_i = Fcoerce_number(i, Qbigz, Qnil);
1239         tmp_j = Fcoerce_number(j, Qbigz, Qnil);
1240         tmp_k = Fcoerce_number(k, Qbigz, Qnil);
1241         return make_quatern_bz(XBIGZ_DATA(tmp_z), XBIGZ_DATA(tmp_i),
1242                                XBIGZ_DATA(tmp_j), XBIGZ_DATA(tmp_k));
1243 }
1244
1245 DEFUN ("quatern-z", Fquatern_z, 1, 1, 0, /*
1246 Return QUATERNION's z-component.
1247 */
1248        (quaternion))
1249 {
1250         CHECK_NUMBER(quaternion);
1251
1252         if (COMPARABLEP(quaternion))
1253                 return quaternion;
1254         else if (COMPLEXP(quaternion))
1255                 return Freal_part(quaternion);
1256         else if (QUATERNP(quaternion))
1257                 return make_bigz_bz(XQUATERN_Z(quaternion));
1258         else
1259                 return wrong_type_argument(Qquaternp, quaternion);
1260 }
1261 DEFUN ("quatern-i", Fquatern_i, 1, 1, 0, /*
1262 Return QUATERNION's i-component.
1263 */
1264        (quaternion))
1265 {
1266         CHECK_NUMBER(quaternion);
1267
1268         if (COMPARABLEP(quaternion))
1269                 return Qzero;
1270         else if (COMPLEXP(quaternion))
1271                 return Fimaginary_part(quaternion);
1272         else if (QUATERNP(quaternion))
1273                 return make_bigz_bz(XQUATERN_I(quaternion));
1274         else
1275                 return wrong_type_argument(Qquaternp, quaternion);
1276 }
1277 DEFUN ("quatern-j", Fquatern_j, 1, 1, 0, /*
1278 Return QUATERNION's j-component.
1279 */
1280        (quaternion))
1281 {
1282         CHECK_NUMBER(quaternion);
1283
1284         if (COMPARABLEP(quaternion) || COMPLEXP(quaternion))
1285                 return Qzero;
1286         else if (QUATERNP(quaternion))
1287                 return make_bigz_bz(XQUATERN_J(quaternion));
1288         else
1289                 return wrong_type_argument(Qquaternp, quaternion);
1290 }
1291 DEFUN ("quatern-k", Fquatern_k, 1, 1, 0, /*
1292 Return QUATERNION's k-component.
1293 */
1294        (quaternion))
1295 {
1296         CHECK_NUMBER(quaternion);
1297
1298         if (COMPARABLEP(quaternion) || COMPLEXP(quaternion))
1299                 return Qzero;
1300         else if (QUATERNP(quaternion))
1301                 return make_bigz_bz(XQUATERN_K(quaternion));
1302         else
1303                 return wrong_type_argument(Qquaternp, quaternion);
1304 }
1305 \f
1306 void init_ent_quatern(void)
1307 {
1308         quatern_init(ent_scratch_quatern);
1309 }
1310
1311 void syms_of_ent_quatern(void)
1312 {
1313         INIT_LRECORD_IMPLEMENTATION(quatern);
1314
1315         DEFSYMBOL(Qquatern);
1316
1317         DEFSUBR(Fmake_quatern);
1318         DEFSUBR(Fquatern_z);
1319         DEFSUBR(Fquatern_i);
1320         DEFSUBR(Fquatern_j);
1321         DEFSUBR(Fquatern_k);
1322 }
1323
1324 void vars_of_ent_quatern(void)
1325 {
1326         Fprovide(intern("quatern"));
1327 }