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