1 /* FILE:nu.c */
2 #include "def.h"
3 #include "macro.h"
4
5
6 #ifdef SQRADTRUE
squareroot(a,b)7 INT squareroot(a,b) OP a,b;
8 /* AK 040291 V1.2 */ /* AK 140891 V1.3 */
9 /* b becomes the squareroot of a */
10 {
11 INT erg=OK;
12 COP("squareroot(1)",a);
13 COP("squareroot(2)",b);
14 CE2(a,b,squareroot);
15 CTO(EMPTY,"squareroot(i2)",b);
16
17 switch (S_O_K(a))
18 {
19 #ifdef BRUCHTRUE
20 case BRUCH:
21 erg += squareroot_bruch(a,b);
22 goto sqende;
23 #endif /* BRUCHTRUE */
24
25 #ifdef INTEGERTRUE
26 case INTEGER:
27 erg += squareroot_integer(a,b);
28 goto sqende;
29 #endif /* INTEGERTRUE */
30
31 #ifdef LONGINTTRUE
32 case LONGINT:
33 erg += squareroot_longint(a,b);
34 goto sqende;
35 #endif /* LONGINTTRUE */
36 default:
37 erg += WTO("squareroot(1)",a);
38 goto sqende;
39 }
40 sqende:
41 ENDR("squareroot");
42
43 }
44
45
46
ganzsquareroot(a,b)47 INT ganzsquareroot(a,b) OP a,b;
48 /* AK 040291 V1.2 */
49 /* b becomes the integer squareroot of a ,
50 i.e. the largest integer with b^2 <= a */
51 /* AK 140891 V1.3 */
52 /* AK 290704 V3.0 */
53 {
54 INT erg = OK;
55 COP("ganzsquareroot(1)",a);
56 COP("ganzsquareroot(2)",b);
57 CE2(a,b,ganzsquareroot);
58 CTO(EMPTY,"ganzsquareroot(i2)",b);
59
60 switch (S_O_K(a))
61 {
62 #ifdef INTEGERTRUE
63 case INTEGER:
64 erg+= ganzsquareroot_integer(a,b);
65 goto endr_ende;
66 #endif /* INTEGERTRUE */
67
68 #ifdef LONGINTTRUE
69 case LONGINT:
70 erg += ganzsquareroot_longint(a,b);
71 goto endr_ende;
72 #endif /* LONGINTTRUE */
73
74 default:
75 erg+= WTO("ganzsquareroot(1)",a);
76 goto endr_ende;
77 }
78 ENDR("ganzsquareroot");
79 }
80 #endif /* SQRADTRUE */
81
82
max(a,b)83 INT max(a,b) OP a,b;
84 /* AK 280689 V1.0 */ /* AK 010290 V1.1 */
85 /* b is a copy of the maximum element */
86
87 /* AK 140891 V1.3 */
88 {
89 INT erg = OK;
90 COP("max(1)",a);
91 COP("max(2)",b);
92 CE2(a,b,max);
93 CTO(EMPTY,"max(i2)",b);
94
95 switch (S_O_K(a))
96 {
97
98 #ifdef MATRIXTRUE
99 case MATRIX:
100 erg += max_matrix(a,b);
101 goto ende;
102 #endif /* MATRIXTRUE */
103
104 #ifdef TABLEAUXTRUE
105 case TABLEAUX:
106 erg += max_tableaux(a,b);
107 goto ende;
108 #endif /* TABLEAUXTRUE */
109
110 #ifdef VECTORTRUE
111 case WORD:
112 case INTEGERVECTOR:
113 erg += max_integervector(a,b);
114 goto ende;
115 case VECTOR:
116 erg += max_vector(a,b);
117 goto ende;
118 #endif /* VECTORTRUE */
119
120 default:
121 erg += WTO("max(1)",a);
122 goto ende;
123 };
124 ende:
125 ENDR("max");
126 }
127
min(a,b)128 INT min(a,b) OP a,b;
129 /* AK 140703 */
130 /* b is a copy of the minimum element */
131
132 /* AK 140891 V1.3 */
133 {
134 INT erg = OK;
135 COP("min(1)",a);
136 COP("min(2)",b);
137 CE2(a,b,min);
138 CTO(EMPTY,"min(i2)",b);
139
140 switch (S_O_K(a))
141 {
142
143 #ifdef MATRIXTRUE
144 case MATRIX:
145 erg += min_matrix(a,b);
146 goto ende;
147 #endif /* MATRIXTRUE */
148
149 #ifdef TABLEAUXTRUE
150 case TABLEAUX:
151 erg += min_tableaux(a,b);
152 goto ende;
153 #endif /* TABLEAUXTRUE */
154
155 #ifdef VECTORTRUE
156 case WORD:
157 case INTEGERVECTOR:
158 erg += min_integervector(a,b);
159 goto ende;
160 case VECTOR:
161 erg += min_vector(a,b);
162 goto ende;
163 #endif /* VECTORTRUE */
164
165 default:
166 erg += WTO("min(1)",a);
167 goto ende;
168 };
169 ende:
170 ENDR("max");
171 }
172
absolute(a,c)173 INT absolute(a,c) OP a,c;
174 /* AK 100888 */ /* AK 280689 V1.0 */ /* AK 050390 V1.1 */
175 /* AK 140891 V1.3 */
176 {
177 INT erg=OK;
178 COP("absolute(1)",a);
179 COP("absolute(2)",c);
180 CE2(a,c,absolute);
181 CTO(EMPTY,"absolute(i2)",c);
182
183 switch(S_O_K(a))
184 {
185 #ifdef BRUCHTRUE
186 case BRUCH:
187 erg += absolute_bruch(a,c);
188 goto ende;
189 #endif /* BRUCHTRUE */
190 #ifdef INTEGERTRUE
191 case INTEGER:
192 M_I_I((S_I_I(a) > 0 ? S_I_I(a): - S_I_I(a)),c);
193 goto ende;
194 #endif /* INTEGERTRUE */
195 #ifdef LONGINTTRUE
196 case LONGINT:
197 erg += absolute_longint(a,c);
198 goto ende;
199 #endif /* LONGINTTRUE */
200 #ifdef MATRIXTRUE
201 case MATRIX:
202 erg += absolute_matrix(a,c);
203 goto ende;
204 #endif /* MATRIXTRUE */
205 #ifdef VECTORTRUE
206 case WORD:
207 case COMPOSITION:
208 case VECTOR:
209 erg += absolute_vector(a,c);
210 goto ende;
211 case INTEGERVECTOR:
212 erg += absolute_integervector(a,c);
213 goto ende;
214 #endif /* VECTORTRUE */
215 default:
216 erg += WTO("absolute(1)",a);
217 goto ende;
218 }
219 ende:
220 ENDR("absolute");
221 }
222
transpose(a,b)223 INT transpose(a,b) OP a,b;
224 /* AK 280388 */ /* AK 280689 V1.0 */ /* AK 050390 V1.1 */
225 /* AK 140891 V1.3 */
226 {
227 INT erg=OK;
228 COP("transpose(1)",a);
229 COP("transpose(2)",b);
230 CE2(a,b,transpose);
231
232 switch (S_O_K(a))
233 {
234 #ifdef MATRIXTRUE
235 case KOSTKA:
236 case KRANZTYPUS:
237 case MATRIX:
238 erg += transpose_matrix(a,b);
239 goto ende;
240 #endif /* MATRIXTRUE */
241 default:
242 WTO("transpose(1)",a);
243 goto ende;
244 };
245 ende:
246 ENDR("transpose");
247 }
248
sub(a,b,c)249 INT sub(a,b,c) OP a,b,c;
250 /* AK 300388 */ /* c = a - b */ /* AK 280689 V1.0 */ /* AK 131289 V1.1 */
251 /* AK 270291 V1.2 */ /* AK 140891 V1.3 */
252 /* AK 260398 V2.0 */
253 {
254 INT erg = OK;
255 EOP("sub(1)",a);
256 EOP("sub(2)",b);
257 COP("sub(3)",c);
258 CE3(a,b,c,sub);
259 switch(S_O_K(a)) {
260 default:
261 erg += sub_default(a,b,c);
262 break;
263 }
264 ENDR("sub");
265 }
266
sub_default(a,b,c)267 INT sub_default(a,b,c) OP a,b,c;
268 /* AK 220202 */
269 {
270 OP d;
271 INT erg = OK;
272 CTO(EMPTY,"sub_default(3)",c);
273 CTO(ANYTYPE,"sub_default(1)",a);
274 CTO(ANYTYPE,"sub_default(2)",b);
275 d=CALLOCOBJECT();
276 ADDINVERS(b,d);
277 ADD(a,d,c);
278 FREEALL(d);
279 CTO(ANYTYPE,"sub_default(e3)",c);
280 ENDR("sub_default");
281 }
282
sub_apply(a,b)283 INT sub_apply(a,b) OP a,b;
284 /* AK 300102 */
285 /* b := b-a; */
286 {
287 INT erg = OK;
288 EOP("sub_apply(1)",a);
289 EOP("sub_apply(2)",b);
290 if (a == b) {
291 erg += m_i_i(0,a);
292 }
293 else {
294 ADDINVERS_APPLY(a);
295 ADD_APPLY(a,b);
296 ADDINVERS_APPLY(a);
297 }
298 ENDR("sub_apply");
299 }
300
kgv(p1,second,d)301 INT kgv(p1,second,d) OP p1, second, d;
302 /* 031186 */ /* d = kgv(p1,second) */
303 /* AK 280689 V1.0 */ /* AK 131289 V1.1 */ /* AK 290591 V1.2 */
304 /* AK 140891 V1.3 */
305 /* AK 260398 V2.0 */
306 {
307 INT erg = OK;
308 OP a,b;
309 EOP("kgv(1)",p1);
310 EOP("kgv(2)",second);
311 COP("kgv(3)",d);
312
313 a=callocobject();
314 b=callocobject();
315 erg += mult(p1,second,a);
316 erg += ggt(p1,second,b);
317 erg += div(a,b,d);
318 erg += freeall(a);
319 erg += freeall(b);
320 ENDR("kgv");
321 }
322
signum(a,c)323 INT signum(a,c) OP a,c;
324 /* AK 280689 V1.0 */ /* AK 181289 V1.1 */ /* AK 140891 V1.3 */
325 /* AK 260398 V2.0 */
326 {
327 INT erg=OK;
328 EOP("signum(1)",a);
329 COP("signum(2)",c);
330 CE2(a,c,signum);
331 switch (S_O_K(a))
332 {
333 #ifdef PERMTRUE
334 case PERMUTATION:
335 erg += signum_permutation(a,c);break;
336 #endif /* PERMTRUE */
337 default:
338 erg += WTO("signum",a); break;
339 };
340 ENDR("signum");
341 }
342
343
lehmercode(a,b)344 INT lehmercode(a,b) OP a,b;
345 /* berechnet den lehmercode entweder einer permuation oder eines vectors
346 AK 270787 */
347 /* AK 280689 V1.0 */ /* AK 181289 V1.1 */ /* AK 140891 V1.3 */
348 /* AK 260398 V2.0 */
349 {
350 INT erg=OK;
351 CE2(a,b,lehmercode);
352 switch (S_O_K(a))
353 {
354 #ifdef PERMTRUE
355 case PERMUTATION:
356 erg += lehmercode_permutation(a,b);
357 break;
358 case VECTOR:
359 case INTEGERVECTOR:
360 erg += lehmercode_vector(a,b);
361 break;
362 #endif /* PERMTRUE */
363 default:
364 WTO("lehmercode",a); break;
365 };
366 ENDR("lehmercode");
367 }
368
add(a,b,d)369 INT add(a,b,d) OP a,b,d;
370 /* AK 160986 */ /* AK 280689 V1.0 */ /* AK 050390 V1.1 */
371 /* AK 270291 V1.2 */ /* AK 070891 V1.3 */
372 /* d = a+b */
373 {
374 INT erg=OK;
375 EOP("add(1)",a);
376 EOP("add(2)",b);
377 COP("add(3)",d);
378 CE3(a,b,d,add);
379
380
381 switch(S_O_K(a))
382 {
383 #ifdef MONOPOLYTRUE
384 case MONOPOLY:
385 erg += add_monopoly (a,b,d);
386 goto add_ende;
387 #endif /* MONOPOLYTRUE */
388 #ifdef CYCLOTRUE
389 case CYCLOTOMIC:
390 erg += add_cyclo (a,b,d);
391 goto add_ende;
392 #endif /* CYCLOTRUE */
393 #ifdef SQRADTRUE
394 case SQ_RADICAL:
395 erg += add_sqrad (a,b,d);
396 goto add_ende;
397 #endif /* SQRADTRUE */
398 case INTEGER :
399 erg += add_integer(a,b,d);
400 break;
401 case LAURENT :
402 erg += add_laurent(a,b,d);
403 break;
404 #ifdef FFTRUE
405 case FF:
406 erg += add_ff(a,b,d);
407 break;
408 #endif /* FFTRUE */
409
410
411
412 #ifdef GRTRUE
413 case GALOISRING:
414 erg += add_galois(a,b,d);
415 break;
416 #endif /* GRTRUE */
417
418
419 #ifdef REIHETRUE
420 case REIHE:
421 erg += add_reihe(a,b,d);
422 break;
423 #endif /* REIHETRUE */
424 #ifdef PARTTRUE
425 case PARTITION:
426 erg += add_partition(a,b,d);
427 break;
428 #endif /* PARTTRUE */
429 #ifdef POLYTRUE
430 case GRAL:
431 case POLYNOM :
432 erg += add_polynom(a,b,d);
433 break;
434 case MONOM :
435 erg += add_monom(a,b,d);
436 break;
437 #endif /* POLYTRUE */
438 #ifdef VECTORTRUE
439 case INTEGERVECTOR:
440 erg += add_integervector(a,b,d);
441 break;
442 case VECTOR :
443 erg += add_vector(a,b,d);
444 break;
445 #endif /* VECTORTRUE */
446 #ifdef SCHURTRUE
447 case SCHUR :
448 erg += add_schur(a,b,d);
449 break;
450 #endif /* SCHURTRUE */
451 #ifdef LONGINTTRUE
452 case LONGINT :
453 erg += add_longint(a,b,d);
454 break;
455 #endif /* LONGINTTRUE */
456 #ifdef MATRIXTRUE
457 case KRANZTYPUS:
458 case INTEGERMATRIX:
459 case MATRIX :
460 erg += add_matrix(a,b,d);
461 break;
462 #endif /* MATRIXTRUE */
463 #ifdef MONOMIALTRUE
464 case MONOMIAL :
465 erg += add_monomial(a,b,d);
466 break;
467 #endif /* MONOMIALTRUE */
468 #ifdef ELMSYMTRUE
469 case ELM_SYM :
470 erg += add_elmsym(a,b,d);
471 break;
472 #endif /* ELMSYMTRUE */
473 #ifdef HOMSYMTRUE
474 case HOM_SYM :
475 erg += add_homsym(a,b,d);
476 break;
477 #endif /* HOMSYMTRUE */
478 #ifdef POWSYMTRUE
479 case POW_SYM :
480 erg += add_powsym(a,b,d);
481 break;
482 #endif /* POWSYMTRUE */
483 #ifdef SCHUBERTTRUE
484 case SCHUBERT:
485 erg += add_schubert(a,b,d);
486 break;
487 #ifdef UNDEF
488 {
489 switch(S_O_K(b))
490 {
491 case SCHUBERT :
492 erg += add_schubert_schubert(
493 a,b,d);
494 break;
495 default :
496 {
497 printobjectkind(b);
498 return error("add_schubert:wrong second type");
499 }
500 };
501 break;
502 }
503 #endif
504 #endif /* SCHUBERTTRUE */
505 #ifdef CHARTRUE
506 case SYMCHAR:
507 erg += add_symchar(a,b,d);
508 break;
509 #endif
510 #ifdef BRUCHTRUE
511 case BRUCH :
512 erg += add_bruch (a,b,d);
513 break;
514 #endif /* BRUCHTRUE */
515 default:
516 {
517 if (nullp(a)) {
518 erg += copy(b,d);
519 break;
520 }
521 if (nullp(b)) {
522 erg += copy(a,d);
523 break;
524 }
525 printobjectkind(a);
526 printobjectkind(b);
527 return error("add: wrong types");
528 }
529 };
530 add_ende:
531 ENDR("add");
532 }
533
SYM_sort(a)534 INT SYM_sort(a) OP a;
535 /* sortiert das object in aufsteigender reihenfolge AK 270787 */
536 /* AK 160986 */ /* AK 280689 V1.0 */ /* AK 050390 V1.1 */
537 /* AK 070891 V1.3 */
538 {
539 INT erg = OK;
540 EOP("SYM_sort(1)",a);
541
542 switch(S_O_K(a))
543 {
544 #ifdef VECTORTRUE
545 case INTEGERVECTOR:
546 case VECTOR :
547 erg += sort_vector(a);break;
548 #endif /* VECTORTRUE */
549 default:
550 erg += WTO("SYM_sort",a); break;
551 };
552 ENDR("SYM_sort");
553 }
554
length(a,d)555 INT length(a,d) OP a,d;
556 /* 160986 */ /* AK 280689 V1.0 */ /* AK 050390 V1.1 */
557 /* AK 140891 V1.3 */
558 /* AK 240398 V2.0 */
559 {
560 INT erg = OK;
561 EOP("length(1)",a);
562 COP("length(2)",d);
563 CE2(a,d,length);
564
565 switch(S_O_K(a))
566 {
567 #ifdef BINTREETRUE
568 case BINTREE :
569 erg += length_bintree(a,d);
570 break;
571 #endif /* PARTTRUE */
572 #ifdef LISTTRUE
573 case GRAL:
574 case HOM_SYM:
575 case POW_SYM:
576 case ELM_SYM:
577 case MONOMIAL:
578 case LIST:
579 case POLYNOM:
580 case MONOPOLY: /* MD */
581 case SCHUBERT:
582 case SCHUR:
583 erg += length_list(a,d);
584 break;
585 #endif /* LISTTRUE */
586 #ifdef PARTTRUE
587 case PARTITION :
588 erg += length_partition(a,d);
589 break;
590 #endif /* PARTTRUE */
591 #ifdef PERMTRUE
592 case PERMUTATION :
593 erg += length_permutation(a,d);
594 break;
595 #endif /* PERMTRUE */
596 #ifdef REIHETRUE
597 case REIHE :
598 erg += length_reihe(a,d);
599 break;
600 #endif /* REIHETRUE */
601 #ifdef SKEWPARTTRUE
602 case SKEWPARTITION :
603 erg += length_skewpartition(a,d);
604 break;
605 #endif /* SKEWPARTTRUE */
606 #ifdef VECTORTRUE
607 case WORD:
608 case COMPOSITION:
609 case INTEGERVECTOR:
610 case VECTOR :
611 erg += length_vector(a,d);
612 break;
613 #endif /* VECTORTRUE */
614 default:
615 erg += WTO("length",a); break;
616 };
617 ENDR("length");
618 }
619
content(a,b)620 INT content(a,b) OP a,b;
621 /* AK 280689 V1.0 */ /* AK 050390 V1.1 */ /* AK 140891 V1.3 */
622 /* AK 240398 V2.0 */
623 {
624 INT erg=OK;
625 CE2(a,b,content);
626 switch(S_O_K(a))
627 {
628 #ifdef TABLEAUXTRUE
629 case TABLEAUX :
630 erg += content_tableaux(a,b );
631 break;
632 #endif /* TABLEAUXTRUE */
633 #ifdef WORDTRUE
634 case WORD :
635 erg += content_word(a,b);
636 break;
637 #endif /* WORDTRUE */
638 default:
639 erg += WTO("content",a); break;
640 };
641 ENDR("content");
642 }
643
SYM_sum(a,res)644 INT SYM_sum(a,res) OP a,res;
645 /* AK 280689 V1.0 */ /* AK 050390 V1.1 */ /* AK 120391 V1.2 */
646 /* AK 140891 V1.3 */
647 /* AK 170298 V2.0 */
648 {
649 INT erg = OK;
650 COP("sum(1)",a);
651 COP("sum(2)",res);
652 CE2(a,res,SYM_sum);
653
654 switch(S_O_K(a))
655 {
656 #ifdef VECTORTRUE
657 case INTEGERVECTOR:
658 case SUBSET:
659 case COMPOSITION :
660 erg += sum_integervector(a,res);
661 break;
662 case VECTOR :
663 erg += sum_vector(a,res);
664 break;
665 #endif /* VECTORTRUE */
666 #ifdef PARTTRUE
667 case PARTITION:
668 erg += weight_partition(a,res);
669 break;
670 #endif /* PARTTRUE */
671 #ifdef MATRIXTRUE
672 case MATRIX :
673 case KOSTKA :
674 case KRANZTYPUS :
675 case INTEGERMATRIX :
676 erg += sum_matrix(a,res);
677 break;
678 #endif /* MATRIXTRUE */
679 default:
680 erg += WTO("sum",a); break;
681 };
682
683 ENDR("SYM_sum");
684 }
685
686
conjugate(a,res)687 INT conjugate(a,res) OP a,res;
688 /* AK 280689 V1.0 */ /* AK 281289 V1.1 */ /* AK 120891 V1.3 */
689 /* AK V2.0 170298 */
690 {
691 INT erg = OK;
692 COP("conjugate(1)",a);
693 COP("conjugate(2)",res);
694
695 CE2(a,res,conjugate);
696 switch(S_O_K(a))
697 {
698 #ifdef PARTTRUE
699 case PARTITION:
700 erg += conjugate_partition(a,res);
701 break;
702 #endif /* PARTTRUE */
703
704 #ifdef SKEWPARTTRUE
705 case SKEWPARTITION : /* AK 020890 V1.1 */
706 erg += b_gk_spa(
707 callocobject(), callocobject(), res);
708 erg += conjugate_partition(S_SPA_G(a),S_SPA_G(res));
709 erg += conjugate_partition(S_SPA_K(a),S_SPA_K(res));
710 break;
711 #endif /* SKEWPARTTRUE */
712
713 #ifdef MONOMTRUE
714 case MONOM:
715 erg += b_sk_mo(callocobject(),callocobject(),res);
716 erg += copy(S_MO_K(a),S_MO_K(res));
717 erg += conjugate(S_MO_S(a),S_MO_S(res));
718 break;
719 #endif /* MONOMTRUE */
720
721 #ifdef SCHURTRUE
722 case SCHUR:
723 erg += conjugate_schur(a,res);
724 break;
725 case MONOMIAL:
726 erg += conjugate_monomial(a,res);
727 break;
728 case HOM_SYM:
729 erg += conjugate_homsym(a,res);
730 break;
731 case ELM_SYM:
732 erg += conjugate_elmsym(a,res);
733 break;
734 case POW_SYM:
735 erg += conjugate_powsym(a,res);
736 break;
737 #endif /* SCHURTRUE */
738
739 #ifdef TABLEAUXTRUE
740 case TABLEAUX:
741 erg += conjugate_tableaux(a,res,conjugate);
742 break;
743 #endif /* TABLEAUXTRUE */
744 default:
745 erg += WTO("conjugate",a);
746 break;
747 };
748
749 ENDR("conjugate");
750 }
751
752
addinvers(a,res)753 INT addinvers(a,res) OP a,res;
754 /* AK 280689 V1.0 */ /* AK 131289 V1.1 */ /* AK 270291 V1.2 */
755 /* AK 140891 V1.3 */
756 {
757 INT erg = OK;
758 COP("addinvers(1)",a);
759 COP("addinvers(2)",res);
760 CE2(a,res,addinvers);
761
762 switch(S_O_K(a))
763 {
764 #ifdef BRUCHTRUE
765 case BRUCH :
766 erg += addinvers_bruch(a,res);
767 break;
768 #endif /* BRUCHTRUE */
769 #ifdef CYCLOTRUE
770 case CYCLOTOMIC:
771 erg += addinvers_cyclo (a,res);
772 break;
773 #endif /* CYCLOTRUE */
774 #ifdef FFTRUE
775 case FF :
776 erg += addinvers_ff(a,res);
777 break;
778 #endif /* FFTRUE */
779 #ifdef INTEGERTRUE
780 case INTEGER :
781 erg+= addinvers_integer(a,res);
782 break;
783 #endif /* INTEGERTRUE */
784 #ifdef LONGINTTRUE
785 case LONGINT :
786 erg+= addinvers_longint(a,res);
787 break;
788 #endif /* LONGINTTRUE */
789 #ifdef MATRIXTRUE
790 case MATRIX :
791 erg+= addinvers_matrix(a,res);
792 break;
793 #endif /* MATRIXTRUE */
794 #ifdef MONOMTRUE
795 case MONOM :
796 erg+= addinvers_monom(a,res);
797 break;
798 #endif /* MONOMTRUE */
799 #ifdef MONOPOLYTRUE
800 case MONOPOLY:
801 erg+= addinvers_monopoly (a,res);
802 break;
803 #endif /* MONOPOLYTRUE */
804 #ifdef POLYTRUE
805 case ELM_SYM:
806 case POW_SYM:
807 case MONOMIAL:
808 case HOM_SYM:
809 case SCHUR:
810 case SCHUBERT:
811 case GRAL:
812 case POLYNOM :
813 erg += addinvers_polynom(a,res);
814 break;
815 #endif /* POLYTRUE */
816 #ifdef REIHETRUE /* AK 020893 */
817 case REIHE :
818 erg += addinvers_reihe(a,res);
819 break;
820 #endif /* REIHETRUE */
821 #ifdef SQRADTRUE
822 case SQ_RADICAL:
823 erg+= addinvers_sqrad (a,res);
824 break;
825 #endif /* SQRADTRUE */
826 #ifdef CHARTRUE
827 case SYMCHAR :
828 erg += addinvers_symchar(a,res);
829 break;
830 #endif /* CHARTRUE */
831 #ifdef VECTORTRUE
832 case INTEGERVECTOR:
833 case VECTOR :
834 erg += addinvers_vector(a,res);
835 break;
836 #endif /* VECTORTRUE */
837 default:
838 erg += WTO("addinvers(1)",a); break;
839 };
840 ENDR("addinvers");
841 }
842
843
844
845
846 INT binom_values[BINOMLIMIT][BINOMLIMIT] = {
847 {1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,0},
848 {1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,0},
849 {1, 2, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,0},
850 {1, 3, 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,0},
851 {1, 4, 6, 4, 1, 0, 0, 0, 0, 0, 0, 0,0},
852 {1, 5,10, 10, 5, 1, 0, 0, 0, 0, 0, 0,0},
853 {1, 6,15, 20, 15, 6, 1, 0, 0, 0, 0, 0,0},
854 {1, 7,21, 35, 35, 21, 7, 1, 0, 0, 0, 0,0},
855 {1, 8,28, 56, 70, 56, 28, 8, 1, 0, 0, 0,0},
856 {1, 9,36, 84,126,126, 84, 36, 9, 1, 0, 0,0},
857 {1,10,45,120,210,252,210,120, 45, 10, 1, 0,0},
858 {1,11,55,165,330,462,462,330,165, 55,11, 1,0},
859 {1,12,66,220,495,792,924,792,495,220,66,12,1} };
860
binom_small(oben,unten,d)861 INT binom_small(oben,unten,d) OP oben, unten, d;
862 /* we know 0<= oben <= BINOMLIMIT
863 0<= unten
864 all three a different, d is freed */
865 {
866 INT erg = OK;
867 CTO(INTEGER,"binom_small",oben);
868 CTO(INTEGER,"binom_small",unten);
869 CTO(EMPTY,"binom_small",d);
870 SYMCHECK(S_I_I(oben) < 0 ,"binom_small:oben <0");
871 SYMCHECK(S_I_I(oben) > BINOMLIMIT ,"binom_small:oben > BINOMLIMIT");
872 SYMCHECK(S_I_I(unten) < 0 ,"binom_small:unten <0");
873
874 if (S_I_I(unten) > S_I_I(oben))
875 M_I_I(0,d);
876 else
877 M_I_I( binom_values [ S_I_I(oben) ] [S_I_I(unten)] ,d);
878 ENDR("binom_small");
879 }
880
binom(oben,unten,d)881 INT binom(oben , unten, d) OP oben, unten, d;
882 /* AK 041186 */
883 /* d = oben ! / unten ! * (oben -unten)! */
884 /* auf integer umgestellt am 120187 */
885 /* AK 280689 V1.0 */ /* AK 010290 V1.1 */
886 /* AK 140891 V1.3 */
887 /* AK 030892 oben may be POLYNOM */
888 /* AK 160703 oben or unten may be equal to d */
889 {
890 OP a,b,c;
891 INT i,ui;
892 INT erg = OK;
893 CTO(INTEGER,"binom(2)",unten);
894 SYMCHECK(S_I_I(unten) < 0,"binom:unten < 0");
895 ui = S_I_I(unten);
896
897 if (unten == d) /* AK160703 */
898 {
899 a = CALLOCOBJECT();
900 SWAP(a,d);
901 erg += binom(oben,a,d);
902 FREEALL(a);
903 goto ende;
904 }
905 if (oben == d) /* AK160703 */
906 {
907 a = CALLOCOBJECT();
908 SWAP(a,d);
909 erg += binom(a,unten,d);
910 FREEALL(a);
911 goto ende;
912 }
913
914 if (S_O_K(oben) == POLYNOM) /* AK 030892 */
915 {
916 CALLOCOBJECT2(c,b);
917 COPY(oben,c);
918 M_I_I(-1,b);
919 CLEVER_COPY(oben,d);
920 for (i=1;i<ui;i++)
921 {
922 ADD_APPLY(b,c);
923 MULT_APPLY(c,d);
924 }
925 erg += fakul(unten,c);
926 erg += invers_apply(c);
927 MULT_APPLY(c,d);
928 FREEALL2(c,b);
929 goto ende;
930 }
931
932 CTO(INTEGER,"binom(i1)",oben);
933
934 if (oben == d)
935 {
936 c = callocobject();
937 *c = *oben;
938 C_O_K(d,EMPTY);
939 erg += binom(c,unten,d);
940 erg += freeall(c);
941 goto ende;
942 }
943
944 if (unten == d)
945 {
946 c = callocobject();
947 *c = *unten;
948 C_O_K(d,EMPTY);
949 erg += binom(oben,c,d);
950 erg += freeall(c);
951 goto ende;
952 }
953
954 if (not EMPTYP(d))
955 freeself(d);
956
957 if (S_I_I(oben) == (-1L))
958 {
959 (S_I_I(unten) % 2L == 0L ?
960 M_I_I(1L,d) :
961 M_I_I(-1L,d));
962 goto ende;
963 }
964
965 if (S_I_I(oben)<0)
966 {
967 INT schalter = 0L;
968 b = callocobject();
969 c = callocobject();
970 a = callocobject();
971 COPY_INTEGER(unten,b);
972 COPY_INTEGER(oben,a);
973 INC_INTEGER(a);
974 while(S_I_I(b) >= 0L)
975 {
976 binom(a,b,c);
977 (schalter++ % 2L == 0L ? add(c,d,d):
978 sub(d,c,d));
979 dec(b);
980 };
981 FREEALL(c);
982 goto binomende;
983 }
984
985
986
987 if (S_I_I(oben)==S_I_I(unten)) { M_I_I(1L,d); goto ende;}
988 if (S_I_I(oben)<S_I_I(unten)) { M_I_I(0L,d); goto ende;}
989
990
991 a = CALLOCOBJECT();
992 b = CALLOCOBJECT();
993 M_I_I(S_I_I(oben) - S_I_I(unten),a);
994 erg += fakul(a,b);
995 /* now multiplying the remaining part */
996 FREESELF(d);
997 M_I_I(1,d);
998 for (i=S_I_I(oben);i>S_I_I(unten);i--)
999 {
1000 M_I_I(i,a);
1001 MULT_APPLY_INTEGER(a,d);
1002 }
1003 GANZDIV_APPLY(d,b); /* d = d/b */
1004 binomende:
1005 FREEALL(a);
1006 FREEALL(b);
1007 ende:
1008 ENDR("binom");
1009 }
1010
1011
inc(a)1012 INT inc(a) OP a;
1013 /* AK 280689 V1.0 */ /* AK 081289 V1.1 */ /* AK 140891 V1.3 */
1014 {
1015 INT erg = OK;
1016 EOP("inc(1)",a);
1017 switch(S_O_K(a))
1018 {
1019 #ifdef INTEGERTRUE
1020 case INTEGER :
1021 INC_INTEGER(a);
1022 break;
1023 #endif /* INTEGERTRUE */
1024
1025 #ifdef LONGINTTRUE
1026 case LONGINT :
1027 erg += inc_longint(a);
1028 break;
1029 #endif /* LONGINTTRUE */
1030
1031 #ifdef MATRIXTRUE
1032 case KRANZTYPUS:
1033 case INTEGERMATRIX:
1034 case MATRIX :
1035 erg += inc_matrix(a);
1036 break;
1037 #endif /* MATRIXTRUE */
1038
1039 #ifdef PARTTRUE
1040 case PARTITION :
1041 INC_PARTITION(a);
1042 break;
1043 #endif /* PARTTRUE */
1044
1045 #ifdef PERMTRUE
1046 case PERMUTATION :
1047 erg += inc_permutation(a);
1048 break;
1049 #endif /* PERMTRUE */
1050
1051 #ifdef REIHETRUE
1052 case REIHE :
1053 erg += inc_reihe(a);
1054 break;
1055 #endif /* REIHETRUE */
1056
1057 #ifdef TABLEAUXTRUE
1058 case TABLEAUX :
1059 erg += inc_tableaux(a);
1060 break;
1061 #endif /* TABLEAUXTRUE */
1062
1063 #ifdef VECTORTRUE
1064 case INTEGERVECTOR:
1065 case SUBSET:
1066 case COMPOSITION:
1067 case VECTOR :
1068 erg += inc_vector(a);
1069 break;
1070 case BITVECTOR:
1071 erg += inc_bitvector(a);
1072 break;
1073 #endif /* VECTORTRUE */
1074
1075 default:
1076 erg += WTO("inc(1)",a);
1077 break;
1078 };
1079 ENDR("inc");
1080 }
1081
dec(a)1082 INT dec(a) OP a;
1083 /* AK 280689 V1.0 */ /* AK 131289 V1.1 */ /* AK 140891 V1.3 */
1084 {
1085 INT erg = OK;
1086 EOP("dec(1)",a);
1087 switch(S_O_K(a))
1088 {
1089 #ifdef INTEGERTRUE
1090 case INTEGER :
1091 erg += dec_integer(a);
1092 break;
1093 #endif /* INTEGERTRUE */
1094 #ifdef LONGINTTRUE
1095 case LONGINT :
1096 erg += dec_longint(a);
1097 break;
1098 #endif /* LONGINTTRUE */
1099 #ifdef PARTTRUE
1100 case PARTITION :
1101 erg += dec_partition(a);
1102 break;
1103 #endif /* PARTTRUE */
1104 #ifdef PERMTRUE
1105 case PERMUTATION :
1106 erg += dec_permutation(a);
1107 break;
1108 #endif /* PERMTRUE */
1109 #ifdef VECTORTRUE
1110 case INTEGERVECTOR:
1111 erg += dec_integervector(a);
1112 break;
1113 case VECTOR :
1114 erg += dec_vector(a);
1115 break;
1116 #endif /* VECTORTRUE */
1117 default:
1118 erg += WTO("dec(1)",a); break;
1119 };
1120 ENDR("dec");
1121 }
1122
1123
qdimension(n,d)1124 INT qdimension(n,d) OP n, d;
1125 /* AL 180393 */
1126 {
1127 INT erg = OK;
1128 EOP("qdimension(1)",n);
1129 COP("qdimension(2)",d);
1130 CE2(n,d,qdimension);
1131
1132 switch (S_O_K(n))
1133 {
1134 #ifdef SCHUBERTTRUE /* AL 180393 */
1135 case SCHUBERT:
1136 erg += dimension_schubert(n,d);
1137 break;
1138 #endif /* SCHUBERTTRUE */
1139 default:
1140 WTO("qdimension(1)",n);
1141 break;
1142 }
1143 ENDR("qdimension");
1144 }
1145
1146
dimension(n,d)1147 INT dimension(n,d) OP n, d;
1148 /* AK 011288 */ /* AK 060789 V1.0 */ /* AK 131289 V1.1 */
1149 /* AK 140891 V1.3 */
1150 {
1151 INT erg = OK;
1152 EOP("dimension(1)",n);
1153 COP("dimension(2)",d);
1154 CE2(n,d,dimension);
1155
1156 switch (S_O_K(n))
1157 {
1158 #ifdef PARTTRUE
1159 case AUG_PART:
1160 erg += dimension_augpart(n,d);
1161 break;
1162 case PARTITION:
1163 erg += dimension_partition(n,d);
1164 break;
1165 #endif /* PARTTRUE */
1166 #ifdef SCHUBERTTRUE /* AL 180393 */
1167 case SCHUBERT:
1168 erg += dimension_schubert(n,d);
1169 break;
1170 #endif /* SCHUBERTTRUE */
1171 #ifdef SCHURTRUE /* AK 020890 V1.1 */
1172 case SCHUR:
1173 erg += dimension_schur(n,d);
1174 break;
1175 #endif /* SCHURTRUE */
1176 #ifdef SKEWPARTTRUE /* AK 020890 V1.1 */
1177 case SKEWPARTITION:
1178 erg += dimension_skewpartition(n,d);
1179 break;
1180 #endif /* SKEWPARTTRUE */
1181 default:
1182 erg += WTO("dimension",n); break;
1183 }
1184 ENDR("dimension");
1185 }
1186
1187
div(a,b,c)1188 INT div(a,b,c) OP a,b,c;
1189 /* exact division */
1190 {
1191 INT erg = OK;
1192 EOP("div(1)",a);
1193 EOP("div(2)",b);
1194 COP("div(3)",c);
1195 CE3(a,b,c,div);
1196 switch(S_O_K(a)) {
1197 default:
1198 erg += div_default(a,b,c);
1199 break;
1200 }
1201 ENDR("div");
1202 }
1203
div_default(a,b,d)1204 INT div_default(a,b,d) OP a,b,d;
1205 /* AK 280689 V1.0 */ /* AK 071289 V1.1 */ /* AK 250391 V1.2 */
1206 /* AK 140891 V1.3 */
1207 /* d := a/b */
1208 {
1209 /* AK 031286 als invers*mult */
1210 INT erg = OK;
1211 OP c;
1212 CTO(ANYTYPE,"div_default(1)",a);
1213 CTO(ANYTYPE,"div_default(2)",b);
1214 CTO(EMPTY,"div_default(3)",d);
1215 c = CALLOCOBJECT();
1216 INVERS(b,c);
1217 MULT(a,c,d);
1218 FREEALL(c);
1219
1220 CTO(ANYTYPE,"div_default(e3)",d);
1221 ENDR("div_default");
1222 }
1223
1224
quores(a,b,c,d)1225 INT quores(a,b,c,d) OP a,b,c,d;
1226 /* c = ganzdiv(a,b) d = mod(a,b) */
1227 /* AK 050291 V1.2 */ /* AK 140891 V1.3 */
1228 {
1229 OP e;
1230 INT erg=OK;
1231 SYMCHECK( c == d ,"quores: two result in one variable");
1232
1233 if (a == c)
1234 {
1235 e =CALLOCOBJECT();
1236 *e = *a;
1237 C_O_K(c,EMPTY);
1238 erg +=quores(e,b,c,d);
1239 FREEALL(e);
1240 goto quoresende;
1241 }
1242 if (a == d)
1243 {
1244 e =CALLOCOBJECT();
1245 *e = *a;
1246 C_O_K(d,EMPTY);
1247 erg +=quores(e,b,c,d);
1248 FREEALL(e);
1249 goto quoresende;
1250 }
1251 if (b == c)
1252 {
1253 e =CALLOCOBJECT();
1254 *e = *b;
1255 C_O_K(c,EMPTY);
1256 erg +=quores(a,e,c,d);
1257 FREEALL(e);
1258 goto quoresende;
1259 }
1260 if (b == d)
1261 {
1262 e =CALLOCOBJECT();
1263 *e = *b;
1264 C_O_K(d,EMPTY);
1265 erg +=quores(a,e,c,d);
1266 FREEALL(e);
1267 goto quoresende;
1268 }
1269 if (not EMPTYP(d))
1270 erg += freeself(d);
1271 if (not EMPTYP(c))
1272 erg += freeself(c);
1273 if (EMPTYP(a) || EMPTYP(b))
1274 goto quoresende;
1275
1276 if (nullp(b))
1277 {
1278 debugprint(a);
1279 debugprint(b);
1280 error("quores:null division");
1281 goto endr_ende;
1282 }
1283 if (einsp(b))
1284 {
1285 erg += copy(a,c);
1286 erg += null(a,d); /* AK 170206 */
1287 goto quoresende;
1288 }
1289
1290
1291 switch(S_O_K(a))
1292 {
1293 #ifdef INTEGERTRUE
1294 case INTEGER :
1295 erg += quores_integer(a,b,c,d);break;
1296 #endif /* INTEGERTRUE */
1297 #ifdef LONGINTTRUE
1298 case LONGINT :
1299 erg += quores_longint(a,b,c,d);break;
1300 #endif /* LONGINTTRUE */
1301 #ifdef MONOPOLYTRUE
1302 case MONOPOLY :
1303 erg += quores_monopoly(a,b,c,d);break;
1304 case POLYNOM:
1305 {
1306 OP aa,bb,cc,dd;
1307 aa = CALLOCOBJECT();
1308 bb = CALLOCOBJECT();
1309 cc = CALLOCOBJECT();
1310 dd = CALLOCOBJECT();
1311 t_POLYNOM_MONOPOLY(a,aa);
1312 t_POLYNOM_MONOPOLY(b,bb);
1313 erg += quores_monopoly(aa,bb,cc,dd);
1314 t_MONOPOLY_POLYNOM(cc,c);
1315 t_MONOPOLY_POLYNOM(dd,d);
1316 FREEALL4(aa,bb,cc,dd);
1317 break;
1318 }
1319 #endif /* MONOPOLYTRUE */
1320 default:
1321 erg += WTT("quores",a,b);
1322 break;
1323 }
1324 quoresende:
1325 ENDR("quores");
1326 }
1327
mod(a,b,c)1328 INT mod(a,b,c) OP a,b,c;
1329 /* AK 040393 */
1330 /* AK 030498 V2.0 */
1331 /* c := a % b; */
1332 {
1333 OP d;
1334 INT erg = OK;
1335 EOP("mod(1)",a);
1336 EOP("mod(2)",b);
1337 SYMCHECK(NULLP(b),"mod: second parameter = zero");
1338
1339 CE3(a,b,c,mod);
1340
1341 if (matrixp(a)) /* AK 300793 */
1342 {
1343 if (S_O_K(b) == INTEGER)
1344 {
1345 erg += mod_matrix(a,b,c);
1346 goto endr_ende;
1347 }
1348 }
1349 else if (vectorp(a)) /* AK 101198 */
1350 {
1351 if (S_O_K(b) == INTEGER)
1352 {
1353 erg += mod_vector(a,b,c);
1354 goto endr_ende;
1355 }
1356 }
1357 else if (S_O_K(a)==MONOM)
1358 {
1359 erg += mod_monom(a,b,c);
1360 goto endr_ende;
1361 }
1362 else if (S_O_K(a)==POLYNOM)
1363 {
1364 erg += mod_polynom(a,b,c);
1365 goto endr_ende;
1366 }
1367 else if (LISTP(a))
1368 {
1369 OP s,k,z;
1370 erg += init(S_O_K(a),c);
1371 FORALL(z,a,{
1372 k = CALLOCOBJECT();
1373 erg += mod(S_MO_K(z),b,k);
1374 if (NULLP(k) ) FREEALL(k);
1375 else {
1376 s = CALLOCOBJECT();
1377 b_sk_mo(CALLOCOBJECT(),k,s);
1378 COPY(S_MO_S(z),S_MO_S(s));
1379 insert(s,c,NULL,NULL);
1380 }
1381 });
1382 goto endr_ende;
1383 }
1384
1385 d = CALLOCOBJECT();
1386 if (S_O_K(a) == INTEGER)
1387 erg += quores_integer(a,b,d,c);
1388 else if (S_O_K(a) == LONGINT)
1389 erg += quores_longint(a,b,d,c);
1390 else if (S_O_K(a) == MONOPOLY)
1391 erg += quores_monopoly(a,b,d,c);
1392 else
1393 erg += WTO("mod",a);
1394
1395 FREEALL(d);
1396 ENDR("mod");
1397 }
1398
ganzdiv(a,b,c)1399 INT ganzdiv(a,b,c) OP a,b,c;
1400 /*AK 040393 */
1401 /* c := a/b */
1402 {
1403 OP d ;
1404 INT erg = OK;
1405
1406 if (a == b) { m_i_i(1,c); goto endr_ende; }
1407 CE3(a,b,c,ganzdiv);
1408
1409 d = callocobject();
1410 if (S_O_K(a) == INTEGER)
1411 erg += quores_integer(a,b,c,d);
1412 else if (S_O_K(a) == LONGINT)
1413 erg += quores_longint(a,b,c,d);
1414 else if (S_O_K(a) == MONOPOLY)
1415 erg += quores_monopoly(a,b,c,d);
1416 else
1417 WTO("ganzdiv",a);
1418 erg += freeall(d);
1419 ENDR("ganzdiv");
1420 }
1421
ganzdiv_longint(a,b,c)1422 INT ganzdiv_longint(a,b,c) OP a,b,c;
1423 /* AK 051001 */
1424 /* c = a/b */
1425 {
1426 INT erg = OK;
1427 OP d;
1428 CTO(LONGINT,"ganzdiv_longint(1)",a);
1429 CTO(EMPTY,"ganzdiv_longint(3)",c);
1430
1431 d = callocobject();
1432 erg += quores_longint(a,b,c,d);
1433 erg += freeall(d);
1434
1435 ENDR("ganzdiv_longint");
1436 }
1437
ganzdiv_integer_integer(a,b,c)1438 INT ganzdiv_integer_integer(a,b,c) OP a,b,c;
1439 /* AK 291001 */
1440 {
1441 INT erg = OK;
1442 CTO(INTEGER,"ganzdiv_integer_integer(1)",a);
1443 CTO(INTEGER,"ganzdiv_integer_integer(2)",b);
1444 CTO(EMPTY,"ganzdiv_integer_integer(3)",c);
1445 M_I_I(S_I_I(a) / S_I_I(b),c);
1446 ENDR("ganzdiv_integer_integer");
1447 }
1448
ganzdiv_integer(a,b,c)1449 INT ganzdiv_integer(a,b,c) OP a,b,c;
1450 /* AK 051001 */
1451 /* a is INTEGER */
1452 {
1453 INT erg = OK;
1454 OP d;
1455 CTO(INTEGER,"ganzdiv_integer(1)",a);
1456 CTO(EMPTY,"ganzdiv_integer(2)",c);
1457
1458 if (S_O_K(b) == INTEGER) {
1459 M_I_I(S_I_I(a) / S_I_I(b),c);
1460 }
1461
1462 else {
1463 d = CALLOCOBJECT();
1464 erg += quores_integer(a,b,c,d);
1465 FREEALL(d);
1466 }
1467 ENDR("ganzdiv_integer");
1468 }
1469
mod_apply_integer(a,b)1470 INT mod_apply_integer(a,b) OP a,b;
1471 /* AK 011101 */
1472 /* a = a mod b */
1473 {
1474 INT erg = OK;
1475 CTO(INTEGER,"mod_apply_integer(1)",a);
1476 switch(S_O_K(b)) {
1477 case INTEGER:
1478 M_I_I(S_I_I(a) % S_I_I(b), a);
1479 break;
1480 case LONGINT:
1481 erg += mod_apply_integer_longint(a,b);
1482 break;
1483 default:
1484 erg += WTO("mod_apply_integer(2)",b);
1485 break;
1486 }
1487 ENDR("mod_apply_integer");
1488 }
1489
1490
mod_apply(a,b)1491 INT mod_apply(a,b) OP a,b;
1492 /* AK 051001 */
1493 /* a := a mod b */
1494 /* a and b may be identic */
1495 {
1496 INT erg = OK;
1497 OP c;
1498 EOP("mod_apply(1)",a);
1499 EOP("mod_apply(2)",b);
1500
1501 if (a == b) {
1502 erg += m_i_i(0,a);
1503 goto endr_ende;
1504 }
1505 switch(S_O_K(a)) {
1506 case INTEGER:
1507 erg += mod_apply_integer(a,b);
1508 goto endr_ende;
1509 case LONGINT:
1510 erg += mod_apply_longint(a,b);
1511 goto endr_ende;
1512 default:
1513 break;
1514 }
1515
1516 c = callocobject();
1517 erg += swap(a,c);
1518 erg += mod(c,b,a);
1519 erg += freeall(c);
1520 ENDR("mod_apply");
1521 }
1522
ganzdiv_apply_integer(a,b)1523 INT ganzdiv_apply_integer(a,b) OP a,b;
1524 /* AK 011101 */
1525 /* a := a/b */
1526 {
1527 INT erg = OK;
1528 CTO(INTEGER,"ganzdiv_apply_integer(1)",a);
1529 switch (S_O_K(b) )
1530 {
1531 case INTEGER:
1532 M_I_I(S_I_I(a)/S_I_I(b),a);
1533 break;
1534 default: {
1535 OP c;
1536 c = CALLOCOBJECT();
1537 *c = *a;
1538 C_O_K(a,EMPTY);
1539 erg += ganzdiv_integer(c,b,a);
1540 FREEALL(c);
1541 }
1542 break;
1543 }
1544 ENDR("ganzdiv_apply_integer");
1545 }
1546
1547
div_apply_integer(a,b)1548 INT div_apply_integer(a,b) OP a,b;
1549 /* AK 011101 */
1550 /* a = a / b */
1551 {
1552 INT erg = OK;
1553 CTO(INTEGER,"div_apply_integer(1)",a);
1554 switch (S_O_K(b) )
1555 {
1556 case INTEGER:
1557 if (S_I_I(b) == 1);
1558 else if (S_I_I(b) == -1)
1559 ADDINVERS_APPLY(a);
1560 else if ((S_I_I(a) % S_I_I(b)) == 0)
1561 M_I_I(S_I_I(a)/S_I_I(b),a);
1562 else
1563 {
1564 erg += m_ioiu_b(S_I_I(a),S_I_I(b),a);
1565 erg += kuerzen(a);
1566 }
1567 break;
1568 default: {
1569 OP c;
1570 c = CALLOCOBJECT();
1571 *c = *a;
1572 C_O_K(a,EMPTY);
1573 erg += div(c,b,a);
1574 FREEALL(c);
1575 }
1576 break;
1577 }
1578 ENDR("div_apply_integer");
1579 }
1580
1581
1582
ganzdiv_apply(a,b)1583 INT ganzdiv_apply(a,b) OP a,b;
1584 /* AK 151294 */
1585 /* a := a/b */
1586 /* a and b may be identic */
1587 {
1588 INT erg = OK;
1589 EOP("ganzdiv_apply",a);
1590 EOP("ganzdiv_apply",b);
1591
1592 if (a == b)
1593 {
1594 erg += m_i_i((INT)1,a);
1595 goto endr_ende;
1596 }
1597
1598 switch(S_O_K(a))
1599 {
1600 case INTEGER:
1601 erg += ganzdiv_apply_integer(a,b);
1602 break;
1603 case LONGINT:
1604 erg += ganzdiv_apply_longint(a,b);
1605 break;
1606 default:
1607 {
1608 OP c;
1609 c = CALLOCOBJECT();
1610 *c = *a;
1611 C_O_K(a,EMPTY);
1612 erg += ganzdiv(c,b,a);
1613 FREEALL(c);
1614 }
1615 break;
1616 }
1617 ENDR("ganzdiv_apply");
1618 }
1619
div_apply(a,b)1620 INT div_apply(a,b) OP a,b;
1621 /* AK 151294 */
1622 /* a := a/b */
1623 /* a and b may be identic */
1624 /* AK 291104 V3.0 */
1625 {
1626 INT erg = OK;
1627 EOP("div_apply(1)",a);
1628 EOP("div_apply(2)",b);
1629
1630 if (a == b)
1631 erg += eins(a,a);
1632 else {
1633 switch(S_O_K(a))
1634 {
1635 case INTEGER:
1636 erg += div_apply_integer(a,b);
1637 break;
1638 default:
1639 {
1640 OP c;
1641 c = CALLOCOBJECT();
1642 *c = *a;
1643 C_O_K(a,EMPTY);
1644 erg += div(c,b,a);
1645 FREEALL(c);
1646 }
1647 break;
1648 }
1649 }
1650 ENDR("div_apply");
1651 }
1652
1653
1654
1655
fakul(n,d)1656 INT fakul(n,d) OP n, d;
1657 /* AK 081086 */ /* d = n! */ /* auf integer umgestellt 120187 */
1658 /* AK 280689 V1.0 */ /* AK 181289 V1.1 */ /* AK 060391 V1.2 */
1659 /* AK 140891 V1.3 */
1660 /* n and d may be identic */
1661 {
1662 INT erg = OK;
1663 EOP("fakul(1)",n);
1664 COP("fakul(2)",d);
1665 CTO(INTEGER,"fakul(1)",n);
1666
1667 SYMCHECK(S_I_I(n) < 0,"fakul:negativ INTEGER");
1668
1669 if (S_I_I(n) > (INT)12) {
1670 #ifdef LONGINTTRUE
1671 erg+=fakul_longintresult(n,d);
1672 goto endr_ende;
1673 #else /* LONGINTTRUE */
1674 erg += error("fakul:overflow no LONGINT available");
1675 goto endr_ende;
1676 #endif /* LONGINTTRUE */
1677 }
1678
1679 if (d != n)
1680 FREESELF(d);
1681 switch(S_I_I(n))
1682 {
1683 case 0:
1684 case 1: M_I_I(1L,d);break;
1685 case 2: M_I_I(2L,d);break;
1686 case 3: M_I_I(6L,d);break;
1687 case 4: M_I_I(24L,d);break;
1688 case 5: M_I_I(120L,d);break;
1689 case 6: M_I_I(720L,d);break;
1690 case 7: M_I_I(5040L,d);break;
1691 case 8: M_I_I(40320L,d);break;
1692 case 9: M_I_I(362880,d);break;
1693 case 10: M_I_I(3628800L,d);break;
1694 case 11: M_I_I(39916800L,d);break;
1695 case 12: M_I_I(479001600L,d);break;
1696 }
1697 ENDR("fakul");
1698 }
1699
1700
1701 #ifdef LONGINTTRUE
fakul_longintresult(n,res)1702 INT fakul_longintresult(n,res) OP n,res;
1703 /* AK 180888 */ /* AK 280689 V1.0 */ /* AK 050390 V1.1 */
1704 /* AK 140591 V1.2 */ /* AK 140891 V1.3 */
1705 /* n is of type INTEGER and > 12 */
1706 /* n and res may be identic */
1707 {
1708 OP i = callocobject();
1709 OP s = callocobject();
1710 INT erg = OK,ni;
1711 CTO(INTEGER,"fakul_longintresult",n);
1712
1713 ni = S_I_I(n);
1714 erg += m_i_longint(479001600L,res); /* 12! */
1715 M_I_I(13L,i);
1716 while (S_I_I(i) <= ni)
1717 {
1718 if ((S_I_I(i)+4) > ni)
1719 {
1720 erg += mult_apply_integer_longint(i,res);
1721 INC_INTEGER(i);
1722 }
1723 else {
1724 if (S_I_I(i) < 120) {
1725 M_I_I((S_I_I(i)*(S_I_I(i)+1)*
1726 (S_I_I(i)+2)*(S_I_I(i)+3)),s);
1727 erg += mult_apply_integer_longint(s,res);
1728 M_I_I(S_I_I(i)+4,i); }
1729 else if (S_I_I(i) < 700) {
1730 M_I_I((S_I_I(i)*(S_I_I(i)+1)*(S_I_I(i)+2)),s);
1731 erg += mult_apply_integer_longint(s,res);
1732 M_I_I(S_I_I(i)+3,i); }
1733 else if (S_I_I(i) < 20000) {
1734 M_I_I((S_I_I(i)*(S_I_I(i)+1)),s);
1735 erg += mult_apply_integer_longint(s,res);
1736 M_I_I(S_I_I(i)+2,i); }
1737 else {
1738 erg += mult_apply_integer_longint(i,res);
1739 INC_INTEGER(i);}
1740 }
1741 }
1742 FREEALL2(i,s);
1743 ENDR("fakul_longint");
1744 }
1745 #endif /* LONGINTTRUE */
1746
1747 #define GGT_INT_INT(ai,bi,res)\
1748 do { \
1749 INT c;\
1750 if (ai < 0) ai = -ai;\
1751 if (bi < 0) bi = -bi;\
1752 if (ai == 0) {\
1753 res = bi;\
1754 }\
1755 else if (bi == 0) {\
1756 res = ai;\
1757 }\
1758 else if ( ai == 1 || bi == 1) {\
1759 res = 1;\
1760 }\
1761 else if (ai == bi) {\
1762 res = ai;\
1763 }\
1764 else {\
1765 c =0;\
1766 while ((ai & 1) == 0 && (bi & 1) == 0)\
1767 {\
1768 ai >>= 1;\
1769 bi >>= 1;\
1770 c++;\
1771 }\
1772 while ((ai & 1) == 0)\
1773 ai >>= 1;\
1774 while ((bi & 1) == 0)\
1775 bi >>= 1;\
1776 /* beide ungerade */\
1777 \
1778 while (ai != bi)\
1779 if (ai > bi)\
1780 {\
1781 ai -= bi;\
1782 do\
1783 ai >>= 1;\
1784 while ((ai & 1) == 0);\
1785 }\
1786 else\
1787 {\
1788 bi -= ai;\
1789 do\
1790 bi >>= 1;\
1791 while ((bi & 1) == 0);\
1792 }\
1793 res = ai << c;\
1794 }\
1795 } while (0)
1796
1797
1798
ggt_integer_integer(a,b,d)1799 INT ggt_integer_integer(a,b,d) OP a,b,d;
1800 /* AK 300102 */
1801 /* always positive */
1802 {
1803 INT res,ai,bi,erg = OK;
1804 CTO(INTEGER,"ggt_integer_integer(1)",a);
1805 CTO(INTEGER,"ggt_integer_integer(2)",b);
1806 CTTO(EMPTY,INTEGER,"ggt_integer_integer(3)",d);
1807 ai = S_I_I(a);
1808 bi = S_I_I(b);
1809 GGT_INT_INT(ai,bi,res);
1810 M_I_I(res,d);
1811 ENDR("ggt_integer_integer");
1812 }
1813
1814
ggt_integer(a,b,c)1815 INT ggt_integer(a,b,c) OP a,b,c;
1816 {
1817 INT erg = OK;
1818 CTO(INTEGER,"ggt_integer(1)",a);
1819 CTO(EMPTY,"ggt_integer(3)",c);
1820
1821 switch(S_O_K(b)) {
1822 case INTEGER: erg += ggt_integer_integer(a,b,c);
1823 goto endr_ende;
1824 case LONGINT: erg += ggt_integer_longint(a,b,c);
1825 goto endr_ende;
1826 default:
1827 erg += WTO("ggt_integer(2)",b);
1828 goto endr_ende;
1829 }
1830 ENDR("ggt_integer");
1831 }
1832
1833
1834
ggt_integer_longint(a,b,d)1835 INT ggt_integer_longint(a,b,d) OP a,b,d;
1836 /* always positive */
1837 /* AK 300102 */
1838 {
1839 INT erg = OK;
1840 OP ac;
1841 CTO(INTEGER,"ggt_integer_longint(1)",a);
1842 CTO(LONGINT,"ggt_integer_longint(2)",b);
1843 CTTO(INTEGER,EMPTY,"ggt_integer_longint(3)",d);
1844 if (S_I_I(a) == 0) {
1845 C_O_K(d,EMPTY);
1846 erg += copy_longint(b,d);
1847 }
1848 else {
1849 INT t=0;
1850 ac = CALLOCOBJECT();
1851 if (NEGP_INTEGER(a)) { ADDINVERS_APPLY_INTEGER(a); t=1; }
1852 erg += mod_longint_integer(b,a,ac);
1853 erg += ggt_integer_integer(ac,a,d);
1854 if (t==1) { ADDINVERS_APPLY_INTEGER(a); t=0; }
1855 FREEALL(ac);
1856 }
1857 ENDR("ggt_integer_longint");
1858 }
1859
1860
ggt_i(i,j)1861 INT ggt_i(i,j) INT i, j;
1862 /* AK 010202 */
1863 {
1864 INT res;
1865 GGT_INT_INT(i,j,res);
1866 return res;
1867 }
1868
1869
1870
ggt_integer_integer_slow(a,b,c)1871 INT ggt_integer_integer_slow(a,b,c) OP a,b,c;
1872 {
1873 return ggt_integer(a,b,c);
1874 }
1875
ggt_integer_slow(a,b,c)1876 INT ggt_integer_slow(a,b,c) OP a,b,c;
1877 /* AK 021101
1878 faster als mit div und mod */
1879 /* AK 261101 ggt immer positiv */
1880 {
1881 INT erg = OK;
1882 INT t;
1883 OP d;
1884
1885 CTO(INTEGER,"ggt_integer(1)",a);
1886 CTTO(LONGINT,INTEGER,"ggt_integer(2)",b);
1887 CTO(EMPTY,"ggt_integer(3)",c);
1888
1889 if (NULLP_INTEGER(a))
1890 {
1891 COPY(b,c);
1892 if (NEGP(c)) ADDINVERS_APPLY(c);
1893 goto endr_ende;
1894 }
1895 if (NULLP(b))
1896 {
1897 COPY(a,c);
1898 if (NEGP(c)) ADDINVERS_APPLY(c);
1899 goto endr_ende;
1900 }
1901
1902 d = CALLOCOBJECT();
1903 if (NEGP_INTEGER(a))
1904 erg += ADDINVERS_INTEGER(a,d);
1905 else
1906 COPY(a,d);
1907 if (NEGP(b))
1908 ADDINVERS(b,c);
1909 else
1910 COPY(b,c);
1911
1912
1913 while((t=COMP(d,c)) != 0) {
1914 if (t == 1) {
1915 ADDINVERS_APPLY(c);
1916 ADD_APPLY(c,d);
1917 ADDINVERS_APPLY(c);
1918 }
1919 else {
1920 ADDINVERS_APPLY(d);
1921 ADD_APPLY(d,c);
1922 ADDINVERS_APPLY(d);
1923 }
1924 }
1925 FREEALL(d);
1926 ENDR("ggt_integer");
1927 }
1928
ggt(a,b,c)1929 INT ggt(a,b,c) OP a,b,c;
1930 /* AK 190888 */ /* AK 280689 V1.0 */ /* AK 010290 V1.1 */
1931 /* AK 140591 V1.2 */ /* AK 140891 V1.3 */
1932 /* AK 030498 V2.0 */
1933 /* AK 261101 ggt ist immer positiv */
1934 {
1935 OP i,j;
1936 INT erg=OK,comperg;
1937 EOP("ggt(1)",a);
1938 EOP("ggt(2)",b);
1939 COP("ggt(3)",c);
1940 CE3(a,b,c,ggt);
1941
1942 if (S_O_K(a) == INTEGER)
1943 {
1944 erg+=ggt_integer(a,b,c);
1945 goto endr_ende;
1946 }
1947 else if (S_O_K(a) == LONGINT)
1948 {
1949 erg+=ggt_longint(a,b,c);
1950 goto endr_ende;
1951 }
1952 else if ( (S_O_K(a) == MONOPOLY ) && (S_O_K(b) == MONOPOLY) )
1953 /* AK 170206 */
1954 /* only with finite field coeffs */
1955 {
1956 if (S_O_K(S_PO_K(a) ) != FF) error("ggt-monopoly: only finite field coeffs ");
1957 if (S_O_K(S_PO_K(b) ) != FF) error("ggt-monopoly: only finite field coeffs ");
1958 {
1959 OP aa = CALLOCOBJECT();
1960 OP bb = CALLOCOBJECT();
1961 t_MONOPOLY_POLYNOM(a,aa);
1962 t_MONOPOLY_POLYNOM(b,bb); ggt_field_polynom(aa,bb,c);
1963 t_POLYNOM_MONOPOLY(c,c);
1964 freeall(bb);
1965 freeall(aa);
1966 }
1967 }
1968 else {
1969 erg += WTO("ggt(1)",a);
1970 goto endr_ende;
1971 }
1972 ENDR("ggt");
1973
1974 }
1975
1976 #ifdef UNDEF
hoch_pre200902(a,b,c)1977 INT hoch_pre200902(a,b,c) OP a,b,c;
1978 {
1979 INT erg = OK;
1980 EOP("hoch(1)",a);
1981 EOP("hoch(2)",b);
1982 COP("hoch(3)",c);
1983 CE3(a,b,c,hoch);
1984 switch(S_O_K(a)) {
1985 case INTEGER:
1986 erg += hoch_integer(a,b,c);
1987 break;
1988 case LONGINT:
1989 erg += hoch_longint(a,b,c);
1990 break;
1991 case BRUCH:
1992 erg += hoch_bruch(a,b,c);
1993 break;
1994 default:
1995 erg += hoch_default(a,b,c);
1996 break;
1997 }
1998 ENDR("hoch");
1999 }
2000 #endif
2001
hoch(a,b,c)2002 INT hoch(a,b,c) OP a,b,c ;
2003 /* c = a^b */
2004 /* algorithm 1.2.3 in cohen:a course in computational
2005 algebraic number theory */
2006 /* AK 200902 V2.1 */
2007 {
2008 INT erg = OK;
2009 EOP("hoch(1)",a);
2010 CTTO(INTEGER,LONGINT,"hoch(2)",b);
2011 COP("hoch(3)",a);
2012 CE3(a,b,c,hoch);
2013 {
2014 eins(a,c);
2015 if (not NULLP(b)) {
2016 INT f;
2017 OP N,z;
2018 N = CALLOCOBJECT();
2019 z = CALLOCOBJECT();
2020 if (NEGP(b))
2021 {
2022 ADDINVERS(b,N);
2023 INVERS(a,z);
2024 }
2025 else
2026 {
2027 COPY(b,N);
2028 COPY(a,z);
2029 }
2030 f = number_of_bits(N)-1;
2031
2032 CLEVER_COPY(z,c);
2033
2034 while (1)
2035 {
2036 INT i;
2037 if (f == 0) break;
2038 else f--;
2039
2040 square_apply(c);
2041
2042 if (bit(N,f)) MULT_APPLY(z,c);
2043 }
2044 FREEALL2(N,z);
2045 }
2046 }
2047 ENDR("hoch");
2048 }
2049
hoch_default(basis,expon,ergeb)2050 INT hoch_default(basis,expon,ergeb) OP basis, ergeb, expon;
2051 /* AK 041186 ergeb = basis ** expon */
2052 /* AK 031286 ok */
2053 /* AK 280689 V1.0 */ /* AK 160190 V1.1 */ /* AK 090891 V1.3 */
2054 /* AK 030496 V2.0 */
2055 {
2056 INT erg = OK;
2057 CTTO(INTEGER,LONGINT,"hoch_default(2)",expon);
2058 CTO(EMPTY,"hoch_default(1)",ergeb);
2059
2060 if (NEGP(expon))
2061 {
2062 OP c=callocobject();
2063 erg += invers(basis,c);
2064 erg += addinvers_apply(expon);
2065 erg += hoch_default(c,expon,ergeb);
2066 erg += addinvers_apply(expon);
2067 erg += freeall(c);
2068 goto endr_ende;
2069 }
2070 else if (NULLP(expon))
2071 M_I_I(1,ergeb);
2072 else if (EINSP(expon))
2073 COPY(basis,ergeb);
2074 else {
2075 OP n = callocobject();
2076 OP a = callocobject();
2077 COPY(expon,n);
2078 COPY(basis,a);
2079 COPY(basis,ergeb); /* AK 290692 */
2080 DEC(n); /* AK 290692 */
2081 while (not NULLP(n)) {
2082 MULT_APPLY(a,ergeb);
2083 DEC(n);
2084 }
2085 FREEALL2(a,n);
2086 };
2087 ENDR("hoch_default");
2088 }
2089
2090
invers(a,b)2091 INT invers(a,b) OP a,b;
2092 /* AK 280689 V1.0 */ /* AK 070789 sonderfaelle 0 und 1 */
2093 /* AK 081289 V1.1 */ /* AK 250391 V1.2 */ /* AK 140891 V1.3 */
2094 {
2095 INT erg = OK;
2096 EOP("invers(1)",a);
2097 COP("invers(2)",b);
2098
2099 /* no test on null , e.g. permutation */
2100
2101 if (EINSP(a)) /* AK 070789 */
2102 {
2103 if (a == b) goto endr_ende;
2104 CLEVER_COPY(a,b);
2105 goto endr_ende;
2106 }
2107
2108 CE2(a,b,invers);
2109
2110
2111 switch(S_O_K(a))
2112 {
2113 #ifdef BRUCHTRUE
2114 case BRUCH :
2115 erg += invers_bruch(a,b);
2116 break;
2117 #endif /* BRUCHTRUE */
2118
2119 #ifdef CYCLOTRUE
2120 case CYCLOTOMIC:
2121 erg += invers_cyclo (a,b);
2122 break;
2123 #endif /* CYCLOTRUE */
2124
2125 #ifdef FFTRUE
2126 case FF : erg += invers_ff(a,b); break;
2127 #endif /* FFTRUE */
2128
2129 #ifdef GRTRUE
2130 case GALOISRING:
2131 erg += invers_galois(a,b); break;
2132 #endif /* GRTRUE */
2133
2134 #ifdef LAURENTTRUE
2135 case LAURENT : erg += invers_laurent(a,b); break;
2136 #endif /* LAURENTTRUE */
2137
2138 #ifdef MONOPOLYTRUE
2139 case MONOPOLY : erg += invers_monopoly(a,b); break;
2140 #endif /* MONOPOLYTRUE */
2141
2142 #ifdef LONGINTTRUE
2143 case LONGINT :
2144 erg += invers_longint(a,b);
2145 break;
2146 #endif /* LONGINTTRUE */
2147
2148 #ifdef INTEGERTRUE
2149 case INTEGER :
2150 erg += invers_integer(a,b);
2151 break;
2152 #endif /* INTEGERTRUE */
2153
2154 #ifdef MATRIXTRUE
2155 case KRANZTYPUS:
2156 case KOSTKA :
2157 case MATRIX :
2158 erg += invers_matrix(a,b);
2159 break;
2160 #endif /* MATRIXTRUE */
2161
2162 #ifdef PERMTRUE
2163 case PERMUTATION :
2164 erg += invers_permutation(a,b);
2165 break;
2166 #endif /* PERMTRUE */
2167
2168 #ifdef KRANZTRUE
2169 case KRANZ :
2170 erg += invers_kranz(a,b);
2171 break;
2172 #endif /* KRANZTRUE */
2173
2174 #ifdef POLYTRUE
2175 case POLYNOM : /* CC */
2176 erg += invers_POLYNOM(a,b);
2177 break;
2178
2179 #endif /* POLYTRUE */
2180
2181 #ifdef SQRADTRUE
2182 case SQ_RADICAL:
2183 erg += invers_sqrad (a,b);
2184 break;
2185 #endif /* SQRADTRUE */
2186
2187 default:
2188 erg += WTO("invers(1)",a);
2189 break;
2190 };
2191 ENDR("invers");
2192 }
2193
2194
multadd_apply_default(a,b,c)2195 INT multadd_apply_default(a,b,c) OP a,b,c;
2196 {
2197 INT erg =OK;
2198 OP d;
2199 d=CALLOCOBJECT();
2200 MULT(a,b,d);
2201 ADD_APPLY(d,c);
2202 FREEALL(d);
2203 ENDR("multadd_apply_default");
2204 }
multadd_apply(a,b,c)2205 INT multadd_apply(a,b,c) OP a,b,c;
2206 /* c += a*b */
2207 /* AK 170607 */
2208 {
2209 INT erg =OK;
2210 if (
2211 (S_O_K(a) != S_O_K(b))
2212 ||
2213 (S_O_K(c) != S_O_K(b))
2214 )
2215 {
2216 multadd_apply_default(a,b,c);
2217 }
2218 else {
2219 switch(S_O_K(a))
2220 {
2221 case FF:
2222 multadd_apply_ff(a,b,c);
2223 break;
2224 default:
2225 multadd_apply_default(a,b,c);
2226 break;
2227 }
2228 }
2229 ENDR("multadd_apply");
2230 }
2231
mult(a,b,d)2232 INT mult(a,b,d) OP a,b,d;
2233 /* AK 280689 V1.0 */ /* AK 081289 V1.1 */ /* AK 140891 V1.3 */
2234 /* AK 070498 V2.0 */
2235 {
2236 INT erg = OK;
2237 EOP("mult(1)",a);
2238 EOP("mult(2)",b);
2239 COP("mult(3)",d);
2240 CE3(a,b,d,mult);
2241
2242
2243 switch(S_O_K(a))
2244 {
2245 #ifdef MONOPOLYTRUE
2246 case MONOPOLY:
2247 erg+=mult_monopoly (a,b,d);
2248 break;
2249 #endif /* MONOPOLYTRUE */
2250 #ifdef MONOMTRUE
2251 case MONOM:
2252 erg+=mult_monom (a,b,d);
2253 break;
2254 #endif /* MONOMTRUE */
2255 #ifdef CYCLOTRUE
2256 case CYCLOTOMIC:
2257 erg+=mult_cyclo (a,b,d);
2258 break;
2259 #endif /* CYCLOTRUE */
2260 #ifdef REIHETRUE
2261 case REIHE:
2262 erg+=mult_reihe(a,b,d);
2263 break;
2264 #endif /* REIHETRUE */
2265 #ifdef FFTRUE
2266 case FF: erg+=mult_ff(a,b,d); break;
2267 #endif /* FFTRUE */
2268 #ifdef GRTRUE
2269 case GALOISRING: erg+=mult_galois(a,b,d); break;
2270 #endif /* GRTRUE */
2271 #ifdef SQRADTRUE
2272 case SQ_RADICAL:
2273 erg+=mult_sqrad (a,b,d); break;
2274 #endif /* SQRADTRUE */
2275
2276 #ifdef BRUCHTRUE
2277 case BRUCH :
2278 erg+=mult_bruch(a,b,d);
2279 break;
2280 #endif /* BRUCHTRUE */
2281
2282 #ifdef INTEGERTRUE
2283 case INTEGER :
2284 erg+=mult_integer(a,b,d);
2285 break;
2286 #endif /* INTEGERTRUE */
2287 #ifdef LAURENTTRUE
2288 case LAURENT :
2289 erg+=mult_laurent(a,b,d);
2290 break;
2291 #endif /* LAURENTTRUE */
2292 #ifdef POLYTRUE
2293 case POLYNOM :
2294 erg+=mult_polynom(a,b,d);
2295 break;
2296 #endif /* POLYTRUE */
2297 #ifdef SCHUBERTTRUE
2298 case SCHUBERT :
2299 switch(S_O_K(b))
2300 {
2301 case BRUCH:
2302 case LONGINT:
2303 case INTEGER:
2304 erg+=mult_scalar_schubert(b, a, d);
2305 break;
2306 case POLYNOM:
2307 erg+=mult_schubert_polynom(a,b,d);
2308 break;
2309 case SCHUBERT:
2310 erg+=mult_schubert_schubert(a,b,d);
2311 break;
2312 };
2313 break;
2314 #endif /* SCHUBERTTRUE */
2315 #ifdef SCHURTRUE
2316 case SCHUR :
2317 erg += mult_schur(a,b,d);
2318 break;
2319 case MONOMIAL:
2320 erg += mult_monomial(a,b,d);
2321 break;
2322 case POW_SYM :
2323 erg += mult_powsym(a,b,d);
2324 break;
2325 case ELM_SYM :
2326 erg += mult_elmsym(a,b,d);
2327 break;
2328 case HOM_SYM :
2329 erg+=mult_homsym(a,b,d);
2330 break;
2331 #endif /* SCHURTRUE */
2332 #ifdef MATRIXTRUE
2333 case KRANZTYPUS:
2334 case KOSTKA :
2335 case MATRIX :
2336 erg+=mult_matrix(a,b,d);
2337 break;
2338 #endif /* MATRIXTRUE */
2339 #ifdef LONGINTTRUE
2340 case LONGINT:
2341 erg+=mult_longint(a,b,d);
2342 break;
2343 #endif /* LONGINTTRUE */
2344 #ifdef PERMTRUE
2345 case PERMUTATION:
2346 erg+=mult_permutation(a,b,d);
2347 break;
2348 #endif /* PERMTRUE */
2349 #ifdef VECTORTRUE
2350 case INTEGERVECTOR:
2351 case VECTOR :
2352 switch(S_O_K(b))
2353 {
2354 #ifdef BRUCHTRUE
2355 case BRUCH:
2356 #endif /* BRUCHTRUE */
2357 case LONGINT:
2358 case INTEGER:
2359 erg+=mult_scalar_vector(b,a,d);
2360 break;
2361 case VECTOR:
2362 case INTEGERVECTOR:
2363 erg+=mult_vector_vector(a,b,d);
2364 break;
2365 #ifdef MATRIXTRUE
2366 case MATRIX:
2367 erg+=mult_vector_matrix(a,b,d);
2368 break;
2369 #endif /* MATRIXTRUE */
2370 default:
2371 printobjectkind(b);
2372 error("mult_vector:wrong second type");
2373 return ERROR;
2374 };
2375 break;
2376 #endif /* VECTORTRUE */
2377 #ifdef CHARTRUE
2378 case SYMCHAR :
2379 switch(S_O_K(b))
2380
2381 {
2382 case BRUCH:
2383 case LONGINT:
2384 case INTEGER:
2385 erg+=mult_scalar_symchar(b,a,d);
2386 break;
2387 case SYMCHAR:
2388 erg+=mult_symchar_symchar(a,b,d);
2389 break;
2390 default:
2391 printobjectkind(b);
2392 error("mult_symchar in mult:wrong second type");
2393 return ERROR;
2394 };
2395 break;
2396 #endif /* CHARTRUE */
2397 #ifdef KRANZTRUE
2398 case KRANZ :
2399 switch(S_O_K(b))
2400
2401 {
2402 case KRANZ:
2403 erg+=mult_kranz_kranz(a,b,d);
2404 break;
2405 default:
2406 printobjectkind(b);
2407 error("mult_kranz in mult:wrong second type");
2408 return ERROR;
2409 };
2410 break;
2411 #endif /*KRANZTRUE */
2412 #ifdef GRALTRUE
2413 case GRAL:
2414 erg += mult_gral(a,b,d);
2415 break;
2416 #endif
2417
2418 default:
2419 WTT("mult",a,b);
2420 }
2421 ENDR("mult");
2422 }
2423
2424
scalarproduct(a,b,c)2425 INT scalarproduct(a,b,c) OP a,b,c;
2426 /* AK 010888 */ /* AK 280689 V1.0 */ /* AK 050390 V1.1 */
2427 /* AK 140891 V1.3 */
2428 {
2429 INT erg=OK;
2430 EOP("scalarproduct",a);
2431 EOP("scalarproduct",b);
2432 CE3(a,b,c,scalarproduct);
2433 CTO(EMPTY,"scalarproduct(3)",c);
2434
2435
2436 switch(S_O_K(a))
2437 {
2438
2439 #ifdef SCHUBERTTRUE
2440 case SCHUBERT:
2441 erg += scalarproduct_schubert(a,b,c);
2442 break;
2443 #endif /* SCHURTRUE */
2444
2445 #ifdef SCHURTRUE
2446 case SCHUR :
2447 erg += scalarproduct_schur(a,b,c);
2448 break;
2449 #endif /* SCHURTRUE */
2450 #ifdef MONOMIALTRUE
2451 case MONOMIAL :
2452 erg += scalarproduct_monomial(a,b,c);
2453 break;
2454 #endif /* MONOMIALTRUE */
2455 #ifdef HOMSYMTRUE
2456 case HOMSYM :
2457 erg += scalarproduct_homsym(a,b,c);
2458 break;
2459 #endif /* HOMSYMTRUE */
2460 #ifdef ELMSYMTRUE
2461 case ELMSYM :
2462 erg += scalarproduct_elmsym(a,b,c);
2463 break;
2464 #endif /* ELMSYMTRUE */
2465 #ifdef POWSYMTRUE
2466 case POWSYM :
2467 erg += scalarproduct_powsym(a,b,c);
2468 break;
2469 #endif /* POWSYMTRUE */
2470
2471 #ifdef CHARTRUE
2472 case SYMCHAR :
2473 erg += scalarproduct_symchar(a,b,c);
2474 break;
2475 #endif /* CHARTRUE */
2476
2477 #ifdef VECTORTRUE
2478 case INTEGERVECTOR:
2479 case VECTOR :
2480 erg += scalarproduct_vector(a,b,c);
2481 break;
2482 #endif /* VECTORTRUE */
2483
2484 default:
2485 erg += WTT("scalarproduct",a,b);
2486 break;
2487 };
2488 ENDR("scalarproduct");
2489 }
2490
2491
2492 #ifdef POLYTRUE
vander(n,res)2493 INT vander(n,res) OP n,res;
2494 /* AK 300588 */ /* AK 280689 V1.0 */ /* AK 050390 V1.1 */
2495 /* AK 140891 V1.3 */
2496 /* n and res may be equal */
2497 {
2498 INT ni,i,j,erg = OK;
2499 OP a,b,c;
2500
2501 EOP("vander",n);
2502 CTO(INTEGER,"vander",n);
2503
2504 ni = S_I_I(n);
2505 m_i_i(1L,res);
2506
2507 a = callocobject();
2508 b = callocobject();
2509 c = callocobject();
2510
2511 for (i=2L;i<=ni;i++)
2512 for (j=1L;j<i;j++)
2513 {
2514 erg += m_iindex_monom(i-1,a);
2515 erg += m_iindex_monom(j-1,b);
2516 erg += sub(a,b,c);
2517 erg += mult_apply(c,res);
2518 }
2519
2520 erg += freeall(a);
2521 erg += freeall(b);
2522 erg += freeall(c);
2523 ENDR("vander");
2524 }
2525 #endif /* POLYTRUE */
2526
weight(a,b)2527 INT weight(a,b) OP a,b;
2528 /* AK 280689 V1.0 */ /* AK 050390 V1.1 */
2529 /* AK 140891 V1.3 */ /* AK 250298 V2.0 */
2530 /* AK 131206 V3,1 */
2531 {
2532 INT erg = OK;
2533 EOP("weight(1)",a);
2534 CE2(a,b,weight);
2535
2536 switch(S_O_K(a))
2537 {
2538
2539 #ifdef PARTTRUE
2540 case AUG_PART :
2541 erg+=weight_augpart(a,b);
2542 break;
2543 case PARTITION :
2544 erg+=weight_partition(a,b);
2545 break;
2546 #endif /* PARTTRUE */
2547
2548 #ifdef SKEWPARTTRUE
2549 case SKEWPARTITION :
2550 erg+=weight_skewpartition(a,b);
2551 break;
2552 #endif /* SKEWPARTTRUE */
2553
2554 #ifdef TABLEAUXTRUE
2555 case TABLEAUX :
2556 erg+=weight_tableaux(a,b);
2557 break;
2558 #endif /* TABLEAUXTRUE */
2559
2560 case WORD:
2561 case INTEGERVECTOR:
2562 case VECTOR: /* number of nonzero entries */
2563 erg += weight_vector(a,b);
2564 break;
2565
2566 default:
2567 erg += WTO("weight",a);
2568 break;
2569 };
2570 ENDR("weight");
2571 }
2572
trace(a,b)2573 INT trace(a,b) OP a,b;
2574 /* AK 131289 */ /* AK 131289 V1.1 */
2575 /* AK 140891 V1.3 */
2576 /* AK 250298 V2.0 */
2577 {
2578 INT erg = OK;
2579 EOP("trace(1)",a);
2580 CE2(a,b,trace);
2581
2582 switch (S_O_K(a)) {
2583
2584 #ifdef MATRIXTRUE
2585 case KRANZTYPUS:
2586 case KOSTKA:
2587 case MATRIX:
2588 erg += trace_matrix(a,b); break;
2589 #endif /* MATRIXTRUE */
2590
2591 default:
2592 erg += WTO("trace",a); break;
2593 };
2594 ENDR("trace");
2595 }
2596
det(a,b)2597 INT det(a,b) OP a,b;
2598 /* AK 151289 Determinante berechnung */ /* AK 151289 V1.1 */
2599 {
2600 INT erg = OK;
2601 EOP("det",a);
2602 CE2(a,b,det);
2603
2604 switch (S_O_K(a)) {
2605 #ifdef MATRIXTRUE
2606 case KRANZTYPUS:
2607 case KOSTKA:
2608 case MATRIX:
2609 erg += det_matrix(a,b);
2610 break;
2611 #endif /* MATRIXTRUE */
2612 default:
2613 erg += WTO("det",a); break;
2614 };
2615 ENDR("det");
2616 }
2617
invers_apply(a)2618 INT invers_apply(a) OP a;
2619 /* AK 140591 V1.2 */ /* AK 140891 V1.3 */
2620 {
2621 INT erg = OK;
2622 EOP("invers_apply",a);
2623
2624 switch(S_O_K(a))
2625 {
2626
2627 #ifdef BRUCHTRUE
2628 case BRUCH :
2629 erg += invers_apply_bruch(a);
2630 break;
2631 #endif /* BRUCHTRUE */
2632
2633 #ifdef FFTRUE
2634 case FF :
2635 erg += invers_apply_ff(a);
2636 break;
2637 #endif /* FFTRUE */
2638
2639 #ifdef INTEGERTRUE
2640 case INTEGER :
2641 erg += invers_apply_integer(a);
2642 break;
2643 #endif /* INTEGERTRUE */
2644
2645 #ifdef LONGINTTRUE
2646 case LONGINT:
2647 erg += invers_apply_longint(a);
2648 break;
2649 #endif /*LONGINTTRUE*/
2650
2651 default:
2652 {
2653 OP c = callocobject();
2654 erg += copy(a,c);
2655 erg += invers(c,a);
2656 erg += freeall(c);
2657 }
2658 }
2659 ENDR("invers_apply");
2660 }
2661
addinvers_apply(a)2662 INT addinvers_apply(a) OP a;
2663 /* AK 201289 V1.1 */ /* AK 140891 V1.3 */
2664 /* AK 200498 V2.0 */
2665 {
2666 INT erg = OK;
2667 EOP("addinvers_apply(1)",a);
2668
2669 switch(S_O_K(a))
2670 {
2671
2672 #ifdef BRUCHTRUE
2673 case BRUCH :
2674 erg+=addinvers_apply_bruch(a);
2675 break;
2676 #endif /* BRUCHTRUE */
2677
2678 #ifdef CYCLOTRUE
2679 case CYCLOTOMIC:
2680 erg+=addinvers_apply_cyclo(a);
2681 break;
2682 #endif /* CYCLOTRUE */
2683
2684 #ifdef FFTRUE
2685 case FF:
2686 erg+=addinvers_apply_ff(a);
2687 break;
2688 #endif /* FFTRUE */
2689
2690 #ifdef GRTRUE
2691 case GALOISRING:
2692 erg+=addinvers_apply_galois(a);
2693 break;
2694 #endif /* GRTRUE */
2695
2696 #ifdef LAURENTTRUE
2697 case LAURENT:
2698 erg+=addinvers_apply_laurent(a);
2699 break;
2700 #endif /* LAURENTTRUE */
2701
2702 #ifdef INTEGERTRUE
2703 case INTEGER :
2704 erg+=addinvers_apply_integer(a);
2705 break;
2706 #endif /* INTEGERTRUE */
2707
2708 #ifdef LONGINTTRUE
2709 case LONGINT :
2710 erg+=addinvers_apply_longint(a);
2711 break;
2712 #endif /* LONGINTTRUE */
2713
2714 #ifdef MONOMTRUE
2715 case MONOM :
2716 erg+=addinvers_apply_monom(a);
2717 break;
2718 #endif /* MONOMTRUE */
2719
2720 #ifdef MONOPOLYTRUE
2721 case MONOPOLY:
2722 erg+=addinvers_apply_monopoly (a);
2723 break;
2724 #endif /* MONOPOLYTRUE */
2725
2726 #ifdef POLYTRUE
2727 case HOM_SYM:
2728 erg += addinvers_apply_homsym(a);
2729 break;
2730 case MONOMIAL:
2731 erg += addinvers_apply_monomial(a);
2732 break;
2733 case ELM_SYM:
2734 erg += addinvers_apply_elmsym(a);
2735 break;
2736 case POW_SYM:
2737 erg += addinvers_apply_powsym(a);
2738 break;
2739 case SCHUR:
2740 erg += addinvers_apply_schur(a);
2741 break;
2742
2743 case SCHUBERT:
2744 case GRAL:
2745 case POLYNOM :
2746 erg+=addinvers_apply_polynom(a);
2747 break;
2748 #endif /* POLYTRUE */
2749
2750 #ifdef SQRADTRUE
2751 case SQ_RADICAL:
2752 erg+=addinvers_apply_sqrad (a);
2753 break;
2754 #endif /* SQRADTRUE */
2755
2756 #ifdef CHARTRUE
2757 case SYMCHAR :
2758 erg+=addinvers_apply_symchar(a);
2759 break;
2760 #endif /* CHARTRUE */
2761
2762 #ifdef VECTORTRUE
2763 case INTEGERVECTOR:
2764 case VECTOR :
2765 erg+=addinvers_apply_vector(a);
2766 break;
2767
2768 case HASHTABLE:
2769 erg+=addinvers_apply_hashtable(a);
2770 break;
2771 #endif /* VECTORTRUE */
2772
2773 default:
2774 erg += WTO("addinvers_apply",a);
2775 break;
2776 };
2777 ENDR("addinvers_apply");
2778 }
2779
mult_apply_default(a,b)2780 INT mult_apply_default (a,b) OP a,b;
2781 /* hilfsroutine tut normales mult aufrufen */
2782 /* AK 091092 */
2783 {
2784 INT erg=OK;
2785 OP c;
2786 c = CALLOCOBJECT();
2787 *c = *b;
2788 C_O_K(b,EMPTY);
2789 erg += mult(a,c,b);
2790 FREEALL(c);
2791 ENDR("mult_apply_default");
2792 }
2793
mult_apply(a,b)2794 INT mult_apply(a,b) OP a,b;
2795 /* b := a * b */
2796 /* AK 201289 V1.1 */
2797 /* AK 190291 V1.2 */
2798 /* AK 140891 V1.3 */
2799 {
2800 INT erg = OK;
2801 EOP("mult_apply(1)",a);
2802 EOP("mult_apply(2)",b);
2803 CE2A(a,b,mult_apply);
2804
2805 /* switching according to the first type */
2806
2807 switch(S_O_K(a)) {
2808 #ifdef BRUCHTRUE
2809 case BRUCH:
2810 erg += mult_apply_bruch(a,b);
2811 goto ende;
2812 #endif /* BRUCHTRUE */
2813 #ifdef FFTRUE
2814 case FF:
2815 erg += mult_apply_ff(a,b);
2816 goto ende;
2817 #endif /* FFTRUE */
2818 #ifdef GRTRUE
2819 case GALOISRING:
2820 erg += mult_apply_default(a,b);
2821 goto ende;
2822 #endif /* GRTRUE */
2823 #ifdef GRALTRUE
2824 case GRAL:
2825 erg += mult_apply_gral(a,b);
2826 goto ende;
2827 #endif /* GRALTRUE */
2828 case INTEGER:
2829 erg += mult_apply_integer(a,b);
2830 goto ende;
2831 #ifdef LONGINTTRUE
2832 case LONGINT:
2833 erg += mult_apply_longint(a,b);
2834 goto ende;
2835 #endif /* LONGINTTRUE */
2836 #ifdef MATRIXTRUE
2837 case MATRIX:
2838 erg += mult_apply_matrix(a,b);
2839 goto ende;
2840 #endif /* MATRIXTRUE */
2841 #ifdef MONOMTRUE
2842 case MONOM:
2843 erg += mult_apply_monom(a,b);
2844 goto ende;
2845 #endif /* MONOMTRUE */
2846 #ifdef PERMTRUE
2847 case PERMUTATION:
2848 erg += mult_apply_permutation(a,b);
2849 goto ende;
2850 #endif /* PERMTRUE */
2851 #ifdef POLYTRUE
2852 case POLYNOM:
2853 erg += mult_apply_polynom(a,b);
2854 goto ende;
2855 #endif /* POLYTRUE */
2856 #ifdef REIHETRUE
2857 case REIHE:
2858 erg += mult_apply_reihe(a,b);
2859 goto ende;
2860 #endif /* REIHETRUE */
2861 #ifdef SCHUBERTTRUE
2862 case SCHUBERT:
2863 erg += mult_apply_default(a,b);
2864 goto ende;
2865 #endif /* SCHUBERTTRUE */
2866 #ifdef SCHURTRUE
2867 case HOM_SYM:
2868 erg += mult_apply_homsym(a,b);
2869 goto ende;
2870 case POW_SYM:
2871 erg += mult_apply_powsym(a,b);
2872 goto ende;
2873 case ELM_SYM:
2874 erg += mult_apply_elmsym(a,b);
2875 goto ende;
2876 case MONOMIAL:
2877 erg += mult_apply_monomial(a,b);
2878 goto ende;
2879 case SCHUR:
2880 erg += mult_apply_schur(a,b);
2881 goto ende;
2882 #endif /* SCHURTRUE */
2883 #ifdef CHARTRUE
2884 case SYMCHAR:
2885 erg += mult_apply_symchar(a,b);
2886 goto ende;
2887 #endif /* CHARTRUE */
2888 #ifdef MONOPOLYTRUE
2889 case MONOPOLY:
2890 erg += mult_apply_monopoly (a,b);
2891 goto ende;
2892 #endif /* MONOPOLYTRUE */
2893 #ifdef CYCLOTRUE
2894 case CYCLOTOMIC:
2895 erg += mult_apply_cyclo (a,b);
2896 goto ende;
2897 #endif /* CYCLOTRUE */
2898 #ifdef SQRADTRUE
2899 case SQ_RADICAL:
2900 erg += mult_apply_sqrad (a,b);
2901 goto ende;
2902 #endif /* SQRADTRUE */
2903 #ifdef VECTORTRUE
2904 case VECTOR:
2905 case INTEGERVECTOR:
2906 erg += mult_apply_vector(a,b);
2907 goto ende;
2908 #endif /* VECTORTRUE */
2909 default:
2910 WTT("mult_apply(1,2)",a,b);
2911 goto ende;
2912 }
2913 ende:
2914 ENDR("mult_apply");
2915 }
2916
half_apply(a)2917 INT half_apply(a) OP a;
2918 /* AK 021294 */
2919 {
2920 INT erg = OK;
2921 EOP("half_apply(1)",a);
2922
2923 switch S_O_K(a) {
2924 case INTEGER:
2925 M_I_I(S_I_I(a)/(INT)2, a);
2926 break;
2927 case LONGINT:
2928 erg += half_apply_longint(a);
2929 break;
2930 default: {
2931 OP c;
2932 c = CALLOCOBJECT();
2933 *c = *a;
2934 C_O_K(a,EMPTY);
2935 erg += ganzdiv(c,cons_zwei,a);
2936 FREEALL(c);
2937 } ;
2938 break;
2939 }
2940
2941 ENDR("half_apply");
2942 }
double_apply_default(a)2943 INT double_apply_default(a) OP a;
2944 /* AK 0102002 */
2945 {
2946 INT erg = OK;
2947 OP c;
2948
2949 c= CALLOCOBJECT();
2950 COPY(a,c);
2951 ADD_APPLY(c,a);
2952 FREEALL(c);
2953
2954 ENDR("double_apply_default");
2955 }
2956
double_apply(a)2957 INT double_apply(a) OP a;
2958 /* AK 010692 */
2959 {
2960 INT erg = OK;
2961 EOP("double_apply(1)",a);
2962
2963 switch S_O_K(a) {
2964 case INTEGER:
2965 if ((S_I_I(a) > -1073741824) && /* 2^30 */
2966 (S_I_I(a) < 1073741824) )
2967 {
2968 M_I_I( (S_I_I(a)<<1),a);
2969 }
2970 else
2971 {
2972 erg += t_int_longint(a,a);
2973 erg += double_apply_longint(a);
2974 }
2975 goto ende;
2976 case LONGINT:
2977 erg += double_apply_longint(a);
2978 goto ende;
2979 case BRUCH:
2980 double_apply(S_B_O(a));
2981 erg += kuerzen(a);
2982 goto ende;
2983 default:
2984 erg += double_apply_default(a);
2985 goto ende;
2986 }
2987
2988 ende:
2989 ENDR("double_apply");
2990 }
2991
add_apply(a,b)2992 INT add_apply(a,b) OP a,b;
2993 /* b = a + b */ /* AK 120390 V1.1 */ /* AK 140591 V1.2 */
2994 /* AK 140891 V1.3 */
2995 /* AK 270298 V2.0 */
2996 {
2997 INT erg = OK;
2998 EOP("add_apply(1)",a);
2999 EOP("add_apply(2)",b);
3000 if (a == b)
3001 {
3002 erg += double_apply(a);
3003 goto endr_ende;
3004 }
3005
3006 /* switching according to the first type */
3007 switch(S_O_K(a))
3008 {
3009 #ifdef BRUCHTRUE
3010 case BRUCH:
3011 erg += add_apply_bruch(a,b);
3012 break;
3013 #endif /* BRUCHTRUE */
3014
3015 #ifdef FFTRUE
3016 case FF:
3017 erg += add_apply_ff(a,b);
3018 break;
3019 #endif /* FFTRUE */
3020
3021 #ifdef POLYTRUE
3022 case GRAL:
3023 erg += add_apply_gral(a,b) ;
3024 break;
3025 #endif /* POLYTRUE */
3026
3027 case INTEGER:
3028 erg += add_apply_integer(a,b);
3029 break;
3030
3031 #ifdef LONGINTTRUE
3032 case LONGINT:
3033 erg += add_apply_longint(a,b);
3034 break;
3035 #endif /* LONGINTTRUE */
3036
3037 #ifdef MATRIXTRUE
3038 case KRANZTYPUS:
3039 case MATRIX:
3040 erg += add_apply_matrix(a,b);
3041 break;
3042 #endif /* MATRIXTRUE */
3043
3044 #ifdef REIHETRUE
3045 case REIHE:
3046 erg += add_apply_reihe(a,b);
3047 break;
3048 #endif /* REIHETRUE */
3049
3050 #ifdef SCHUBERTTRUE
3051 case SCHUBERT:
3052 erg += add_apply_schubert(a,b);
3053 break;
3054 #endif /* SCHUBERTTRUE */
3055
3056 #ifdef SCHURTRUE
3057 case POW_SYM:
3058 case MONOMIAL:
3059 case HOM_SYM:
3060 case ELM_SYM:
3061 case SCHUR:
3062 erg += add_apply_symfunc(a,b);
3063 break;
3064 #endif /* SCHURTRUE */
3065
3066 #ifdef CHARTRUE
3067 case SYMCHAR:
3068 erg += add_apply_symchar(a,b);
3069 break;
3070 #endif /* CHARTRUE */
3071
3072 #ifdef POLYTRUE
3073 case POLYNOM:
3074 erg += add_apply_polynom(a,b);
3075 break;
3076 #endif /* POLYTRUE */
3077
3078 case VECTOR:
3079 erg += add_apply_vector(a,b);
3080 break;
3081 case INTEGERVECTOR:
3082 erg += add_apply_integervector(a,b);
3083 break;
3084
3085 #ifdef MONOPOLYTRUE
3086 case MONOPOLY:
3087 erg += add_apply_monopoly (a,b);
3088 break;
3089 #endif /* MONOPOLYTRUE */
3090
3091 #ifdef CYCLOTRUE
3092 case CYCLOTOMIC:
3093 erg += add_apply_cyclo (a,b);
3094 break;
3095 #endif /* CYCLOTRUE */
3096
3097 #ifdef SQRADTRUE
3098 case SQ_RADICAL:
3099 erg += add_apply_sqrad (a,b);
3100 break;
3101 #endif /* SQRADTRUE */
3102
3103 default:
3104 erg += add_apply_default(a,b);
3105 break;
3106 }
3107 ende:
3108 ENDR("add_apply");
3109 }
3110
add_apply_default(a,b)3111 INT add_apply_default(a,b) OP a,b;
3112 /* AK 040302 */
3113 {
3114 INT erg = OK;
3115 OP c;
3116 EOP("add_apply_default(1)",a);
3117 EOP("add_apply_default(2)",b);
3118 c = CALLOCOBJECT();
3119 SWAP(b,c);
3120 ADD(a,c,b);
3121 FREEALL(c);
3122 ENDR("add_apply_default");
3123 }
3124
3125
multinom_small(a,b,c)3126 INT multinom_small(a,b,c) OP a,b,c;
3127 /* AK 120901 */
3128 {
3129 INT erg = OK,i;
3130 switch(S_I_I(a)) {
3131 case 1: M_I_I(1L,c);break;
3132 case 2: M_I_I(2L,c);break;
3133 case 3: M_I_I(6L,c);break;
3134 case 4: M_I_I(24L,c);break;
3135 case 5: M_I_I(120L,c);break;
3136 case 6: M_I_I(720L,c);break;
3137 case 7: M_I_I(5040L,c);break;
3138 case 8: M_I_I(40320L,c);break;
3139 case 9: M_I_I(362880,c);break;
3140 case 10: M_I_I(3628800L,c);break;
3141 case 11: M_I_I(39916800L,c);break;
3142 case 12: M_I_I(479001600L,c);break;
3143 default: error("wrong int value in multinom_small");goto endr_ende;
3144 }
3145 for (i=0;i<S_V_LI(b);i++)
3146 switch ( S_V_II(b,i) ) {
3147 case 0: break;
3148 case 1: break;
3149 case 2: M_I_I(S_I_I(c)/2L,c);break;
3150 case 3: M_I_I(S_I_I(c)/6L,c);break;
3151 case 4: M_I_I(S_I_I(c)/24L,c);break;
3152 case 5: M_I_I(S_I_I(c)/120L,c);break;
3153 case 6: M_I_I(S_I_I(c)/720L,c);break;
3154 case 7: M_I_I(S_I_I(c)/5040L,c);break;
3155 case 8: M_I_I(S_I_I(c)/40320L,c);break;
3156 case 9: M_I_I(S_I_I(c)/362880,c);break;
3157 case 10: M_I_I(S_I_I(c)/3628800L,c);break;
3158 case 11: M_I_I(S_I_I(c)/39916800L,c);break;
3159 case 12: M_I_I(S_I_I(c)/479001600L,c);break;
3160 default: error("wrong int value in multinom_small");goto endr_ende;
3161 }
3162 ENDR("multinom_small");
3163 }
3164
multinom(a,b,c)3165 INT multinom(a,b,c) OP a,b,c;
3166 /* AK 040892 */
3167 {
3168 OP d;
3169 INT i,erg = OK;
3170 CTO(INTEGER,"multinom(1)",a);
3171 CTTO(VECTOR,INTEGERVECTOR,"multinom(2)",b);
3172
3173 if (S_I_I(a) < 1) {
3174 error("multinom with negative value");
3175 goto endr_ende;
3176 }
3177
3178
3179 if (S_O_K(b) != INTEGERVECTOR)
3180 for (i=0L;i<S_V_LI(b);i++)
3181 if (S_O_K(S_V_I(b,i)) != INTEGER)
3182 {
3183 error("multinom:no integer vector");
3184 goto endr_ende;
3185 }
3186
3187 CE3(a,b,c,multinom);
3188
3189 if (S_I_I(a) <= 12 ) {
3190 erg += multinom_small(a,b,c);
3191 goto endr_ende;
3192 }
3193 M_I_I(1L,c);
3194 d = callocobject();
3195 for (i=0L;i<S_V_LI(b);i++)
3196 {
3197 erg += fakul(S_V_I(b,i),d);
3198 MULT_APPLY(d,c);
3199 }
3200 erg += invers_apply(c);
3201 erg += fakul(a,d);
3202 MULT_APPLY(d,c);
3203 FREEALL(d);
3204 ENDR("multinom");
3205 }
3206
3207
moebius_rekurs(n)3208 static INT moebius_rekurs(n) OP n;
3209 /* DL 030593 */
3210 {
3211 INT erg;
3212 OP i, h;
3213
3214 if (nullp(n))
3215 return 0L;
3216
3217 if (einsp(n))
3218 return 1L;
3219
3220 i = callocobject();
3221 h = callocobject();
3222 for (m_i_i(2L, i); mod(n, i, h), !nullp(h); inc(i));
3223 /* Koennte evtl. durch schnellere Version ersetzt werden, die
3224 nur Primzahlen durchlaeuft! */
3225
3226 if (eq(i, n))
3227 {
3228 erg = -1L;
3229 goto fertig;
3230 }
3231
3232 mult(i, i, h);
3233 mod(n, h, h);
3234 if (nullp(h))
3235 {
3236 erg = 0L;
3237 goto fertig;
3238 }
3239
3240 div(n, i, h);
3241 erg = -moebius_rekurs(h);
3242
3243 fertig:
3244 freeall(h);
3245 freeall(i);
3246 return erg;
3247 }
3248
3249
moebius(n,my)3250 INT moebius(n, my) OP n, my;
3251 /* DL 030593 */
3252 {
3253 INT erg = OK;
3254 if (n == NULL)
3255 {
3256 erg += error("moebius: input parameter == NULL");
3257 goto endr_ende;
3258 }
3259
3260 if (my == NULL)
3261 {
3262 erg += error("moebius: output parameter == NULL");
3263 goto endr_ende;
3264 }
3265
3266 if (S_O_K(n) != INTEGER && S_O_K(n) != LONGINT)
3267 {
3268 WTO("moebius", n);
3269 goto endr_ende;
3270 }
3271
3272 if (negp(n))
3273 {
3274 erg += error("moebius: input parameter negative");
3275 goto endr_ende;
3276 }
3277
3278 erg += m_i_i(moebius_rekurs(n), my);
3279 ENDR("moebius");
3280 }
3281
square_apply(a)3282 INT square_apply(a) OP a;
3283 /* a = a^2 */
3284 /* AK 271101 */
3285 {
3286 INT erg = OK;
3287 EOP("square_apply(1)",a);
3288 if (S_O_K(a) == INTEGER)
3289 erg += square_apply_integer(a);
3290 else if (S_O_K(a) == LONGINT)
3291 erg += square_apply_longint(a);
3292 else
3293 {
3294 OP b;
3295 b = CALLOCOBJECT();
3296 COPY(a,b);
3297 MULT_APPLY(b,a);
3298 FREEALL(b);
3299 }
3300
3301 ENDR("square_apply");
3302 }
3303
3304
bin_ggt(a,b,c)3305 INT bin_ggt(a,b,c) OP a,b,c;
3306 /* Knuth band 2 2. aufl. p.321 */
3307 {
3308 OP k,u,v,t;
3309 INT erg = OK;
3310 CTTO(LONGINT,INTEGER,"bin_ggt(1)",a);
3311 CTTO(LONGINT,INTEGER,"bin_ggt(2)",b);
3312
3313 k = CALLOCOBJECT();
3314 u = CALLOCOBJECT();
3315 v = CALLOCOBJECT();
3316 t = CALLOCOBJECT();
3317
3318 COPY(a,u);
3319 COPY(b,v);
3320 if (NEGP(u))
3321 {
3322 ADDINVERS_APPLY(u);
3323 }
3324 if (NEGP(v))
3325 {
3326 ADDINVERS_APPLY(v);
3327 }
3328 M_I_I(0,k);
3329
3330 b1:
3331 if (odd(u)) goto b2;
3332 if (odd(v)) goto b2;
3333 erg += half_apply(u);
3334 erg += half_apply(v);
3335 INC_INTEGER(k);
3336 goto b1;
3337 b2:
3338 if (odd(u)) {
3339 ADDINVERS(v,t);
3340 goto b4;}
3341 else
3342 COPY(u,t);
3343 b3:
3344 erg += half_apply(t);
3345 b4:
3346 if (even(t)) goto b3;
3347 /* b5: */
3348 if (POSP(t))
3349 {
3350 FREESELF(u);
3351 COPY(t,u);
3352 ADDINVERS_APPLY(v);
3353 ADD_APPLY(v,t);
3354 ADDINVERS_APPLY(v);
3355 }
3356 else {
3357 ADDINVERS_APPLY(t);
3358 FREESELF(v);
3359 COPY(t,v);
3360 ADD_APPLY(u,t);
3361 }
3362 /* b6: */
3363 if (not NULLP(t)) goto b3;
3364
3365 if (not NULLP(k)) {
3366 erg += hoch(cons_zwei,k,c);
3367 MULT_APPLY(u,c);
3368 }
3369 else {
3370 FREESELF(c);
3371 SWAP(u,c);
3372 }
3373 FREEALL(u);
3374 FREEALL(t);
3375 FREEALL(v);
3376 FREEALL(k);
3377 ENDR("bin_ggt");
3378 }
3379
3380
3381
3382 #ifdef UNDEF
extended_ggt(a,b,c,d,e)3383 INT extended_ggt(a,b,c,d,e) OP a,b,c,d,e;
3384 /* c = ggt = da + eb */
3385 /* AK 051294 */
3386 /* Kn Bd2 p.325 */
3387 {
3388 INT erg = OK;
3389 OP v,u,t;
3390 OP q;
3391 EOP("extended_ggt(1)",a);
3392 EOP("extended_ggt(2)",b);
3393 COP("extended_ggt(3)",c);
3394 COP("extended_ggt(4)",d);
3395 COP("extended_ggt(5)",e);
3396 u = callocobject();
3397 v = callocobject();
3398 t = callocobject();
3399 q = callocobject();
3400 erg += m_il_v(3L,v);
3401 erg += m_il_v(3L,t);
3402 erg += m_il_v(3L,u);
3403 erg += m_i_i(1L,S_V_I(u,0L));
3404 erg += m_i_i(0L,S_V_I(u,1L));
3405 erg += copy(a,S_V_I(u,2L));
3406 erg += m_i_i(0L,S_V_I(v,0L));
3407 erg += m_i_i(1L,S_V_I(v,1L));
3408 erg += copy(b,S_V_I(v,2L));
3409 x2:
3410 if (nullp(S_V_I(v,2L)))
3411 goto ende;
3412 erg += ganzdiv(S_V_I(u,2L),S_V_I(v,2L),q);
3413 erg += mult(q,v,q);
3414 erg += sub(u,q,t);
3415 erg += copy(v,u);
3416 erg += copy(t,v);
3417
3418 goto x2;
3419 ende:
3420 erg += copy(S_V_I(u,0L),d);
3421 erg += copy(S_V_I(u,1L),e);
3422 erg += copy(S_V_I(u,2L),c);
3423 erg += freeall(q);
3424 erg += freeall(v);
3425 erg += freeall(t);
3426 erg += freeall(u);
3427 ENDR("extended_ggt");
3428 }
3429 #endif
3430
3431 /* extended euklid algorithm */
gcd_ex(a,b,c,d,e)3432 INT gcd_ex(a,b,c,d,e) OP a,b,c,d,e;
3433 /* AK 020703 */
3434 /* c = da+be ; c = gcd(a,b) */
3435 {
3436 INT erg = OK;
3437 CTTO(INTEGER,LONGINT,"gcd_ex(1)",a);
3438 CTTO(INTEGER,LONGINT,"gcd_ex(2)",b);
3439 if ((a == c) || (a==d) || (a==e))
3440 {
3441 OP v;
3442 v=CALLOCOBJECT(); SWAP(a,v);
3443 erg += gcd_ex(v,b,c,d,e);
3444 FREEALL(v); goto endr_ende;
3445 }
3446 if ((b == c) || (b==d) || (b==e))
3447 {
3448 OP v;
3449 v=CALLOCOBJECT(); SWAP(b,v);
3450 erg += gcd_ex(a,v,c,d,e);
3451 FREEALL(v); goto endr_ende;
3452 }
3453
3454 FREESELF(c);
3455 FREESELF(d);
3456 FREESELF(e);
3457 if (NULLP(a))
3458 {
3459 COPY(b,c);
3460 M_I_I(0,d);
3461 M_I_I(1,e);
3462 }
3463 else if (NULLP(b))
3464 {
3465 COPY(a,c);
3466 M_I_I(1,d);
3467 M_I_I(0,e);
3468 }
3469 else if (NEGP(a))
3470 {
3471 ADDINVERS_APPLY(a);
3472 erg += gcd_ex(a,b,c,d,e);
3473 ADDINVERS_APPLY(a);
3474 ADDINVERS_APPLY(c);
3475 ADDINVERS_APPLY(d);
3476 ADDINVERS_APPLY(e);
3477 }
3478 else if (NEGP(b))
3479 {
3480 ADDINVERS_APPLY(b);
3481 erg += gcd_ex(a,b,c,d,e);
3482 ADDINVERS_APPLY(b);
3483 ADDINVERS_APPLY(c);
3484 ADDINVERS_APPLY(d);
3485 ADDINVERS_APPLY(e);
3486 }
3487 else
3488 {
3489 OP v1,v2;
3490 OP q,r;
3491 INT i;
3492 CALLOCOBJECT4(v1,v2,q,r);
3493 /*init*/
3494 m_il_v(3,v1);
3495 m_il_v(3,v2);
3496 COPY(a,S_V_I(v1,0));M_I_I(1,S_V_I(v1,1));M_I_I(0,S_V_I(v1,2));
3497 COPY(b,S_V_I(v2,0));M_I_I(1,S_V_I(v2,2));M_I_I(0,S_V_I(v2,1));
3498
3499 do {
3500 if (LT(S_V_I(v1,0),S_V_I(v2,0))) SWAP(v1,v2);
3501
3502 quores(S_V_I(v1,0),S_V_I(v2,0),q,r);
3503 if (NULLP(r)) {
3504 SWAP(c,S_V_I(v2,0));
3505 SWAP(d,S_V_I(v2,1));
3506 SWAP(e,S_V_I(v2,2));
3507 goto ende;
3508 }
3509 ADDINVERS_APPLY(q);
3510 for (i=0;i<3;i++)
3511 {
3512 FREESELF(r);
3513 MULT(q,S_V_I(v2,i),r);
3514 ADD_APPLY(r,S_V_I(v1,i));
3515 }
3516 } while(1);
3517
3518 ende:
3519 FREEALL4(q,r,v1,v2);
3520 }
3521
3522 ENDR("gcd_ex");
3523 }
3524