2 ent-quatern.c -- Numeric types for SXEmacs
3 Copyright (C) 2005, 2006 Sebastian Freundt
5 Author: Sebastian Freundt
7 This file is part of SXEmacs
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.
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.
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/>. */
27 #include "sysproc.h" /* For qxe_getpid */
29 #include "ent-quatern.h"
31 quatern ent_scratch_quatern;
33 static ase_nullary_operation_f Qent_quatern_zero, Qent_quatern_one;
37 quatern_print(Lisp_Object obj, Lisp_Object printcharfun, int SXE_UNUSED(escapeflag))
39 Bufbyte *fstr = quatern_to_string(XQUATERN_DATA(obj), 10);
40 write_c_string((char*)fstr, printcharfun);
42 fstr = (Bufbyte *)NULL;
47 quatern_equal(Lisp_Object obj1, Lisp_Object obj2, int SXE_UNUSED(depth))
49 return quatern_eql(XQUATERN_DATA(obj1), XQUATERN_DATA(obj2));
53 quatern_hash(Lisp_Object obj, int SXE_UNUSED(depth))
55 return quatern_hashcode(XQUATERN_DATA(obj));
59 quatern_mark(Lisp_Object SXE_UNUSED(obj))
65 quatern_finalise(void *unused, int for_disksave)
69 "Can't dump an emacs containing "
70 "quaternionic objects", Qt);
74 static const struct lrecord_description quatern_description[] = {
75 { XD_OPAQUE_DATA_PTR, offsetof(Lisp_Quatern, data) },
79 DEFINE_BASIC_LRECORD_IMPLEMENTATION("quatern", quatern,
80 quatern_mark, quatern_print,
82 quatern_equal, quatern_hash,
83 quatern_description, Lisp_Quatern);
87 void quatern_init(quatern g)
89 bigz_init(quatern_z(g));
90 bigz_init(quatern_i(g));
91 bigz_init(quatern_j(g));
92 bigz_init(quatern_k(g));
95 void quatern_fini(quatern g)
97 bigz_fini(quatern_z(g));
98 bigz_fini(quatern_i(g));
99 bigz_fini(quatern_j(g));
100 bigz_fini(quatern_k(g));
103 unsigned long quatern_hashcode(quatern g)
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)));
111 Bufbyte *quatern_to_string(quatern g, int base)
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;
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);
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);
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;
134 /* now append the imaginary string */
135 XREALLOC_ARRAY(z_str, Bufbyte, z_len +
142 z_str[z_len+neg_i+i_len+1] = '+';
144 z_str[z_len+neg_i+i_len+1+neg_j+j_len+1] = '+';
145 memmove(&z_str[z_len + neg_i],
148 memmove(&z_str[z_len + neg_i+i_len+1 + neg_j],
151 memmove(&z_str[z_len + neg_i+i_len+1 + neg_j+j_len+1 + neg_k],
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';
163 /***** Quatern: converting assignments *****/
164 void quatern_set(quatern g1,quatern g2)
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));
172 void quatern_set_long(quatern g, long l)
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);
180 void quatern_set_long_long_long_long(
181 quatern g, long l1, long l2, long l3, long l4)
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);
189 void quatern_set_ulong(quatern g, unsigned long ul)
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);
197 void quatern_set_ulong_ulong_ulong_ulong(
198 quatern g, unsigned long ul1, unsigned long ul2,
199 unsigned long ul3, unsigned long ul4)
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);
207 void quatern_set_bigz(quatern g, bigz z)
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);
215 void quatern_set_bigz_bigz_bigz_bigz(
216 quatern g, bigz z1, bigz z2, bigz z3, bigz z4)
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);
224 /* void bigc_set_quatern(bigc c, quatern g)
226 * bigc_set_bigfr_bigfr(quatern_z(g), z1);
230 /***** Quatern: comparisons *****/
231 int quatern_eql(quatern g1, quatern g2)
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))));
239 /***** Quatern: arithmetic *****/
241 void quatern_abs(bigfr res, quatern g)
244 /* the absolute archimedean valuation of a+bi is defined as:
245 * (a^2 + b^2 + c^2 + d^2)^(1/2)
247 bigz accu1, accu2, bz;
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);
256 bigfr_set_bigz(res, bz);
257 bigfr_sqrt(res, res);
265 void quatern_norm(bigz res, quatern g)
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));
273 void quatern_neg(quatern res, quatern g)
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));
282 void quatern_conj(quatern res, quatern g)
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));
290 void quatern_add(quatern res, quatern g1, quatern g2)
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));
301 quatern_set(res, accu);
305 void quatern_sub(quatern res, quatern g1, quatern g2)
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));
316 quatern_set(res, accu);
320 void quatern_mul(quatern res, quatern g1, quatern g2)
322 /* multiplication is defined as:
323 * (a + bi + cj + dk)*(e + fi + gj + hk) = <too complex ;)>
325 bigz accu1, accu2, accu3, accu4;
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));
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);
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));
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);
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));
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);
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));
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);
377 quatern_set(res, accu);
386 void quatern_div(quatern res, quatern g1, quatern g2)
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)
393 quatern_norm(ent_scratch_bigz, g2);
395 /* do normal multiplication with conjugate of g2 */
396 quatern_conj(ent_scratch_quatern, g2);
397 quatern_mul(res, g1, ent_scratch_quatern);
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);
406 void quatern_mod(quatern res, quatern g1, quatern g2)
409 /* the modulo relation is defined as:
410 * (a + bi) mod (c + di) ~
411 * (a+bi) - ((a+bi) div (c-di)) * (c+di)
416 /* do normal division */
417 quatern_div(accug, g1, g2);
419 /* now re-multiply g2 */
420 quatern_mul(accug, accug, g2);
422 /* and find the difference */
423 quatern_sub(res, g1, accug);
428 void quatern_pow(quatern res, quatern g1, unsigned long g2)
430 #if defined(HAVE_MPZ) && defined(WITH_GMP)
433 bigz bin, resintg, resimag, tmpbz1, tmpbz2, tmpbz3, intg, imag;
444 bigz_set_long(resintg, 0L);
445 bigz_set_long(resimag, 0L);
447 bigz_set(intg, quatern_z(g1));
448 bigz_set(imag, quatern_i(g1));
450 /* we compute using the binomial coefficients */
451 for (i=0; i<=g2; i++) {
452 mpz_bin_uiui(bin, g2, i);
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);
460 bigz_add(resintg, resintg, bin);
461 } else if (i % 4 == 2) {
462 bigz_sub(resintg, resintg, bin);
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);
471 bigz_add(resimag, resimag, bin);
472 } else if (i % 4 == 3) {
473 bigz_sub(resimag, resimag, bin);
478 quatern_set_bigz_bigz_bigz_bigz(res, resintg, resimag, resimag, resimag);
489 quatern_set_long_long(res, 0L, 0L);
496 #define I_UNARY_SYMBOL 2
499 #define J_UNARY_SYMBOL 16
502 #define K_UNARY_SYMBOL 128
506 int isquatern_string (const char *cp)
509 const Bufbyte *ucp = (const Bufbyte *)cp;
512 /* parse the z-part */
514 if (*ucp == '+' || *ucp == '-')
517 if (*ucp >= '0' && *ucp <= '9') {
519 while (*ucp >= '0' && *ucp <= '9')
523 /* check if we had a int number until here */
524 if (!(state == (Z_INT)))
527 /* now parse i-part */
529 if (*ucp == '+' || *ucp == '-') {
530 state |= I_UNARY_SYMBOL;
534 if (*ucp >= '0' && *ucp <= '9') {
536 while (*ucp >= '0' && *ucp <= '9')
539 if (*ucp == 'i' || *ucp == 'I') {
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)))
548 /* now parse j-part */
550 if (*ucp == '+' || *ucp == '-') {
551 state |= J_UNARY_SYMBOL;
555 if (*ucp >= '0' && *ucp <= '9') {
557 while (*ucp >= '0' && *ucp <= '9')
560 if (*ucp == 'j' || *ucp == 'J') {
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)))
569 /* now parse k-part */
571 if (*ucp == '+' || *ucp == '-') {
572 state |= K_UNARY_SYMBOL;
576 if (*ucp >= '0' && *ucp <= '9') {
578 while (*ucp >= '0' && *ucp <= '9')
581 if (*ucp == 'k' || *ucp == 'K') {
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)))
590 return (((*ucp == 0) || (*ucp == ' ') || (*ucp == '\t') ||
591 (*ucp == '\n') || (*ucp == '\r') || (*ucp == '\f')));
594 Lisp_Object read_quatern_string(char *cp)
596 bigz bz_z, bz_i, bz_j, bz_k;
607 /* MPZ bigz_set_string has no effect
608 * with initial + sign */
615 /* jump over a leading minus */
619 while ((*cp >= '0' && *cp <= '9'))
622 /* MPZ cannot read numbers with characters after them.
623 * See limitations below in convert GMP-MPZ strings
627 bigz_set_string(bz_z, (char *)end, 0);
630 /* read the i-part */
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);
650 while ((*cp >= '0' && *cp <= '9'))
654 bigz_set_string(bz_i, (char *)end, 0);
658 if (*cp == 'i' || *cp == 'I')
661 /* read the j-part */
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);
681 while ((*cp >= '0' && *cp <= '9'))
685 bigz_set_string(bz_j, (char *)end, 0);
689 if (*cp == 'j' || *cp == 'J')
692 /* read the k-part */
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);
712 while ((*cp >= '0' && *cp <= '9'))
716 bigz_set_string(bz_k, (char *)end, 0);
720 if (*cp == 'k' || *cp == 'K')
723 result = make_quatern_bz(bz_z, bz_i, bz_j, bz_k);
734 ent_quatern_zerop(Lisp_Object o)
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);
743 ent_quatern_onep(Lisp_Object o)
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);
753 ent_quatern_unitp(Lisp_Object o)
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)));
774 static inline Lisp_Object
775 ent_sum_QUATERN_T(Lisp_Object l, Lisp_Object r)
777 quatern_add(ent_scratch_quatern, XQUATERN_DATA(l), XQUATERN_DATA(r));
778 return make_quatern_qu(ent_scratch_quatern);
780 static inline Lisp_Object
781 ent_sum_QUATERN_T_INT_T(Lisp_Object l, Lisp_Object r)
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);
787 static inline Lisp_Object
788 ent_sum_INT_T_QUATERN_T(Lisp_Object l, Lisp_Object r)
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);
794 static inline Lisp_Object
795 ent_sum_QUATERN_T_BIGZ_T(Lisp_Object l, Lisp_Object r)
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);
801 static inline Lisp_Object
802 ent_sum_BIGZ_T_QUATERN_T(Lisp_Object l, Lisp_Object r)
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);
809 static inline Lisp_Object
810 ent_diff_QUATERN_T(Lisp_Object l, Lisp_Object r)
812 quatern_sub(ent_scratch_quatern, XQUATERN_DATA(l), XQUATERN_DATA(r));
813 return make_quatern_qu(ent_scratch_quatern);
815 static inline Lisp_Object
816 ent_diff_QUATERN_T_INT_T(Lisp_Object l, Lisp_Object r)
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);
822 static inline Lisp_Object
823 ent_diff_INT_T_QUATERN_T(Lisp_Object l, Lisp_Object r)
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);
829 static inline Lisp_Object
830 ent_diff_QUATERN_T_BIGZ_T(Lisp_Object l, Lisp_Object r)
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);
836 static inline Lisp_Object
837 ent_diff_BIGZ_T_QUATERN_T(Lisp_Object l, Lisp_Object r)
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);
844 static inline Lisp_Object
845 ent_neg_QUATERN_T(Lisp_Object l)
847 quatern_neg(ent_scratch_quatern, XQUATERN_DATA(l));
848 return make_quatern_qu(ent_scratch_quatern);
850 static inline Lisp_Object
851 ent_prod_QUATERN_T(Lisp_Object l, Lisp_Object r)
853 quatern_mul(ent_scratch_quatern, XQUATERN_DATA(l), XQUATERN_DATA(r));
854 return make_quatern_qu(ent_scratch_quatern);
856 static inline Lisp_Object
857 ent_prod_QUATERN_T_INT_T(Lisp_Object l, Lisp_Object r)
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);
863 static inline Lisp_Object
864 ent_prod_INT_T_QUATERN_T(Lisp_Object l, Lisp_Object r)
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);
870 static inline Lisp_Object
871 ent_prod_QUATERN_T_BIGZ_T(Lisp_Object l, Lisp_Object r)
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);
877 static inline Lisp_Object
878 ent_prod_BIGZ_T_QUATERN_T(Lisp_Object l, Lisp_Object r)
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);
885 static inline Lisp_Object
886 ent_div_QUATERN_T(Lisp_Object l, Lisp_Object r)
888 if (ent_quatern_zerop(r)) {
889 if (!ent_quatern_zerop(l)) {
890 return make_indef(COMPLEX_INFINITY);
892 return make_indef(NOT_A_NUMBER);
895 quatern_div(ent_scratch_quatern, XQUATERN_DATA(l), XQUATERN_DATA(r));
896 return make_quatern_qu(ent_scratch_quatern);
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
902 static inline Lisp_Object
903 ent_quo_QUATERN_T(Lisp_Object l, Lisp_Object r)
905 if (ent_quatern_zerop(r)) {
906 if (!ent_quatern_zerop(l)) {
907 return make_indef(COMPLEX_INFINITY);
909 return make_indef(NOT_A_NUMBER);
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);
919 static inline Lisp_Object
920 ent_inv_QUATERN_T(Lisp_Object r)
922 if (ent_quatern_zerop(r)) {
923 return make_indef(COMPLEX_INFINITY);
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);
929 static inline Lisp_Object
930 ent_rem_QUATERN_T(Lisp_Object l, Lisp_Object r)
932 if (ent_quatern_zerop(r)) {
933 return Qent_quatern_zero;
935 quatern_mod(ent_scratch_quatern, XQUATERN_DATA(l), XQUATERN_DATA(r));
936 return make_quatern_qu(ent_scratch_quatern);
938 static inline Lisp_Object
939 ent_pow_QUATERN_T_integer(Lisp_Object l, Lisp_Object r)
946 if (bigz_fits_ulong_p(XBIGZ_DATA(r)))
947 expo = bigz_to_ulong(XBIGZ_DATA(r));
949 Fsignal(Qarith_error, r);
951 Fsignal(Qdomain_error, r);
953 quatern_pow(ent_scratch_quatern, XQUATERN_DATA(l), expo);
954 return make_quatern_qu(ent_scratch_quatern);
959 ent_eq_quatern(Lisp_Object l, Lisp_Object r)
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))));
972 ent_ne_quatern(Lisp_Object l, Lisp_Object r)
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))));
985 static inline Lisp_Object
986 ent_vallt_QUATERN_T(Lisp_Object l, Lisp_Object r)
992 quatern_norm(ent_scratch_bigz, XQUATERN_DATA(l));
993 quatern_norm(b2, XQUATERN_DATA(r));
994 result = bigz_lt(ent_scratch_bigz, b2);
997 return (result) ? Qt : Qnil;
999 static inline Lisp_Object
1000 ent_valgt_QUATERN_T(Lisp_Object l, Lisp_Object r)
1006 quatern_norm(ent_scratch_bigz, XQUATERN_DATA(l));
1007 quatern_norm(b2, XQUATERN_DATA(r));
1008 result = bigz_gt(ent_scratch_bigz, b2);
1011 return (result) ? Qt : Qnil;
1013 static inline Lisp_Object
1014 ent_valeq_QUATERN_T(Lisp_Object l, Lisp_Object r)
1020 quatern_norm(ent_scratch_bigz, XQUATERN_DATA(l));
1021 quatern_norm(b2, XQUATERN_DATA(r));
1022 result = bigz_eql(ent_scratch_bigz, b2);
1025 return (result) ? Qt : Qnil;
1027 static inline Lisp_Object
1028 ent_valne_QUATERN_T(Lisp_Object l, Lisp_Object r)
1034 quatern_norm(ent_scratch_bigz, XQUATERN_DATA(l));
1035 quatern_norm(b2, XQUATERN_DATA(r));
1036 result = bigz_eql(ent_scratch_bigz, b2);
1039 return (result) ? Qnil : Qt;
1044 static inline Lisp_Object
1045 ent_lift_all_QUATERN_T(Lisp_Object number, ent_lift_args_t SXE_UNUSED(la))
1047 number = ent_lift(number, BIGZ_T, NULL);
1048 bigz_set_long(ent_scratch_bigz, 0L);
1049 return make_quatern_bz(XBIGZ_DATA(number),
1057 ent_lift_COMPLEX_QUATERN_T(Lisp_Object number, ent_lift_args_t SXE_UNUSED(la))
1061 z = Freal_part(number);
1062 i = Fimaginary_part(number);
1064 z = ent_lift(z, BIGZ_T, NULL);
1065 i = ent_lift(i, BIGZ_T, NULL);
1067 bigz_set_long(ent_scratch_bigz, 0L);
1068 return make_quatern_bz(XBIGZ_DATA(z), XBIGZ_DATA(i),
1076 ent_quatern_nullary_optable_init(void)
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);
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);
1088 ent_quatern_unary_optable_init(void)
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);
1095 ent_quatern_binary_optable_init(void)
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);
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);
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);
1131 /* divisions and quotients */
1132 ent_binop_register(ASE_BINARY_OP_DIV,
1133 QUATERN_T, QUATERN_T, ent_div_QUATERN_T);
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);
1145 ent_binop_register(ASE_BINARY_OP_QUO,
1146 QUATERN_T, QUATERN_T, ent_div_QUATERN_T);
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);
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);
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);
1172 ent_quatern_unary_reltable_init(void)
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);
1180 ent_quatern_binary_reltable_init(void)
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);
1189 ent_quatern_lifttable_init(void)
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);
1194 ent_lift_register(BIGQ_T, QUATERN_T, ent_lift_all_QUATERN_T);
1197 ent_lift_register(BIGF_T, QUATERN_T, ent_lift_all_QUATERN_T);
1200 ent_lift_register(BIGFR_T, QUATERN_T, ent_lift_all_QUATERN_T);
1203 ent_lift_register(FLOAT_T, QUATERN_T, ent_lift_all_QUATERN_T);
1206 ent_lift_register(BIGG_T, QUATERN_T, ent_lift_COMPLEX_QUATERN_T);
1209 ent_lift_register(BIGC_T, QUATERN_T, ent_lift_COMPLEX_QUATERN_T);
1213 void init_optables_QUATERN_T(void)
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();
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.
1230 Lisp_Object tmp_z, tmp_i, tmp_j, tmp_k;
1232 CHECK_COMPARABLE(z);
1233 CHECK_COMPARABLE(i);
1234 CHECK_COMPARABLE(j);
1235 CHECK_COMPARABLE(k);
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));
1245 DEFUN ("quatern-z", Fquatern_z, 1, 1, 0, /*
1246 Return QUATERNION's z-component.
1250 CHECK_NUMBER(quaternion);
1252 if (COMPARABLEP(quaternion))
1254 else if (COMPLEXP(quaternion))
1255 return Freal_part(quaternion);
1256 else if (QUATERNP(quaternion))
1257 return make_bigz_bz(XQUATERN_Z(quaternion));
1259 return wrong_type_argument(Qquaternp, quaternion);
1261 DEFUN ("quatern-i", Fquatern_i, 1, 1, 0, /*
1262 Return QUATERNION's i-component.
1266 CHECK_NUMBER(quaternion);
1268 if (COMPARABLEP(quaternion))
1270 else if (COMPLEXP(quaternion))
1271 return Fimaginary_part(quaternion);
1272 else if (QUATERNP(quaternion))
1273 return make_bigz_bz(XQUATERN_I(quaternion));
1275 return wrong_type_argument(Qquaternp, quaternion);
1277 DEFUN ("quatern-j", Fquatern_j, 1, 1, 0, /*
1278 Return QUATERNION's j-component.
1282 CHECK_NUMBER(quaternion);
1284 if (COMPARABLEP(quaternion) || COMPLEXP(quaternion))
1286 else if (QUATERNP(quaternion))
1287 return make_bigz_bz(XQUATERN_J(quaternion));
1289 return wrong_type_argument(Qquaternp, quaternion);
1291 DEFUN ("quatern-k", Fquatern_k, 1, 1, 0, /*
1292 Return QUATERNION's k-component.
1296 CHECK_NUMBER(quaternion);
1298 if (COMPARABLEP(quaternion) || COMPLEXP(quaternion))
1300 else if (QUATERNP(quaternion))
1301 return make_bigz_bz(XQUATERN_K(quaternion));
1303 return wrong_type_argument(Qquaternp, quaternion);
1306 void init_ent_quatern(void)
1308 quatern_init(ent_scratch_quatern);
1311 void syms_of_ent_quatern(void)
1313 INIT_LRECORD_IMPLEMENTATION(quatern);
1315 DEFSYMBOL(Qquatern);
1317 DEFSUBR(Fmake_quatern);
1318 DEFSUBR(Fquatern_z);
1319 DEFSUBR(Fquatern_i);
1320 DEFSUBR(Fquatern_j);
1321 DEFSUBR(Fquatern_k);
1324 void vars_of_ent_quatern(void)
1326 Fprovide(intern("quatern"));