1 /* SYMMETRICA file:rest.c */
2 #include "def.h"
3 #include "macro.h"
4
5
6 #ifdef SKEWPARTTRUE
7 static struct skewpartition * callocskewpartition();
8 #endif /* SKEWPARTTRUE */
9 #ifdef WORDTRUE
10 static INT coroutine250488();
11 #endif /* WORDTRUE */
12
13
14
15
callocobject_anfang()16 INT callocobject_anfang()
17 {
18 return OK;
19 }
20
callocobject_ende()21 INT callocobject_ende()
22 {
23 return OK;
24 }
25
check_equal_3(a,b,c,f,e)26 INT check_equal_3(a,b,c,f,e) OP a,b,c; INT (*f)(), *e;
27 /* the OP a and b and c are compared
28 return : EQUAL if a == c or b==c , is in this case the function was
29 evaluated in *e we have the return value
30 b is freed
31 */
32 /* AK 240398 V2.0 */
33 {
34 if ((a==c) && (b == c))
35 {
36 OP d = callocobject();
37 *d = *c;
38 C_O_K(c,EMPTY);
39 *e = (*f)(d,d,c);
40 *e += freeall(d);
41 return EQUAL;
42 }
43 else if (a==c)
44 {
45 OP d = callocobject();
46 *d = *c;
47 C_O_K(c,EMPTY);
48 *e = (*f)(d,b,c);
49 *e += freeall(d);
50 return EQUAL;
51 }
52 else if (b==c)
53 {
54 OP d = callocobject();
55 *d = *c;
56 C_O_K(c,EMPTY);
57 *e = (*f)(a,d,c);
58 *e += freeall(d);
59 return EQUAL;
60 }
61 else
62 {
63 *e = OK;
64 if (c != NULL)
65 if (not EMPTYP(c))
66 *e += freeself(c);
67 return OK;
68 }
69 }
check_equal_4(a,b,c,d,f,e)70 INT check_equal_4(a,b,c,d,f,e) OP a,b,c,d; INT (*f)(), *e;
71 /* the OP a and b and c are compared
72 return : EQUAL if a == d or b==d or d==c, is in this case the function was
73 evaluated in *e we have the return value
74 */
75 {
76 if (a==d)
77 {
78 OP dd = callocobject();
79 *dd = *d;
80 C_O_K(d,EMPTY);
81 *e = (*f)(dd,b,c,d);
82 *e += freeall(dd);
83 return EQUAL;
84 }
85 else if (b==d)
86 {
87 OP dd = callocobject();
88 *dd = *d;
89 C_O_K(d,EMPTY);
90 *e = (*f)(a,dd,c,d);
91 *e += freeall(dd);
92 return EQUAL;
93 }
94 else if (c==d)
95 {
96 OP dd = callocobject();
97 *dd = *d;
98 C_O_K(d,EMPTY);
99 *e = (*f)(a,b,dd,d);
100 *e += freeall(dd);
101 return EQUAL;
102 }
103 else
104 {
105 *e = OK;
106 if (d != NULL)
107 if (not EMPTYP(d))
108 *e += freeself(d);
109 return OK;
110 }
111 }
112
check_equal_2(a,b,f,e)113 INT check_equal_2(a,b,f,e) OP a,b; INT (*f)(), *e;
114 /* the OP a and b are compared
115 return : EQUAL if a == b , is in this case the function was
116 evaluated in *e we have the return value
117 b is freed
118 */
119 {
120 INT erg = OK;
121 if (a==b)
122 {
123 OP c;
124 c = CALLOCOBJECT();
125 *c = *b;
126 C_O_K(b,EMPTY);
127 *e = (*f)(c,b);
128 FREEALL(c);
129 return EQUAL;
130 }
131 else
132 {
133 *e = OK;
134 FREESELF(b);
135 return OK;
136 }
137 ENDR("check_equal_2");
138 }
check_equal_2a(a,b,f,e)139 INT check_equal_2a(a,b,f,e) OP a,b; INT (*f)(), *e;
140 /* apply version, work with copy of a */
141 /* the OP a and b are compared
142 return : EQUAL if a == b , is in this case the function was
143 evaluated in *e we have the return value
144 b is freed
145 */
146 /* AK 240398 V2.0 */
147 {
148 if (a==b)
149 {
150 OP c = callocobject();
151 *e = copy(a,c);
152 *e += (*f)(c,b);
153 *e += freeall(c);
154 return EQUAL;
155 }
156 else
157 {
158 *e = OK;
159 return OK;
160 }
161 }
162
163
164 #define SYMDIR "./symresults"
165 INT sym_no_results=0; /* 0 == stored results will be used */
166 /* 1 == stored results will not be used */
167
check_fopen(f,r)168 static FILE *check_fopen(f,r) char *f, *r;
169 /* AK 240398 V2.0 */
170 {
171 char t1[300];
172 if (sym_no_results==1)
173 return NULL;
174 sprintf(t1,"%s/%s",SYMDIR,f);
175 return fopen(t1,r);
176 }
177
check_result_0(t,c)178 INT check_result_0(t,c) OP c; char *t;
179 /* testet ob ein vorberechnetes result da ist */
180 /* AK 280705 V3.0 */
181 {
182 char t1[100],t3[100];
183 FILE *fp;
184 INT erg = OK;
185
186 COP("check_result_0(1)",t);
187
188 fp = check_fopen(t,"r");
189 if (fp == NULL)
190 return NORESULT;
191 erg += objectread(fp,c);
192 fclose(fp);
193 ENDR("check_result_0");
194 }
195
check_result_1(a,t,c)196 INT check_result_1(a,t,c) OP a,c; char *t;
197 /* testet ob ein vorberechnetes result da ist */
198 /* AK 020996 */
199 /* AK 240398 V2.0 */
200 {
201 char t1[100],t3[100];
202 FILE *fp;
203 INT erg = OK;
204
205 COP("check_result(2)",t);
206 EOP("check_result(1)",a);
207
208 sprint(t1,a);
209 sprintf(t3,"%s_%s",t,t1);
210 fp = check_fopen(t3,"r");
211 if (fp == NULL)
212 return NORESULT;
213 erg += objectread(fp,c);
214 fclose(fp);
215 ENDR("check_result_1");
216 }
217
check_result_2(a,b,t,c)218 INT check_result_2(a,b,t,c) OP a,b,c; char *t;
219 /* testet ob ein vorberechnetes result da ist */
220 /* AK 020996 */
221 /* AK 240398 V2.0 */
222 {
223 char t1[100],t2[100],t3[100];
224 FILE *fp;
225 INT erg = OK;
226 COP("check_result(3)",t);
227 EOP("check_result(1)",a);
228 EOP("check_result(2)",b);
229
230 sprint(t1,a);
231 sprint(t2,b);
232 sprintf(t3,"%s_%s_%s",t,t1,t2);
233 fp = check_fopen(t3,"r");
234 if (fp == NULL)
235 return NORESULT;
236 erg += objectread(fp,c);
237 fclose(fp);
238 ENDR("check_result_2");
239 }
240
check_result_3(a,b,d,t,c)241 INT check_result_3(a,b,d,t,c) OP a,b,d,c; char *t;
242 /* check if there is a stored result */
243 /* AK 020996 */ /* AK 240398 V2.0 */
244 {
245 char t1[100],t2[100],t3[100],t4[100];
246 FILE *fp;
247 INT erg = OK;
248 COP("check_result(4)",t);
249 EOP("check_result(1)",a);
250 EOP("check_result(2)",b);
251 EOP("check_result(3)",d);
252
253 sprint(t1,a); sprint(t2,b); sprint(t4,d);
254 sprintf(t3,"%s_%s_%s_%s",t,t1,t2,t4);
255 fp = check_fopen(t3,"r");
256 if (fp == NULL)
257 return NORESULT;
258 erg += objectread(fp,c);
259 fclose(fp);
260 ENDR("check_result_3");
261 }
262
check_result_5(a,b,d,e,f,t,c)263 INT check_result_5(a,b,d,e,f,t,c) OP a,b,d,c,e,f; char *t;
264 /* check if there is a stored result */
265 /* AK 240805 */
266 {
267 char t1[100],t2[100],t3[100],t4[100],t5[100],t6[100];
268 FILE *fp;
269 INT erg = OK;
270 COP("check_result(6)",t);
271 EOP("check_result(1)",a);
272 EOP("check_result(2)",b);
273 EOP("check_result(3)",d);
274 EOP("check_result(4)",e);
275 EOP("check_result(5)",f);
276
277 sprint(t1,a); sprint(t2,b); sprint(t4,d);
278 sprint(t5,e);sprint(t6,f);
279
280 sprintf(t3,"%s_%s_%s_%s_%s_%s",t,t1,t2,t4,t5,t6);
281 fp = check_fopen(t3,"r");
282 if (fp == NULL)
283 return NORESULT;
284 erg += objectread(fp,c);
285 fclose(fp);
286 ENDR("check_result_5");
287 }
288
289
290
store_result_0(t,c)291 INT store_result_0(t,c) OP c; char *t;
292 /* stores a result without parameter */
293 /* AK 280705 V3.0 */
294 {
295 FILE *fp;
296 INT erg = OK;
297 fp = check_fopen(t,"w");
298 if (fp == NULL) { goto endr_ende; } /* error, silently not storing */
299 erg += objectwrite(fp,c);
300 fclose(fp);
301 ENDR("store_result_0");
302 }
303
store_result_1(a,t,c)304 INT store_result_1(a,t,c) OP a,c; char *t;
305 /* speichere ein berechnetes result zu einem parameter */ /* AK 020996 */
306 /* AK 240398 V2.0 */
307 {
308 char t1[100],t3[100];
309 FILE *fp;
310 INT erg = OK;
311 sprint(t1,a);
312 sprintf(t3,"%s_%s",t,t1);
313 fp = check_fopen(t3,"w");
314 if (fp == NULL) { goto endr_ende; } /* nicht gespeichert */
315 erg += objectwrite(fp,c);
316 fclose(fp);
317 ENDR("store_result_1");
318 }
319
store_result_2(a,b,t,c)320 INT store_result_2(a,b,t,c) OP a,b,c; char *t;
321 /* speichere ein berechnetes result zu zwei parametern */
322 /* AK 020996 */
323 /* AK 240398 V2.0 */
324 {
325 char t1[100],t2[100],t3[100];
326 FILE *fp;
327 INT erg = OK;
328 sprint(t1,a);
329 sprint(t2,b);
330 sprintf(t3,"%s_%s_%s",t,t1,t2);
331 fp = check_fopen(t3,"w");
332 if (fp == NULL) { goto endr_ende; } /* nicht gespeichert */
333 erg += objectwrite(fp,c);
334 fclose(fp);
335 ENDR("store_result_2");
336 }
337
store_result_3(a,b,d,t,c)338 INT store_result_3(a,b,d,t,c) OP d,a,b,c; char *t;
339 /* speichere ein berechnetes result zu zwei parametern */
340 /* AK 020996 */
341 /* AK 240398 V2.0 */
342 {
343 char t1[100],t2[100],t3[100],t4[100];
344 FILE *fp;
345 INT erg = OK;
346 sprint(t1,a); sprint(t2,b); sprint(t4,d);
347 sprintf(t3,"%s_%s_%s_%s",t,t1,t2,t4);
348 fp = check_fopen(t3,"w");
349 if (fp == NULL) { goto endr_ende; }
350 /* nicht gespeichert */
351 erg += objectwrite(fp,c);
352 fclose(fp);
353 ENDR("store_result_2");
354 }
355
store_result_5(a,b,d,e,f,t,c)356 INT store_result_5(a,b,d,e,f,t,c) OP d,a,b,c,e,f; char *t;
357 /* stores a result indexed by 5 parameters */
358 /* AK 240805 */
359 {
360 char t1[100],t2[100],t3[100],t4[100],t5[100],t6[100];
361 FILE *fp;
362 INT erg = OK;
363 sprint(t1,a); sprint(t2,b); sprint(t4,d);
364 sprint(t5,e);sprint(t6,f);
365 sprintf(t3,"%s_%s_%s_%s_%s_%s",t,t1,t2,t4,t5,t6);
366 fp = check_fopen(t3,"w");
367 if (fp == NULL) { goto endr_ende; }
368 /* nicht gespeichert */
369 erg += objectwrite(fp,c);
370 fclose(fp);
371 ENDR("store_result_5");
372 }
373
store_result_4(a,b,d,e,t,c)374 INT store_result_4(a,b,d,e,t,c) OP d,a,b,c,e; char *t;
375 /* stores a result indexed by 4 parameters */
376 /* AK 250607 */
377 {
378 char t1[100],t2[100],t3[100],t4[100],t5[100],t6[100];
379 FILE *fp;
380 INT erg = OK;
381 sprint(t1,a); sprint(t2,b); sprint(t4,d);
382 sprint(t5,e);
383 sprintf(t3,"%s_%s_%s_%s_%s",t,t1,t2,t4,t5);
384 fp = check_fopen(t3,"w");
385 if (fp == NULL) { goto endr_ende; }
386 /* nicht gespeichert */
387 erg += objectwrite(fp,c);
388 fclose(fp);
389 ENDR("store_result_4");
390 }
391
392
393
394
empty_object(t)395 INT empty_object(t) char *t;
396 /* AK 220997 */
397 /* AK 240398 V2.0 */
398 {
399 fprintf(stderr,"function: %s \n",t);
400 return error("empty object as parameter");
401 }
402
null_object(t)403 INT null_object(t) char *t;
404 /* AK 211093 */
405 /* AK 240398 V2.0 */
406 {
407 fprintf(stderr,"function: %s \n",t);
408 return error("null object as parameter");
409 }
410
not_yet_implemented(t)411 INT not_yet_implemented(t) char *t;
412 /* AK 211093 */
413 /* AK 240398 V2.0 */
414 {
415 fprintf(stderr,"function: %s \n",t);
416 return error("not yet implemented");
417 }
418
equal_2_error()419 INT equal_2_error() {
420 fprintf(stderr,"internal error: two parameter equal, this should not happen");
421 return I2PE;
422 }
error_during_computation(t)423 INT error_during_computation(t) char *t;
424 /* AK 090393 */ /* AK 240398 V2.0 */
425 {
426 INT err;
427 fprintf(stderr,"function: %s \n",t);
428 err = error("error during computation");
429 return ERROR;
430 }
error_during_computation_code(t,code)431 INT error_during_computation_code(t,code) char *t; INT code;
432 /* AK 170698 V2.0 */
433 {
434 INT err;
435 fprintf(stderr, "function: %s code: %" PRIINT " \n" ,t,code);
436 err = error("error during computation");
437 return ERROR;
438 }
439
440
wrong_type_twoparameter(t,a,b)441 INT wrong_type_twoparameter(t,a,b) char *t; OP a,b;
442 /* AK 090393 */
443 /* AK 240398 V2.0 */
444 {
445 fprintf(stderr,"function: %s not definied for object types:\n",t);
446 fprintf(stderr,"type of first parameter:");
447 printobjectkind(a);
448 fprintf(stderr,"type of second parameter:");
449 printobjectkind(b);
450 return error("function with wrong input types");
451 }
452
wrong_type_oneparameter(t,a)453 INT wrong_type_oneparameter(t,a) char *t; OP a;
454 /* AK 090393 */
455 /* AK 240398 V2.0 */
456 {
457 fprintf(stderr,"function: %s not definied for object type:\n",t);
458 printobjectkind(a);
459 return error("function with wrong input type");
460 }
461
swap(a,b)462 INT swap(a,b) OP a,b;
463 /* AK 280388 */ /* AK 280689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */
464 /* a becomes b and b becomes a */
465 /* AK 240398 V2.0 */
466 {
467 INT erg = OK;
468 struct object c;
469 SYMCHECK(a == b,"swap:identical");
470
471 c = *a;
472 *a = *b;
473 *b = c;
474 ENDR("swap");
475 }
476
rz(a,b)477 INT rz(a,b) OP a, b;
478 /* AK 261087 berechnet die reduzierte Zerlegung */
479 /* AK 280689 V1.0 */ /* AK 181289 V1.1 */ /* AK 120391 V1.2 */
480 /* AK 210891 V1.3 */
481 /* AK 240398 V2.0 */
482 {
483 INT erg = OK;
484 EOP("rz(1)",a);
485 COP("rz(2)",b);
486 CE2(a,b,rz);
487
488 switch(S_O_K(a))
489 {
490 #ifdef PERMTRUE
491 case PERMUTATION :
492 switch(S_P_K(a))
493 {
494 case VECTOR:
495 erg += rz_perm(a,b);break;
496 case BAR:
497 erg += rz_bar(a,b);break;
498 }
499 break;
500 case INTEGERVECTOR:
501 case VECTOR:
502 switch(S_O_K(S_V_I(a,0L)))
503 {
504 case INTEGER:
505 erg += rz_lehmercode(a,b);
506 break;
507 case VECTOR:
508 erg += rz_lehmercode_bar(a,b);
509 break;
510 }
511 break;
512 #endif /* PERMTRUE */
513 default:
514 erg+= WTO("rz(1)",a);
515 break;
516
517 };
518 ENDR("rz");
519 }
520
lastof(a,res)521 INT lastof(a,res) OP a,res;
522 /* AK 280689 V1.0 */ /* AK 090790 V1.1 */ /* AK 200691 V1.2 */
523 /* AK 210891 V1.3 */
524 /* AK 020398 V2.0 */
525 /* input: ..
526 output: a copy of the last elemnent */
527 {
528 INT erg = OK;
529 EOP("lastof(1)",a);
530 COP("lastof(2)",res);
531 CE2(a,res,lastof);
532
533 switch(S_O_K(a))
534 {
535 #ifdef PARTTRUE
536 case PARTITION:
537 erg+=lastof_partition(a,res);
538 break;
539 #endif /* PARTTRUE */
540
541 #ifdef SKEWPARTTRUE
542 case SKEWPARTITION :
543 erg+=lastof_skewpartition(a,res);
544 break;
545 #endif /* SKEWPARTTRUE */
546
547 #ifdef VECTORTRUE
548 case INTEGERVECTOR:
549 erg+=lastof_integervector(a,res);
550 break;
551
552 case VECTOR :
553 erg+=lastof_vector(a,res);
554 break;
555 #endif /* VECTORTRUE */
556
557 default:
558 erg+= WTO("lastof(1)",a);
559 break;
560 };
561 ENDR("lastof");
562 }
563
564 INT freeall_speicherposition;
565 INT freeall_speichersize;
566 OP *freeall_speicher; /* global variable for callocobject/freeall */
567
speicher_anfang()568 INT speicher_anfang()
569 /* AK 231001 */
570 {
571 INT erg = OK;
572 freeall_speicher=(OP *)SYM_MALLOC(SPEICHERSIZE * sizeof(OP));
573 SYMCHECK( (freeall_speicher == NULL), "speicher_anfang:no mem");
574 freeall_speicherposition = -1;
575 freeall_speichersize=SPEICHERSIZE;
576 ENDR("speicher_anfang");
577 }
578
speicher_ende()579 INT speicher_ende()
580 /* AK 231001 */
581 {
582 INT i;
583 for (i=freeall_speicherposition;i>=0L;i--) /* AK 161091 */
584 {
585 SYM_free(freeall_speicher[i]); /* AK 161091 */
586 }
587 SYM_FREE(freeall_speicher); /* AK 161091 */
588 return OK;
589 }
590
591
freeall_magma(a)592 INT freeall_magma(a) OP a;
593 {
594 if (not EMPTYP(a))
595 freeself(a);
596 SYM_FREE(a);
597 return OK;
598 }
599
freeall(a)600 INT freeall(a) OP a;
601 /* AK 101286 */ /* AK 280689 V1.0 */ /* AK 071289 V1.1 */
602 /* AK 270291 V1.2 */ /* AK 050891 V1.3 */
603 {
604 INT erg = OK;
605
606 COP("freeall(1)",a);
607
608 if (not EMPTYP(a))
609 erg += freeself(a);
610
611 if (freeall_speicherposition+1 == freeall_speichersize) /* AK 231001 */
612 {
613 freeall_speicher = (OP *)
614 SYM_realloc(freeall_speicher,
615 (freeall_speichersize+SPEICHERSIZE)*sizeof(OP));
616 SYMCHECK( (freeall_speicher == NULL) ,"freeall:no more memory");
617 freeall_speichersize = freeall_speichersize+SPEICHERSIZE;
618 }
619 freeall_speicher[++freeall_speicherposition] = a;
620
621 ENDR("freeall");
622 }
623
624
freeself(a)625 INT freeself(a) OP a;
626 /* AK 061186 */ /* AK 280689 V1.0 */ /* AK 041289 V1.1 */ /* AK 050891 V1.3 */
627 /* AK 070498 V2.0 */
628 {
629 INT erg=OK;
630 COP("freeself(1)",a);
631
632 switch(S_O_K(a))
633 {
634 case EMPTY:
635 break;
636 #ifdef BINTREETRUE
637 case BINTREE :
638 erg += freeself_bintree(a);
639 break;
640 #endif /* BINTREETRUE */
641
642 #ifdef BRUCHTRUE
643 case BRUCH :
644 erg += freeself_bruch(a);
645 break;
646 #endif /* BRUCHTRUE */
647 #ifdef FFTRUE
648 case FF :
649 erg += freeself_ff(a);
650 break;
651 #endif /* FFTRUE */
652 case INTEGER :
653 erg += FREESELF_INTEGER(a);
654 break;
655 #ifdef LISTTRUE
656 case GRAL: case HOM_SYM: case POW_SYM: case MONOPOLY:
657 case POLYNOM: case SCHUR: case SCHUBERT: case ELM_SYM:
658 case LIST: case MONOMIAL:
659 erg += freeself_list(a);
660 break;
661 #endif /* LISTTRUE */
662 #ifdef LONGINTTRUE
663 case LONGINT :
664 erg += freeself_longint(a);
665 break;
666 #endif /* LONGINTTRUE */
667 #ifdef MATRIXTRUE
668 case KRANZTYPUS :
669 erg += freeself_kranztypus(a);
670 break;
671 case KOSTKA :
672 case MATRIX :
673 erg += freeself_matrix(a);
674 break;
675 case INTEGERMATRIX:
676 erg += freeself_integermatrix(a);
677 break;
678 #endif /* MATRIXTRUE */
679 #ifdef MONOMTRUE
680 case MONOM :
681 erg += freeself_monom(a);
682 break;
683 #endif /* MONOMTRUE */
684 #ifdef NUMBERTRUE
685 case SQ_RADICAL:
686 case CYCLOTOMIC:
687 erg += freeself_number(a);
688 break;
689 #endif /* NUMBERTRUE */
690 #ifdef PARTTRUE
691 case AUG_PART :
692 case CHARPARTITION:
693 case PARTITION :
694 erg += freeself_partition(a);
695 break;
696 #endif /* PARTTRUE */
697 #ifdef PERMTRUE
698 case PERMUTATION :
699 erg += freeself_permutation(a);
700 break;
701 #endif /* PERMTRUE */
702 #ifdef REIHETRUE
703 case REIHE :
704 erg += freeself_reihe(a);
705 break;
706 #endif /* REIHETRUE */
707 #ifdef SKEWPARTTRUE
708 case SKEWPARTITION :
709 erg += freeself_skewpartition(a);
710 break;
711 #endif /* PERMTRUE */
712 #ifdef CHARTRUE
713 case SYMCHAR :
714 erg += freeself_symchar(a);
715 break;
716 #endif /* CHARTRUE */
717 #ifdef TABLEAUXTRUE
718 case TABLEAUX :
719 erg += freeself_tableaux(a);
720 break;
721 #endif /* TABLEAUXTRUE */
722 #ifdef VECTORTRUE
723 case HASHTABLE:
724 erg += freeself_hashtable(a);
725 break;
726 case LAURENT:
727 erg += freeself_laurent(a);
728 break;
729 #ifdef KRANZTRUE
730 case KRANZ:
731 erg += freeself_kranz(a);
732 break;
733 #endif /* KRANZTRUE */
734 case WORD:
735 case QUEUE:
736 case VECTOR:
737 erg += freeself_vector(a);
738 break;
739 case BITVECTOR:
740 erg += freeself_bitvector(a);
741 break;
742 case SUBSET:
743 case INTEGERVECTOR:
744 case COMPOSITION:
745 erg += freeself_integervector(a);
746 break;
747 case GALOISRING:
748 erg += freeself_galois(a);
749 break;
750 #endif /* VECTORTRUE */
751 default:
752 erg += WTO("freeself(1)",a);
753 break;
754 };
755 CTO(EMPTY,"freeself(e1)",a);
756 ENDR("freeself");
757 }
758
copy(a,b)759 INT copy(a,b) OP a, b;
760 /* AK 280689 V1.0 */ /* AK 201289 V1.1 */ /* AK 050891 V1.3 */
761 {
762 INT erg = OK;
763 if (sym_timelimit > 0L)
764 check_time();
765
766 if (a == b) return(OK);
767 COP("copy(1)",a);
768 COP("copy(2)",b);
769 FREESELF(b);
770
771 switch(S_O_K(a))
772 {
773 case EMPTY:
774 break;
775 #ifdef BINTREETRUE
776 case BINTREE :
777 erg += copy_bintree(a,b);
778 break;
779 #endif /* BINTREETRUE */
780
781 #ifdef BRUCHTRUE
782 case BRUCH :
783 erg += copy_bruch(a,b);
784 break;
785 #endif /* BRUCHTRUE */
786
787 #ifdef FFTRUE
788 case FF:
789 erg += copy_ff(a,b);
790 break;
791 #endif /* FFTRUE */
792
793 #ifdef INTEGERTRUE
794 case INTEGER :
795 COPY_INTEGER(a,b);
796 break;
797 #endif /* INTEGERTRUE */
798
799 #ifdef LISTTRUE
800 case POLYNOM: case GRAL:
801 case MONOPOLY:
802 case SCHUBERT: case LIST :
803 erg += copy_list(a,b);
804 break;
805 case SCHUR:
806 erg += copy_schur(a,b);
807 break;
808 case HOMSYM:
809 erg += copy_homsym(a,b);
810 break;
811 case MONOMIAL:
812 erg += copy_monomial(a,b);
813 break;
814 case POWSYM:
815 erg += copy_powsym(a,b);
816 break;
817 case ELMSYM:
818 erg += copy_elmsym(a,b);
819 break;
820
821 #endif /* LISTTRUE */
822 #ifdef LONGINTTRUE
823 case LONGINT :
824 erg += copy_longint(a,b);
825 break;
826 #endif /* LONGINTTRUE */
827 #ifdef MATRIXTRUE
828 case INTEGERMATRIX:
829 erg += copy_integermatrix(a,b);
830 break;
831 case KRANZTYPUS :
832 erg += copy_kranztypus(a,b);
833 break;
834 case KOSTKA :
835 case MATRIX :
836 erg += copy_matrix(a,b);
837 break;
838
839 #endif /* MATRIXTRUE */
840 #ifdef MONOMTRUE
841 case MONOM :
842 erg += copy_monom(a,b);
843 break;
844 #endif /* MONOMTRUE */
845 #ifdef NUMBERTRUE
846 case SQ_RADICAL:
847 case CYCLOTOMIC: erg += copy_number(a,b);break;
848 #endif /* NUMBERTRUE */
849 #ifdef PARTTRUE
850 case AUG_PART :
851 case PARTITION : erg += copy_partition(a,b);break;
852 #endif /* PARTTRUE */
853 #ifdef PERMTRUE
854 case PERMUTATION : erg += copy_permutation(a,b);break;
855 #endif /* PERMTRUE */
856 #ifdef REIHETRUE
857 case REIHE : erg += copy_reihe(a,b);break;
858 #endif /* REIHETRUE */
859 #ifdef SKEWPARTTRUE
860 case SKEWPARTITION : erg += copy_skewpartition(a,b);break;
861 #endif /* SKEWPARTTRUE */
862 #ifdef CHARTRUE
863 case SYMCHAR : erg += copy_symchar(a,b);break;
864 #endif /* CHARTRUE */
865 #ifdef TABLEAUXTRUE
866 case TABLEAUX : erg += copy_tableaux(a,b);break;
867 #endif /* TABLEAUXTRUE */
868 #ifdef VECTORTRUE
869 case HASHTABLE:
870 erg += copy_hashtable(a,b);
871 break;
872 case COMPOSITION:
873 erg += copy_composition(a,b);
874 break;
875 case WORD:
876 erg += copy_word(a,b);
877 break;
878 case KRANZ:
879 erg += copy_kranz(a,b);
880 break;
881 case SUBSET:
882 erg += copy_subset(a,b);
883 break;
884 case LAURENT:
885 erg += copy_laurent(a,b);
886 break;
887 case QUEUE:
888 erg += copy_queue(a,b);
889 break;
890 case VECTOR:
891 erg += copy_vector(a,b);
892 break;
893 case INTEGERVECTOR:
894 erg += copy_integervector(a,b); break;
895 case GALOISRING:
896 erg += copy_galois(a,b); break;
897 case BITVECTOR:
898 erg += copy_bitvector(a,b); break;
899 #endif /* VECTORTRUE */
900 default:
901 erg+= WTO("copy(1)",a);
902 break;
903 };
904
905 ENDR("copy");
906 }
907
append_apply(a,b)908 INT append_apply(a,b) OP a,b;
909 /* AK 060901 */
910 /* a := [a1,...,ak,b1,...,bl] */
911 {
912 INT erg = OK;
913 COP("append_apply(1)",a);
914 COP("append_apply(2)",b);
915 /* a and b may be equal here */
916 switch(S_O_K(a))
917 {
918 #ifdef PARTTRUE
919 case PARTITION :
920 erg += append_apply_part(a,b);
921 break;
922 #endif /* PARTTRUE */
923 #ifdef VECTORTRUE
924 case INTEGERVECTOR:
925 case WORD:
926 case QUEUE:
927 case COMPOSITION:
928 case SUBSET:
929 case VECTOR :
930 erg += append_apply_vector(a,b);
931 break;
932 #endif /* VECTORTRUE */
933 default:
934 erg+= WTO("append_apply",a);
935 break;
936 };
937 ENDR("append_apply");
938 }
939
append(a,b,e)940 INT append(a,b,e) OP a,b,e;
941 /* AK 280689 V1.0 */ /* AK 221289 V1.1 */
942 /* AK 190291 V1.2 */ /* AK 090891 V1.3 */
943 /* e := [a1,...,ak,b1,...,bl] */
944 /* AK 241006 V3.1 */
945 {
946 INT erg = OK;
947 if (a == e) {
948 erg += append_apply(a,b);
949 goto endr_ende;
950 }
951 CE3(a,b,e,append);
952
953 if (EMPTYP(b)) {
954 erg += copy(a,e);
955 goto endr_ende;
956 }
957 switch(S_O_K(a))
958 {
959 case LIST: /* missing */
960 NYI("append with lists");
961 break;
962 #ifdef PARTTRUE
963 case PARTITION :
964 erg += append_part_part(a,b,e);
965 break;
966 #endif /* PARTTRUE */
967
968 #ifdef VECTORTRUE
969 case INTEGERVECTOR:
970 case WORD:
971 case QUEUE:
972 case COMPOSITION:
973 case SUBSET:
974 case VECTOR :
975 erg += append_vector(a,b,e);
976 break;
977 #endif /* VECTORTRUE */
978 default: erg+= WTO("append",a); break;
979 };
980 ENDR("append");
981 }
982
983
scalarp(a)984 INT scalarp(a) OP a;
985 /* test ob scalarer datentyp
986 Fri Mar 3 12:43:30 MEZ 1989
987 AK wahr falls INTEGER,LONGINT,BRUCH */
988 /* AK 280689 V1.0 */ /* AK 221289 V1.1 */ /* AK 210891 V1.3 */
989 {
990 INT erg = OK;
991 COP("scalarp(1)",a);
992 switch(S_O_K(a))
993 {
994 case BRUCH:
995 case INTEGER:
996 case LONGINT:
997 return(TRUE);
998 default:
999 return(FALSE);
1000 }
1001 ENDR("scalarp");
1002 }
1003
dynamicp(a)1004 INT dynamicp(a) OP a;
1005 /* test ob dynamische datenstruktur */
1006 /* Tue Jan 10 07:16:33 MEZ 1989 */
1007 /* AK 280689 V1.0 */ /* AK 160890 V1.1 */ /* AK 050891 V1.3 */
1008 {
1009 INT erg = OK;
1010 COP("dynamicp",a);
1011 switch (S_O_K(a))
1012 {
1013 case GRAL: case HOM_SYM: case POW_SYM: case BINTREE:
1014 case MONOPOLY: case SCHUR: case SCHUBERT: case LIST:
1015 case ELM_SYM: case MONOMIAL: case POLYNOM:
1016 return(TRUE);
1017 default:
1018 return(FALSE);
1019 }
1020 ENDR("dynamicp");
1021 }
1022
1023
1024
nullp(a)1025 INT nullp(a) OP a;
1026 /* 290388 aus macro */ /* AK 280689 V1.0 */ /* AK 081289 V1.1 */
1027 /* AK 210891 V1.3 */
1028 {
1029 INT erg = OK;
1030 EOP("nullp(1)",a);
1031
1032 switch (S_O_K(a))
1033 {
1034 #ifdef BRUCHTRUE
1035 case BRUCH: return(NULLP_BRUCH(a));
1036 #endif /* BRUCHTRUE */
1037 case INTEGER: return (NULLP_INTEGER(a));
1038 #ifdef FFTRUE
1039 case FF: return nullp_ff(a);
1040 #endif /* FFTRUE */
1041 #ifdef GRTRUE
1042 case GALOISRING: return nullp_galois(a);
1043 #endif /* GRTRUE */
1044 #ifdef LONGINTTRUE
1045 case LONGINT: return nullp_longint(a);
1046 #endif /* LONGINTTRUE */
1047 #ifdef CYCLOTRUE
1048 case CYCLOTOMIC: return nullp_cyclo(a);
1049 #endif /* CYCLOTRUE */
1050 #ifdef MONOPOLYTRUE
1051 case MONOPOLY: return nullp_monopoly(a); /* AK 290395 */
1052 #endif /* MONOPOLYTRUE */
1053 #ifdef MATRIXTRUE
1054 case INTEGERMATRIX:
1055 return nullp_integermatrix(a);
1056 case MATRIX:
1057 return nullp_matrix(a);
1058 #endif /* MATRIXTRUE */
1059 #ifdef SQRADTRUE
1060 case SQ_RADICAL: return nullp_sqrad(a);
1061 #endif /* SQRADTRUE */
1062 #ifdef SCHUBERTTRUE
1063 case SCHUBERT: return nullp_schubert(a); /* AL 180393 */
1064 #endif /* SCHUBERTTRUE */
1065 #ifdef SCHURTRUE
1066 case ELM_SYM: return nullp_elmsym(a);
1067 case POW_SYM: return nullp_powsym(a);
1068 case HOM_SYM: return nullp_homsym(a);
1069 case MONOMIAL: return nullp_monomial(a);
1070 case SCHUR: return nullp_schur(a);
1071 #endif /* SCHURTRUE */
1072 #ifdef CHARTRUE
1073 case SYMCHAR: return nullp_symchar(a); /* AK 010692 */
1074 #endif /* CHARTRUE */
1075 #ifdef POLYTRUE
1076 case POLYNOM: return nullp_polynom(a);
1077 #endif /* POLYTRUE */
1078 #ifdef REIHETRUE
1079 case REIHE: return nullp_reihe(a);
1080 #endif /* REIHETRUE */
1081 #ifdef VECTORTRUE /* AK 311091 */
1082 case INTEGERVECTOR: return nullp_integervector(a);
1083 case VECTOR: return nullp_vector(a);
1084 case BITVECTOR: return nullp_bitvector(a);
1085 case HASHTABLE: return nullp_integer(S_V_I(a,S_V_LI(a)));
1086 #endif /* VECTORTRUE */
1087
1088 case MONOM: return NULLP(S_MO_K(a));
1089
1090 default:
1091 WTO("nullp",a);
1092 };
1093 ENDR("nullp");
1094 }
1095
bit(a,i)1096 INT bit(a,i) OP a; INT i;
1097 /* returns the i-th bit of a */
1098 /* in the case of longint with out sign */
1099 /* AK 200902 V2.1 */
1100 {
1101 INT erg = OK;
1102 CTTO(INTEGER,LONGINT,"bit(1)",a);
1103 SYMCHECK(i<0,"bit: neg index");
1104 {
1105 if (S_O_K(a) == INTEGER)
1106 {
1107 INT l;
1108 if (i>=32) return 0;
1109 l = S_I_I(a);
1110 return (l>>i)&1;
1111 }
1112 else
1113 {
1114 return bit_longint(a,i);
1115 }
1116 }
1117 ENDR("bit");
1118 }
1119
eins_default(a,b)1120 INT eins_default(a,b) OP a,b;
1121 /* AK 200902 V2.1 */
1122 {
1123 INT erg = OK;
1124 erg += m_i_i(1,b);
1125 cast_apply(S_O_K(a),b);
1126 ENDR("eins_default");
1127 }
1128
eins(a,b)1129 INT eins(a,b) OP a,b;
1130 /* a any object b becomes identity in the object class of a */
1131 /* AK 200902 V2.1 */ /* AK 120804 V3.0 */
1132 /* AK 231106 V3.1 */
1133 {
1134 INT erg = OK;
1135 EOP("eins(1)",a);
1136 switch(S_O_K(a)) {
1137 case BRUCH: /* AK 120804 */
1138 case INTEGER:
1139 case LONGINT:
1140 erg += m_i_i(1,b);
1141 break;
1142 case GALOISRING:
1143 erg += eins_galois(a,b);
1144 break;
1145 case FF:
1146 erg += eins_ff(a,b);
1147 break;
1148 case MATRIX:
1149 case INTEGERMATRIX:
1150 if (S_M_HI(a)==S_M_LI(a)) {
1151 INT i,j;
1152 erg += m_lh_m(S_M_L(a),S_M_H(a),b);
1153 C_O_K(b,S_O_K(a));
1154 for (i=0;i<S_M_HI(b);i++)
1155 for (j=0;j<S_M_LI(b);j++)
1156 if (i==j) eins(S_M_IJ(a,i,j),S_M_IJ(b,i,j));
1157 else null(S_M_IJ(a,i,j),S_M_IJ(b,i,j));
1158 }
1159 else
1160 error("eins:only for quadratic matrices");
1161 break;
1162 case PERMUTATION:
1163 erg += first_permutation(S_P_L(a),b);
1164 break;
1165 case KRANZ: /* AK 120804 */
1166 {
1167 INT i;
1168 COPY(a,b);
1169 erg += eins(S_KR_G(a),S_KR_G(b));
1170 for (i=0;i<S_KR_GLI(a);i++)
1171 eins(S_KR_I(a,i),S_KR_I(b,i));
1172 }
1173 break;
1174 case POLYNOM: /* AK 271005 */
1175 {
1176 if (S_L_S(a) != NULL) {
1177 OP dd=CALLOCOBJECT();
1178 eins(S_PO_K(a),dd);
1179 m_scalar_polynom(dd,b);
1180 FREEALL(dd);
1181 }
1182 else {
1183 m_scalar_polynom(cons_eins,b);
1184 }
1185 }
1186 break;
1187 case MONOPOLY: /* AK 271005 */
1188 {
1189 if (S_L_S(a) != NULL) {
1190 OP dd=CALLOCOBJECT();
1191 eins(S_PO_K(a),dd);
1192 m_skn_mp(cons_null,dd,NULL,b);
1193 FREEALL(dd);
1194 }
1195 else {
1196 m_skn_mp(cons_null,cons_eins,NULL,b);
1197 }
1198 }
1199 break;
1200 default:
1201 erg += eins_default(a,b);
1202 break;
1203 }
1204 ENDR("eins");
1205 }
1206
null_default(a,b)1207 INT null_default(a,b) OP a,b;
1208 /* AK 200902 V2.1 */
1209 {
1210 INT erg = OK;
1211 erg += m_i_i(0,b);
1212 cast_apply(S_O_K(a),b);
1213 ENDR("eins_default");
1214 }
1215
1216
null(a,b)1217 INT null(a,b) OP a,b;
1218 /* a any object b becomes zero in the object class */
1219 /* AK 200902 V2,1 */
1220 {
1221 INT erg = OK;
1222 EOP("null(1)",a);
1223 switch(S_O_K(a)) {
1224 case GALOISRING:
1225 erg += null_galois(a,b);
1226 break;
1227 case FF:
1228 erg += null_ff(a,b);
1229 break;
1230 case INTEGER:
1231 case LONGINT:
1232 erg += m_i_i(0,b);
1233 break;
1234 case POLYNOM:
1235 case SCHUR:
1236 case HOMSYM:
1237 case ELMSYM:
1238 case POWSYM:
1239 case MONOMIAL:
1240 case MONOPOLY:
1241 erg += init(S_O_K(a),b);
1242 break;
1243 default:
1244 erg += null_default(a,b);
1245 break;
1246 }
1247 ENDR("null");
1248 }
1249
einsp(a)1250 INT einsp(a) OP a;
1251 /* TRUE if a is unity */
1252 /* 290388 aus macro */ /* AK 280689 V1.0 */ /* AK 081289 V1.1 */
1253 /* AK 250291 V1.2 */ /* AK 210891 V1.3 */
1254 /* AK 040398 V2.0 */
1255 {
1256 INT erg = OK;
1257 COP("einsp",a);
1258 switch (S_O_K(a)) {
1259
1260
1261 #ifdef BRUCHTRUE
1262 case BRUCH: return einsp_bruch(a);
1263 #endif /* BRUCHTRUE */
1264
1265 #ifdef FFTRUE
1266 case FF: return einsp_ff(a);
1267 #endif /* FFTRUE */
1268
1269
1270
1271 #ifdef GRTRUE
1272 case GALOISRING: return einsp_galois(a);
1273 #endif /* GRTRUE */
1274
1275
1276 case INTEGER: return einsp_integer(a);
1277
1278 #ifdef LONGINTTRUE
1279 case LONGINT: return einsp_longint(a);
1280 #endif /* LONGINTTRUE */
1281
1282
1283 #ifdef MATRIXTRUE
1284 case MATRIX: return einsp_matrix(a);
1285 #endif /* MATRIXTRUE */
1286
1287 #ifdef REIHETRUE
1288 case REIHE: return einsp_reihe(a);
1289 #endif /* REIHETRUE */
1290
1291 #ifdef KRANZTRUE
1292 case KRANZ: return einsp_kranz(a);
1293 #endif /* KRANZTRUE */
1294
1295 #ifdef PERMTRUE
1296 case PERMUTATION: return einsp_permutation(a);
1297 #endif /* PERMTRUE */
1298
1299 #ifdef POLYTRUE
1300 case POLYNOM: return einsp_polynom(a);
1301 case GRAL:
1302 case MONOPOLY: return einsp_monopoly(a);
1303 #endif
1304
1305 #ifdef SQRADTRUE
1306 case SQ_RADICAL: return einsp_sqrad(a);
1307 #endif
1308 #ifdef CYCLOTRUE
1309 case CYCLOTOMIC: return einsp_cyclotomic(a);
1310 #endif
1311
1312 #ifdef SCHURTRUE
1313 case ELM_SYM: return einsp_elmsym(a);
1314 case POW_SYM: return einsp_powsym(a);
1315 case HOM_SYM: return einsp_homsym(a);
1316 case MONOMIAL: return einsp_monomial(a);
1317 case SCHUR: return einsp_schur(a);
1318 #endif /* SCHURTRUE */
1319 #ifdef SCHUBERTTRUE
1320 case SCHUBERT: return einsp_schubert(a);
1321 #endif /* SCHUBERTTRUE */
1322 #ifdef VECTORTRUE
1323 case INTEGERVECTOR:
1324 return einsp_integervector(a);
1325 case VECTOR: return einsp_vector(a);
1326 #endif
1327 #ifdef CHARTRUE
1328 case SYMCHAR: return einsp_symchar(a);
1329 #endif /* CHARTRUE */
1330 default:
1331 WTO("einsp(1)",a);
1332 };
1333 ENDR("einsp");
1334 }
1335
negeinsp(a)1336 INT negeinsp(a) OP a;
1337 /* AK 181289 V1.1 */ /* AK 250291 V1.2 */
1338 /* AK 210891 V1.3 */
1339 {
1340 INT erg = OK;
1341 EOP("negeinsp(1)",a);
1342
1343 switch (S_O_K(a))
1344 {
1345
1346 #ifdef BRUCHTRUE
1347 case BRUCH:
1348 return(negeinsp_bruch(a));
1349 #endif /* BRUCHTRUE */
1350
1351 #ifdef INTEGERTRUE
1352 case INTEGER:
1353 return(NEGEINSP_INTEGER(a));
1354 #endif /* INTEGERTRUE */
1355
1356 #ifdef LONGINTTRUE
1357 case LONGINT:
1358 return negeinsp_longint(a);
1359 #endif /* LONGINTTRUE */
1360
1361 #ifdef POLYTRUE
1362 case POLYNOM: return negeinsp_polynom(a);
1363 #endif
1364
1365 default:
1366 WTO("negeinsp(1)",a);
1367 };
1368 ENDR("negeinsp");
1369 }
1370
vexillaryp(a,part)1371 INT vexillaryp(a,part) OP a,part;
1372 /* AK 290986 */
1373 /* part ist die Partition zugehoerig zur permutation */
1374 /* AK 280689 V1.0 */ /* AK 181289 V1.1 */
1375 /* AK 210891 V1.3 */
1376 {
1377 INT erg = OK;
1378 switch(S_O_K(a))
1379 {
1380 #ifdef PERMTRUE
1381 case PERMUTATION :
1382 return vexillaryp_permutation(a,part);
1383 #endif /* PERMTRUE */
1384 default:
1385 WTO("vexillary(1)",a);
1386 };
1387 ENDR("vexillaryp");
1388 }
1389
lastp(a)1390 INT lastp(a) OP a;
1391 /* AK 250986 */ /* AK 280689 V1.0 */ /* AK 181289 V1.1 */
1392 /* AK 200691 V1.2 */ /* AK 210891 V1.3 */
1393 {
1394 INT erg = OK;
1395 EOP("lastp(1)",a);
1396
1397 switch(S_O_K(a)) {
1398 #ifdef LISTTRUE
1399 case HOM_SYM :
1400 case POW_SYM :
1401 case GRAL :
1402 case POLYNOM :
1403 case MONOPOLY:
1404 case SCHUBERT :
1405 case SCHUR :
1406 case ELM_SYM:
1407 case MONOMIAL:
1408 case LIST :
1409 return(lastp_list(a));
1410 #endif /* LISTTRUE */
1411 default:
1412 WTO("lastp(1)",a);
1413 };
1414 ENDR("lastp");
1415 }
1416
odd(a)1417 INT odd(a) OP a;
1418 /* AK 210291 V1.2 */ /* AK 210891 V1.3 */
1419 {
1420 return not even(a);
1421 }
1422
even(a)1423 INT even(a) OP a;
1424 /* AK 280689 V1.0 */ /* AK 160890 V1.1 */ /* AK 210291 V1.2 */
1425 /* AK 210891 V1.3 */
1426 {
1427 INT erg = OK;
1428 EOP("even(1)",a);
1429 switch(S_O_K(a))
1430 {
1431 #ifdef INTEGERTRUE
1432 case INTEGER : return even_integer(a);
1433 #endif /* INTEGERTRUE */
1434 #ifdef LONGINTTRUE
1435 case LONGINT : return even_longint(a);
1436 #endif /* LONGINTTRUE */
1437 #ifdef PARTTRUE
1438 case PARTITION : return even_partition(a); /* AK 300992 */
1439 #endif /* PARTTRUE */
1440 #ifdef PERMTRUE
1441 case PERMUTATION : return even_permutation(a); /* AK 010692 */
1442 #endif /* PERMTRUE */
1443 default: WTO("even",a);goto endr_ende;
1444 };
1445 ENDR("even");
1446 }
1447
negp(a)1448 INT negp(a) OP a;
1449 /* AK 190888 */ /* AK 280689 V1.0 */ /* AK 160890 V1.1 */ /* AK 210891 V1.3 */
1450 /* AK V2.0 221298 */
1451 /* true if a < 0 */
1452 /* AK 151204 V3.0 */
1453 {
1454 INT erg = OK;
1455 COP("negp",a);
1456 switch(S_O_K(a))
1457 {
1458 #ifdef BRUCHTRUE
1459 case BRUCH : return negp_bruch(a);
1460 #endif /* BRUCHTRUE */
1461 #ifdef INTEGERTRUE
1462 case INTEGER : return negp_integer(a);
1463 #endif /* INTEGERTRUE */
1464 #ifdef LONGINTTRUE
1465 case LONGINT : return negp_longint(a);
1466 #endif /* LONGINTTRUE */
1467 #ifdef POLYTRUE /* AK V2.0 221298 */
1468 /* true if all coeffs < 0 */
1469 case SCHUBERT:
1470 case GRAL:
1471 case SCHUR:
1472 case ELM_SYM:
1473 case POW_SYM:
1474 case HOM_SYM:
1475 case MONOMIAL:
1476 case MONOPOLY:
1477 case POLYNOM:
1478 return negp_polynom(a);
1479 #endif /* POLYTRUE */
1480
1481 default: WTO("negp",a);goto endr_ende;
1482 };
1483
1484 ENDR("negp");
1485 }
1486
posp(a)1487 INT posp(a) OP a;
1488 /* AK 190888 */ /* AK 280689 V1.0 */ /* AK 160890 V1.1 */ /* AK 210891 V1.3 */
1489 /* AK 190298 V2.0 */
1490 /* TRUE if > 0 */
1491 /* changed from >= 0 to >0 041001 AK */
1492 /* AK 151204 V3.0 */
1493 {
1494 INT erg = OK;
1495 COP("posp",a);
1496 switch(S_O_K(a))
1497 {
1498 #ifdef BRUCHTRUE
1499 case BRUCH : return posp_bruch(a) ;
1500 #endif /* BRUCHTRUE */
1501 #ifdef INTEGERTRUE
1502 case INTEGER : return POSP_INTEGER(a) ;
1503 #endif /* INTEGERTRUE */
1504 #ifdef LONGINTTRUE
1505 case LONGINT : return posp_longint(a) ;
1506 #endif /* LONGINTTRUE */
1507 #ifdef VECTORTRUE
1508 case INTEGERVECTOR:
1509 case VECTOR : return posp_vector(a) ;
1510 #endif /* VECTORTRUE */
1511 #ifdef POLYTRUE /* AK V2.0 221298 */
1512 /* true if all coeffs > 0 */
1513 case SCHUBERT:
1514 case GRAL:
1515 case SCHUR:
1516 case ELM_SYM:
1517 case POW_SYM:
1518 case HOM_SYM:
1519 case MONOMIAL:
1520 case MONOPOLY:
1521 case POLYNOM:
1522 return posp_polynom(a);
1523 #endif /* POLYTRUE */
1524 default:
1525 erg += WTO("posp",a);
1526 goto endr_ende;
1527 };
1528 ENDR("posp");
1529 }
1530
comp(a,b)1531 INT comp(a,b) OP a,b;
1532 /* AK 280689 V1.0 */ /* AK 281289 V1.1 */ /* AK 210891 V1.3 */
1533 {
1534 INT erg = OK;
1535 COP("comp(1)",a);
1536 COP("comp(2)",b);
1537 if (EMPTYP(a) && EMPTYP(b)) return(0L);
1538 else if (EMPTYP(a)) return(-1L);
1539 else if (EMPTYP(b)) return(1L);
1540 else switch(S_O_K(a)){
1541 #ifdef BRUCHTRUE
1542 case BRUCH : return comp_bruch(a,b);
1543 #endif /* BRUCHTRUE */
1544 #ifdef FFTRUE
1545 case FF : return comp_ff(a,b);
1546 #endif /* FFTRUE */
1547 #ifdef INTEGERTRUE
1548 case INTEGER :
1549 if (S_O_K(b) == INTEGER)
1550 return ( S_I_I(a) > S_I_I(b) ? 1L :
1551 S_I_I(a) == S_I_I(b) ? 0L : -1L );
1552 else
1553 return comp_integer(a,b);
1554 #endif /* INTEGERTRUE */
1555 #ifdef LONGINTTRUE
1556 case LONGINT : return comp_longint(a,b);
1557 #endif /* LONGINTTRUE */
1558 #ifdef MATRIXTRUE
1559 case KRANZTYPUS :return comp_kranztafel(a,b);
1560 case INTEGERMATRIX: return comp_integermatrix(a,b);
1561 case MATRIX : return comp_matrix(a,b);
1562 #endif /* MATRIXTRUE */
1563 #ifdef MONOMTRUE
1564 case MONOM : return comp_monom(a,b);
1565 #endif /* MONOMTRUE */
1566 #ifdef LISTTRUE
1567 case SCHUBERT:
1568 case GRAL:
1569 case SCHUR:
1570 case ELM_SYM:
1571 case POW_SYM:
1572 case HOM_SYM:
1573 case MONOMIAL:
1574 case LIST : return comp_list(a,b);
1575 case POLYNOM:
1576 return comp_polynom(a,b);
1577 case MONOPOLY:
1578 return comp_monopoly(a,b);
1579 #endif /* LISTTRUE */
1580 #ifdef PARTTRUE
1581 case PARTITION: return comp_partition(a,b);
1582 #endif /* PARTTRUE */
1583 #ifdef PERMTRUE
1584 case PERMUTATION: return comp_permutation(a,b);
1585 #endif /* PERMTRUE */
1586 #ifdef REIHETRUE
1587 case REIHE: return comp_reihe(a,b);
1588 #endif /* REIHETRUE */
1589 #ifdef SKEWPARTTRUE
1590 case SKEWPARTITION: return comp_skewpartition(a,b);
1591 #endif /* SKEWPARTTRUE */
1592 #ifdef CHARTRUE
1593 case SYMCHAR: return comp_symchar(a,b);
1594 #endif /* CHARTRUE */
1595 #ifdef TABLEAUXTRUE
1596 case TABLEAUX : /* 060588 */
1597 return comp_tableaux(a,b);
1598 #endif /* TABLEAUXTRUE */
1599 #ifdef WORDTRUE
1600 case WORD:
1601 return comp_word(a,b);
1602 #endif /* WORDTRUE */
1603 #ifdef VECTORTRUE
1604 case BITVECTOR: /* AK 200395 */
1605 return comp_bv(a,b);
1606 case VECTOR:
1607 return comp_vector(a,b);
1608 case INTEGERVECTOR:
1609 case COMPOSITION:
1610 case SUBSET:
1611 return comp_integervector(a,b);
1612 case GALOISRING:
1613 return comp_galois(a,b);
1614 #endif /* VECTORTRUE */
1615 default: return WTT("comp",a,b);
1616 }
1617 ENDR("comp");
1618 }
1619
lt(a,b)1620 INT lt(a,b) OP a,b;
1621 /* AK 280689 V1.0 */ /* AK 160890 V1.1 */ /* AK 210891 V1.3 */
1622 /* AK 161204 V3.0 */
1623 {
1624 INT erg = OK;
1625 COP("lt(1)",a);
1626 COP("lt(2)",b);
1627 if (comp(a,b) < 0L) return(TRUE);
1628 return(FALSE);
1629 ENDR("lt");
1630 }
1631
eq(a,b)1632 INT eq(a,b) OP a,b;
1633 /* AK 280689 V1.0 */ /* AK 160890 V1.1 */ /* AK 210891 V1.3 */
1634 /* AK 161204 V3.0 */
1635 {
1636 INT erg = OK;
1637 COP("eq(1)",a);
1638 COP("eq(2)",b);
1639 switch (S_O_K(a)) {
1640 case INTEGER:
1641 return eq_integer(a,b);
1642 case PARTITION:
1643 return eq_partition(a,b);
1644 case PERMUTATION:
1645 return eq_permutation(a,b);
1646 case VECTOR:
1647 return eq_vector(a,b);
1648 case CYCLOTOMIC:
1649 return eq_cyclotomic(a,b);
1650 case SQ_RADICAL:
1651 return eq_sqrad(a,b);
1652 case INTEGERMATRIX:
1653 case MATRIX:
1654 case KRANZTYPUS:
1655 return eq_matrix(a,b); /* AK 110703 */
1656 case INTEGERVECTOR: /* AK 280804 */
1657 if (S_O_K(b)==INTEGERVECTOR)
1658 return eq_integervector_integervector(a,b);
1659 else if (comp(a,b) == 0L) return(TRUE);
1660 else return FALSE;
1661 default:
1662 /* AK 051207 if (S_O_K(a) != S_O_K(b)) return FALSE; */
1663
1664 if (comp(a,b) == 0L) return(TRUE);
1665 }
1666 ENDR("eq");
1667 }
1668
neq(a,b)1669 INT neq(a,b) OP a,b;
1670 /* AK 280689 V1.0 */ /* AK 160890 V1.1 */ /* AK 210891 V1.3 */
1671 {
1672 INT erg = OK;
1673 COP("neq(1)",a);
1674 COP("neq(2)",b);
1675 return not eq(a,b);
1676 ENDR("neq");
1677 }
1678
gr(a,b)1679 INT gr(a,b) OP a,b;
1680 /* AK 280689 V1.0 */ /* AK 160890 V1.1 */ /* AK 210891 V1.3 */
1681 {
1682 if (comp(a,b) > 0L) return(TRUE);
1683 return(FALSE);
1684 }
1685
ge(a,b)1686 INT ge(a,b) OP a,b;
1687 /* AK 260789 V1.0 */ /* AK 160890 V1.1 */ /* AK 210891 V1.3 */
1688 {
1689 if (comp(a,b) >= 0L) return(TRUE);
1690 return(FALSE);
1691 }
1692
gt(a,b)1693 INT gt(a,b) OP a,b;
1694 /* AK 010889 V1.0 */ /* AK 160890 V1.1 */ /* AK 210891 V1.3 */
1695 {
1696 if (S_O_K(a) == INTEGER)
1697 if (S_O_K(b) == INTEGER) return ((S_I_I(a) > S_I_I(b))? TRUE:FALSE);
1698
1699 if (comp(a,b) > 0L) return(TRUE);
1700 return(FALSE);
1701 }
1702
1703
1704
le(a,b)1705 INT le(a,b) OP a,b;
1706 /* AK 280689 V1.0 */ /* AK 160890 V1.1 */ /* AK 210891 V1.3 */
1707 {
1708 if (comp(a,b) > 0L) return(FALSE);
1709 return(TRUE);
1710 }
1711
listp(a)1712 INT listp(a) OP a;
1713 /* AK 030789 V1.0 */ /* AK 160890 V1.1 */ /* AK 060891 V1.3 */
1714 {
1715 OBJECTKIND kind = S_O_K(a);
1716 if ( kind == LIST ||
1717 kind == POLYNOM ||
1718 kind == MONOPOLY ||
1719 kind == GRAL ||
1720 kind == HOM_SYM ||
1721 kind == POW_SYM ||
1722 kind == ELM_SYM ||
1723 kind == MONOMIAL ||
1724 kind == SCHUR ||
1725 kind == SCHUBERT
1726 ) return(TRUE);
1727 else return(FALSE);
1728 }
1729
factorize(a,b)1730 INT factorize(a,b) OP a,b;
1731 /* AK 290304 */
1732 /* decomposition into factors, i.e. a vector of factors */
1733 /* the factors are ordered */
1734 /* AK 281106 V3.1 */
1735 {
1736 INT erg = OK;
1737 CE2(a,b,factorize);
1738 FREESELF(b);
1739 switch(S_O_K(a))
1740 {
1741 case INTEGER: erg+=factorize_integer(a,b); goto endr_ende;
1742 case LONGINT: NYI("factorize for longint"); goto endr_ende;
1743 case POLYNOM: NYI("factorize for polynom"); goto endr_ende;
1744 default: WTO("factorize",a);
1745 }
1746 ENDR("factorize");
1747 }
1748
1749 #ifdef INTEGERTRUE
factorize_integer(a,b)1750 INT factorize_integer(a,b) OP a,b;
1751 /* AK 060690 V1.1 */ /* AK 060891 V1.3 */ /* AK 220998 V2.0 */
1752 /* input: INTEGER object a
1753 output:INTEGERVECTOR of prim factors in increasing order */
1754 {
1755 INT erg = OK;
1756 CTO(INTEGER,"factorize_integer(1)",a);
1757
1758 {
1759 INT ai = S_I_I(a);
1760 INT i=2L;
1761 m_il_v((INT)0,b);
1762 while (i <= ai)
1763 {
1764 if (ai % i == 0L) {
1765 INC(b);
1766 M_I_I(i,S_V_I(b,S_V_LI(b)-1L));
1767 ai = ai / i; continue; }
1768 i++;
1769 }
1770 }
1771
1772 ENDR("factorize_integer");
1773 }
1774 #endif /* INTEGERTRUE */
1775
1776
1777 #ifdef BRUCHTRUE
invers_apply_integer(a)1778 INT invers_apply_integer(a) OP a;
1779 /* AK 140591 V1.2 */ /* AK 060891 V1.3 */
1780 {
1781 INT erg = OK;
1782 CTO(INTEGER,"invers_apply_integer",a);
1783 SYMCHECK(S_I_I(a) == 0,"invers_apply_integer:zero");
1784 if (S_I_I(a) == 1) goto endr_ende;
1785 if (S_I_I(a) == -1) {
1786 M_I_I(-S_I_I(a),a);
1787 goto endr_ende; }
1788 erg += m_ioiu_b(1L, S_I_I(a), a);
1789 ENDR("invers_apply_integer");
1790 }
1791 #endif /* BRUCHTRUE */
1792
addinvers_apply_integer(a)1793 INT addinvers_apply_integer(a) OP a;
1794 /* AK 201289 V1.1 */ /* AK 140591 V1.2 */ /* AK 060891 V1.3 */
1795 {
1796 INT erg = OK;
1797 CTO(INTEGER,"addinvers_apply_integer",a);
1798 M_I_I(- S_I_I(a), a);
1799 ENDR("addinvers_apply_integer");
1800 }
1801
1802
addinvers_integer(a,b)1803 INT addinvers_integer(a,b) OP a,b;
1804 /* AK 280689 V1.0 */ /* AK 131289 V1.1 */ /* AK 060891 V1.3 */
1805 {
1806 INT erg = OK;
1807 CTO(INTEGER,"addinvers_integer(1)",a);
1808 CTO(EMPTY,"addinvers_integer(2)",b);
1809 M_I_I(- S_I_I(a), b);
1810 ENDR("addinvers_integer");
1811 }
1812
inc_integer(a)1813 INT inc_integer(a) OP a;
1814 /* AK 280689 V1.0 */ /* AK 181289 V1.1 */ /* AK 060891 V1.3 */
1815 {
1816 INT erg = OK;
1817 CTO(INTEGER,"inc_integer(1)",a);
1818 C_I_I(a,S_I_I(a)+1L);
1819 ENDR("inc_integer");
1820 }
1821
dec_integer(a)1822 INT dec_integer(a) OP a;
1823 /* AK 280689 V1.0 */ /* AK 181289 V1.1 */ /* AK 060891 V1.3 */
1824 {
1825 INT erg = OK;
1826 CTO(INTEGER,"dec_integer(1)",a);
1827 C_I_I(a,S_I_I(a)-1L);
1828 ENDR("dec_integer");
1829 }
1830
hoch_integer_integer(a,b,c)1831 INT hoch_integer_integer(a,b,c) OP a,b,c;
1832 {
1833 INT erg = OK;
1834 INT i;
1835 OP d;
1836 CTTO(LONGINT,INTEGER,"hoch_integer_integer(1)",a);
1837 CTO(INTEGER,"hoch_integer_integer(2)",b);
1838 CTO(EMPTY,"hoch_integer_integer(3)",c);
1839 if (NULLP_INTEGER(b)) {
1840 M_I_I(1,c);
1841 goto ende;
1842 }
1843 if (NEGP_INTEGER(b)) {
1844 erg += b_ou_b(CALLOCOBJECT(),CALLOCOBJECT(),c);
1845 M_I_I(1,S_B_O(c));
1846 C_B_I(c,GEKUERZT);
1847 ADDINVERS_APPLY_INTEGER(b);
1848 erg += hoch_integer_integer(a,b,S_B_U(c));
1849 ADDINVERS_APPLY_INTEGER(b);
1850 goto ende;
1851 }
1852 if (EINSP_INTEGER(b)) {
1853 COPY(a,c);
1854 goto ende;
1855 }
1856 SYMCHECK((S_I_I(b) <= 1), "hoch_integer_integer:(i1)");
1857
1858 i = S_I_I(b);
1859 d = CALLOCOBJECT();
1860 COPY(a,d);
1861 M_I_I(1,c);
1862 while(i) {
1863 if ( i % 2 == 1)
1864 {
1865 MULT_APPLY(d,c);
1866 }
1867
1868 erg += square_apply(d);
1869 i /= 2;
1870 }
1871
1872 FREEALL(d);
1873 ende:
1874 CTTO(INTEGER,LONGINT,"hoch_integer_integer(e3)",c);
1875 ENDR("hoch_integer_integer");
1876 }
1877
hoch_longint_integer(a,b,c)1878 INT hoch_longint_integer(a,b,c) OP a,b,c;
1879 {
1880 INT erg = OK;
1881 CTO(LONGINT,"hoch_longint_integer(1)",a);
1882 CTO(INTEGER,"hoch_longint_integer(2)",b);
1883 CTO(EMPTY,"hoch_longint_integer(3)",c);
1884 erg += hoch_integer_integer(a,b,c);
1885 ENDR("hoch_longint_integer");
1886 }
1887
hoch_longint_longint(a,b,c)1888 INT hoch_longint_longint(a,b,c) OP a,b,c;
1889 {
1890 INT erg = OK;
1891 CTO(LONGINT,"hoch_longint_longint(1)",a);
1892 CTO(LONGINT,"hoch_longint_longint(2)",b);
1893 CTO(EMPTY,"hoch_longint_longint(3)",c);
1894 NYI("hoch_longint_longint");
1895 ENDR("hoch_longint_longint");
1896 }
1897
hoch_integer_longint(a,b,c)1898 INT hoch_integer_longint(a,b,c) OP a,b,c;
1899 {
1900 INT erg = OK;
1901 CTO(INTEGER,"hoch_integer_longint(1)",a);
1902 CTO(LONGINT,"hoch_integer_longint(2)",b);
1903 CTO(EMPTY,"hoch_integer_longint(3)",c);
1904 NYI("hoch_integer_longint");
1905 ENDR("hoch_integer_longint");
1906 }
1907
1908 INT hoch_default();
hoch_bruch_integer(a,b,c)1909 INT hoch_bruch_integer(a,b,c) OP a,b,c;
1910 {
1911 INT erg = OK;
1912 CTO(BRUCH,"hoch_bruch_integer(1)",a);
1913 CTO(INTEGER,"hoch_bruch_integer(2)",b);
1914 CTO(EMPTY,"hoch_bruch_integer(3)",c);
1915 erg += hoch_default(a,b,c);
1916 ENDR("hoch_bruch_integer");
1917 }
1918
hoch_bruch_longint(a,b,c)1919 INT hoch_bruch_longint(a,b,c) OP a,b,c;
1920 {
1921 INT erg = OK;
1922 CTO(BRUCH,"hoch_bruch_longint(1)",a);
1923 CTO(LONGINT,"hoch_bruch_longint(2)",b);
1924 CTO(EMPTY,"hoch_bruch_longint(3)",c);
1925 erg += hoch_default(a,b,c);
1926 ENDR("hoch_bruch_longint");
1927 }
1928
1929
1930
hoch_integer(a,b,c)1931 INT hoch_integer(a,b,c) OP a,b,c;
1932 {
1933 INT erg = OK;
1934 CTO(INTEGER,"hoch_integer(1)",a);
1935 CTO(EMPTY,"hoch_integer(3)",c);
1936 if (S_O_K(b) == INTEGER)
1937 erg += hoch_integer_integer(a,b,c);
1938 else if (S_O_K(b) == LONGINT)
1939 erg += hoch_integer_longint(a,b,c);
1940 else
1941 erg += hoch_default(a,b,c);
1942 ENDR("hoch_integer");
1943 }
1944
hoch_longint(a,b,c)1945 INT hoch_longint(a,b,c) OP a,b,c;
1946 {
1947 INT erg = OK;
1948 CTO(LONGINT,"hoch_longint(1)",a);
1949 CTO(EMPTY,"hoch_longint(3)",c);
1950 if (S_O_K(b) == INTEGER)
1951 erg += hoch_longint_integer(a,b,c);
1952 else if (S_O_K(b) == LONGINT)
1953 erg += hoch_longint_longint(a,b,c);
1954 else
1955 erg += hoch_default(a,b,c);
1956 ENDR("hoch_longint");
1957 }
1958
hoch_bruch(a,b,c)1959 INT hoch_bruch(a,b,c) OP a,b,c;
1960 {
1961 INT erg = OK;
1962 CTO(BRUCH,"hoch_bruch(1)",a);
1963 CTO(EMPTY,"hoch_bruch(3)",c);
1964 if (S_O_K(b) == INTEGER)
1965 erg += hoch_bruch_integer(a,b,c);
1966 else if (S_O_K(b) == LONGINT)
1967 erg += hoch_bruch_longint(a,b,c);
1968 else
1969 erg += hoch_default(a,b,c);
1970 ENDR("hoch_bruch");
1971 }
1972
mult_integer_integer(a,b,d)1973 INT mult_integer_integer(a,b,d) OP a,b,d;
1974 /* AK 280689 V1.0 */ /* AK 181289 V1.1 */ /* AK 060891 V1.3 */
1975 {
1976 INT l,erg = OK;
1977 CTO(INTEGER,"mult_integer_integer(1)",a);
1978 CTO(INTEGER,"mult_integer_integer(2)",b);
1979 CTO(EMPTY,"mult_integer_integer(3)",d);
1980
1981 l=INTLOG(a) + INTLOG(b);
1982 if ( l > 9)
1983 {
1984 #ifdef LONGINTTRUE
1985 OP c= CALLOCOBJECT();
1986 erg += t_int_longint(a,c);
1987 erg += mult_longint_integer(c,b,d);
1988 FREEALL(c);
1989 #else /* LONGINTTRUE */
1990 erg += error("mult_integer_integer:no LONGINT");
1991 #endif /* LONGINTTRUE */
1992 goto endr_ende;
1993 }
1994
1995 M_I_I(S_I_I(a)*S_I_I(b),d);
1996 ENDR("mult_integer_integer");
1997 }
1998
mult_integer_longint(a,b,c)1999 INT mult_integer_longint(a,b,c) OP a,b,c;
2000 {
2001 INT erg = OK;
2002 CTO(INTEGER,"mult_integer_longint",a);
2003 CTO(LONGINT,"mult_integer_longint",b);
2004 CTO(EMPTY,"mult_integer_longint",c);
2005
2006 erg += mult_longint_integer(b,a,c);
2007
2008 ENDR("mult_integer_longint");
2009 }
2010
mult_integer_bruch(a,b,c)2011 INT mult_integer_bruch(a,b,c) OP a,b,c;
2012 {
2013 INT erg = OK;
2014 CTO(INTEGER,"mult_integer_bruch",a);
2015 CTO(BRUCH,"mult_integer_bruch",b);
2016 CTO(EMPTY,"mult_integer_bruch",c);
2017
2018 erg += mult_bruch_integer(b,a,c);
2019
2020 ENDR("mult_integer_bruch");
2021 }
2022
mult_integer(a,b,d)2023 INT mult_integer(a,b,d) OP a,b,d;
2024 /* AK 280689 V1.0 */ /* AK 181289 V1.1 */ /* AK 060891 V1.3 */
2025 {
2026 INT erg=OK;
2027 CTO(INTEGER,"mult_integer(1)",a);
2028 CTTO(EMPTY,INTEGER,"mult_integer(3)",d);
2029 EOP("mult_integer(2)",b);
2030
2031 if (S_O_K(d)==INTEGER) C_O_K(d,EMPTY);
2032 switch(S_O_K(b)) {
2033 #ifdef BRUCHTRUE
2034 case BRUCH:
2035 erg += mult_bruch_integer(b,a,d);
2036 goto ende;
2037 #endif /* BRUCHTRUE */
2038
2039 case INTEGER:
2040 erg += mult_integer_integer(a,b,d);
2041 goto ende;
2042
2043 #ifdef LONGINTTRUE
2044 case LONGINT:
2045 erg += mult_longint_integer(b,a,d);
2046 goto ende;
2047 #endif /* LONGINTTRUE */
2048
2049 #ifdef MATRIXTRUE
2050 case KRANZTYPUS :
2051 case MATRIX:
2052 erg += mult_scalar_matrix(a,b,d);
2053 goto ende;
2054 #endif /* MATRIXTRUE */
2055
2056 #ifdef MONOMTRUE
2057 case MONOM:
2058 erg += mult_integer_monom(a,b,d);
2059 goto ende;
2060 #endif /* MONOMTRUE */
2061
2062 #ifdef POLYTRUE
2063 case POW_SYM:
2064 erg += mult_powsym_scalar(b,a,d);
2065 goto ende;
2066 case ELM_SYM:
2067 erg += mult_elmsym_scalar(b,a,d);
2068 goto ende;
2069 case HOM_SYM:
2070 erg += mult_homsym_scalar(b,a,d);
2071 goto ende;
2072 case MONOMIAL:
2073 erg += mult_monomial_scalar(b,a,d);
2074 goto ende;
2075 case SCHUR:
2076 erg += mult_schur_scalar(b,a,d);
2077 goto ende;
2078 #ifdef SCHUBERTTRUE
2079 case SCHUBERT:
2080 erg += mult_scalar_schubert(a,b,d);
2081 goto ende;
2082 #endif
2083 case GRAL:
2084 erg += mult_scalar_gral(a,b,d);
2085 goto ende;
2086 case POLYNOM:
2087 erg += mult_scalar_polynom(a,b,d);
2088 goto ende;
2089 case MONOPOLY:
2090 erg += mult_scalar_monopoly(a,b,d);
2091 goto ende;
2092 #endif /* POLYTRUE */
2093
2094 #ifdef LAURENTTRUE
2095 case LAURENT:
2096 {
2097 OP c = callocobject();
2098 erg += t_INTEGER_LAURENT(a,c);
2099 erg += mult_laurent(c,b,d);
2100 erg += freeall(c);
2101 }
2102 goto ende;
2103 #endif /* LAURENTTRUE */
2104
2105 #ifdef SQRADTRUE
2106 case SQ_RADICAL:
2107 erg += mult_scalar_sqrad(a,b,d);
2108 goto ende;
2109 #endif /* SQRADDTRUE */
2110
2111 #ifdef CYCLOTRUE
2112 case CYCLOTOMIC:
2113 erg += mult_scalar_cyclo(a,b,d);
2114 goto ende;
2115 #endif /* CYCLOTRUE */
2116
2117 #ifdef CHARTRUE
2118 case SYMCHAR:
2119 erg += mult_scalar_symchar(a,b,d);
2120 goto ende;
2121 #endif /* CHARTRUE */
2122
2123 #ifdef VECTORTRUE
2124 case INTEGERVECTOR:
2125 case VECTOR:
2126 erg += mult_scalar_vector(a,b,d);
2127 goto ende;
2128 #endif /* VECTORTRUE */
2129
2130 #ifdef FFTRUE
2131 case FF:
2132 erg += cast_apply_ff(a);
2133 erg += mult_ff(a,b,d);
2134 goto ende;
2135 #endif /* FFTRUE */
2136
2137 case HASHTABLE:
2138 erg += mult_integer_hashtable(a,b,d);
2139 goto ende;
2140
2141 default:
2142 WTO("mult_integer(2)",b);
2143 goto ende;
2144 }
2145 ende:
2146 ENDR("mult_integer");
2147 }
2148
even_integer(a)2149 INT even_integer(a) OP a;
2150 /* AK 280689 V1.0 */ /* AK 181289 V1.1 */ /* AK 060891 V1.3 */
2151 {
2152 return(S_I_I(a) %2L == 0L);
2153 }
2154
posp_integer(a)2155 INT posp_integer(a) OP a;
2156 /* AK 280689 V1.0 */ /* AK 181289 V1.1 */ /* AK 060891 V1.3 */
2157 {
2158 return(S_I_I(a) >= (INT) 0);
2159 }
2160
negp_integer(a)2161 INT negp_integer(a) OP a;
2162 /* AK 280689 V1.0 */ /* AK 181289 V1.1 */ /* AK 060891 V1.3 */
2163 {
2164 return(S_I_I(a) < 0L);
2165 }
2166
mod_integer_integer(a,b,c)2167 INT mod_integer_integer(a,b,c) OP a,b,c;
2168 {
2169 INT erg = OK;
2170 CTO(INTEGER,"mod_integer_integer(1)",a);
2171 CTO(INTEGER,"mod_integer_integer(2)",b);
2172 CTO(EMPTY,"mod_integer_integer(3)",c);
2173
2174 M_I_I(S_I_I(a) % S_I_I(b),c);
2175 ENDR("mod_integer");
2176 }
2177
2178
add_integer_integer(a,b,c)2179 INT add_integer_integer(a,b,c) OP a,b,c;
2180 /* AK 251001 */
2181 {
2182 INT erg = OK,i;
2183 CTO(INTEGER,"add_integer_integer(1)",a);
2184 CTO(INTEGER,"add_integer_integer(2)",b);
2185 CTO(EMPTY,"add_integer_integer(3)",c);
2186
2187 i = S_I_I(a)+S_I_I(b);
2188 if (
2189 ( (S_I_I(a) > 0) && (S_I_I(b) > 0) && (i <= 0) )
2190 ||
2191 ( (S_I_I(a) < 0) && (S_I_I(b) < 0) && (i >= 0) )
2192 )
2193 {
2194 #ifdef LONGINTTRUE
2195 OP d;
2196 d = callocobject();
2197 erg += t_int_longint(b,d);
2198 erg += add_longint_integer(d,a,c);
2199 erg += freeall(d);
2200 #else /* LONGINTTRUE */
2201 erg += error("add_apply_integer_integer:Overflow no LONGINT");
2202 #endif /* LONGINTTRUE */
2203 }
2204 else {
2205 M_I_I(i,c);
2206 }
2207
2208 ENDR("add_integer_integer");
2209 }
2210
add_integer_longint(a,b,c)2211 INT add_integer_longint(a,b,c) OP a,b,c;
2212 /* AK 251001 */
2213 {
2214 INT erg = OK;
2215 CTO(INTEGER,"add_integer_longint(1)",a);
2216 CTO(LONGINT,"add_integer_longint(2)",b);
2217 CTO(EMPTY,"add_integer_longint(3)",c);
2218
2219 erg += add_longint_integer(b,a,c);
2220 ENDR("add_integer_longint");
2221 }
2222
add_integer(a,b,c)2223 INT add_integer(a,b,c) OP a,b,c;
2224 /* das erste object ist vom typ INTEGER, das ergebnis ist ein leere
2225 object */
2226 /* AK 280689 V1.0 */ /* AK 181289 V1.1 */ /* AK 280291 V1.2 */
2227 /* AK 060891 V1.3 */
2228 {
2229 INT erg = OK;
2230 CTO(INTEGER,"add_integer(1)",a);
2231 CTO(EMPTY,"add_integer(3)",c);
2232 EOP("add_integer(2)",b);
2233
2234
2235 switch(S_O_K(b))
2236 {
2237 #ifdef BRUCHTRUE
2238 case BRUCH:
2239 erg += add_bruch_scalar(b,a,c);
2240 goto aiende;
2241 #endif /* BRUCHTRUE */
2242
2243 case INTEGER:
2244 erg += add_integer_integer(a,b,c);
2245 goto aiende;
2246
2247 #ifdef LONGINTTRUE
2248 case LONGINT:
2249 erg += add_longint_integer(b,a,c);
2250 goto aiende;
2251 #endif /* LONGINTTRUE */
2252
2253 #ifdef POLYTRUE /* AK 060891 */
2254 case POLYNOM:
2255 erg += add_scalar_polynom(a,b,c);
2256 goto aiende;
2257 #endif /* POLYTRUE */
2258
2259 case SQ_RADICAL:
2260 erg += add_scalar_sqrad(a,b,c);
2261 goto aiende;
2262 case CYCLOTOMIC:
2263 erg += add_scalar_cyclo(a,b,c);
2264 goto aiende;
2265
2266 #ifdef SCHURTRUE /* AK 240102 */
2267 case SCHUR:
2268 erg += add_schur(b,a,c);
2269 goto aiende;
2270 case HOMSYM:
2271 erg += add_homsym(b,a,c);
2272 goto aiende;
2273 case POWSYM:
2274 erg += add_powsym(b,a,c);
2275 goto aiende;
2276 case ELMSYM:
2277 erg += add_elmsym(b,a,c);
2278 goto aiende;
2279 case MONOMIAL:
2280 erg += add_monomial(b,a,c);
2281 goto aiende;
2282 #endif /* SCHURTRUE */
2283 case MONOPOLY:
2284 erg += add_scalar_monopoly(a,b,c);
2285 goto aiende;
2286
2287 default :
2288 if (NULLP_INTEGER(a))
2289 COPY(b,c);
2290 else
2291 erg += WTO("add_integer(2)",b);
2292 goto aiende;
2293 } /* end switch */
2294 aiende:
2295 ENDR("add_integer");
2296 }
2297
eq_integer(a,b)2298 INT eq_integer(a,b) OP a,b;
2299 /* AK 110202 */
2300 {
2301 INT erg = OK;
2302 CTO(INTEGER,"eq_integer(1)",a);
2303
2304 switch(S_O_K(b)) {
2305 case SQ_RADICAL:
2306 return FALSE;
2307 case CYCLOTOMIC:
2308 return FALSE;
2309 case EMPTY:
2310 return FALSE;
2311
2312 default:
2313 return comp_integer(a,b) == 0;
2314 }
2315
2316 ENDR("eq_integer");
2317 }
2318
comp_integer_integer(a,b)2319 INT comp_integer_integer(a,b) OP a,b;
2320 /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */
2321 /* AK 281098 V2.0 */
2322 {
2323 INT ai = S_I_I(a);
2324 INT bi = S_I_I(b);
2325 if (ai == bi) return(0L);
2326 if (ai > bi) return(1L);
2327 return(-1L);
2328 }
2329
comp_integer(a,b)2330 INT comp_integer(a,b) OP a,b;
2331 /* AK 280888 */ /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */
2332 /* AK 040298 V2.0 */
2333 /* a is of type INTEGER
2334 type of b is from
2335 BRUCH, INTEGER, LONGINT, POLYNOM */
2336 {
2337 INT erg = OK;
2338 CTO(INTEGER,"comp_integer(1)",a);
2339
2340 switch (S_O_K(b))
2341 {
2342 #ifdef BRUCHTRUE
2343 case BRUCH:
2344 return -1 * comp_bruch_scalar(b,a);
2345 #endif /* BRUCHTRUE */
2346
2347 case INTEGER:
2348 return COMP_INTEGER_INTEGER(a,b);
2349
2350 #ifdef LONGINTTRUE
2351 case LONGINT:
2352 return -1 * comp_longint_integer(b,a);
2353 #endif /* LONGINTTRUE */
2354
2355 #ifdef POLYTRUE
2356 case POLYNOM:
2357 return -1 * comp_polynom_scalar(b,a);
2358 #endif /* POLYTRUE */
2359
2360 default:
2361 WTO("comp_integer(2)",b);goto endr_ende;
2362 }
2363 ENDR("comp_integer");
2364 }
2365
2366
2367
quores_integer(a,b,c,d)2368 INT quores_integer(a,b,c,d) OP a,b,c,d;
2369 /* AK 280888 */ /* AK 270689 V1.0 */ /* AK 081289 V1.1 */
2370 /* AK 210891 V1.3 */
2371 /* d is always positive */
2372 /* a is integer */
2373 {
2374 INT erg = OK;
2375 CTO(INTEGER,"quores_integer(1)",a);
2376 CTO(EMPTY,"quores_integer(3)",c);
2377 CTO(EMPTY,"quores_integer(4)",d);
2378
2379 switch(S_O_K(b))
2380 {
2381 case INTEGER:
2382 {
2383 M_I_I(S_I_I(a) / S_I_I(b), c);
2384 M_I_I(S_I_I(a) % S_I_I(b), d);
2385 if ((S_I_I(d) < 0L) && (S_I_I(b) < 0L))
2386 {
2387 M_I_I(S_I_I(d)-S_I_I(b),d);
2388 INC_INTEGER(c);
2389 }
2390 if ((S_I_I(d) < 0L) && (S_I_I(b) > 0L))
2391 {
2392 M_I_I(S_I_I(d)+S_I_I(b),d);
2393 DEC_INTEGER(c);
2394 }
2395 goto endr_ende;
2396 }
2397 #ifdef LONGINTTRUE
2398 case LONGINT:
2399 {
2400 if (NULLP_INTEGER(a)) /* AK 020103 */
2401 {
2402 M_I_I(0,c);
2403 M_I_I(0,d);
2404 }
2405 else
2406 {
2407 OP e = callocobject();
2408 erg += m_i_longint(S_I_I(a),e);
2409 erg += quores_longint(e,b,c,d);
2410 erg += freeall(e);
2411 }
2412 goto endr_ende;
2413 };
2414 #endif /* LONGINTTRUE */
2415 default: WTT("quores_integer",a,b); goto endr_ende;
2416 }
2417 ENDR("quores_integer");
2418 }
2419
nullp_integer(a)2420 INT nullp_integer(a) OP a;
2421 /* AK 280689 V1.0 */ /* AK 181289 V1.1 */
2422 /* AK 210891 V1.3 */
2423 /* a is integer */
2424 {
2425 return( (S_I_I(a) == 0L) ? TRUE : FALSE );
2426 }
2427
einsp_integer(a)2428 INT einsp_integer(a) OP a;
2429 /* AK 270689 V1.0 */ /* AK 181289 V1.1 */
2430 /* AK 210891 V1.3 */
2431 /* a is integer */
2432 {
2433 return ((S_I_I(a) == 1L)?TRUE:FALSE);
2434 }
2435
negeinsp_integer(a)2436 INT negeinsp_integer(a) OP a;
2437 /* AK 070789 V1.0 */ /* AK 181289 V1.1 */
2438 /* AK 210891 V1.3 */
2439 /* a is integer */
2440 {
2441 return ((S_I_I(a) == -1L)? TRUE : FALSE);
2442 }
2443
copy_integer(a,c)2444 INT copy_integer(a,c) OP a,c;
2445 /* AK 270689 V1.0 */ /* AK 181289 V1.1 */
2446 /* AK 210891 V1.3 */
2447 {
2448 M_I_I( S_I_I(a),c);
2449 return OK;
2450 }
2451
2452 #ifdef BRUCHTRUE
invers_integer(a,b)2453 INT invers_integer(a,b) OP a,b;
2454 /* AK 031286 */ /* AK 220888 gilt auch bei longint */
2455 /* AK 270689 V1.0 */ /* AK 151289 V1.1 */ /* AK 210891 V1.3 */
2456 {
2457 INT erg = OK;
2458 CTO(INTEGER,"invers_integer(1)",a);
2459 CTO(EMPTY,"invers_integer(2)",b);
2460 if (EINSP_INTEGER(a))
2461 {
2462 M_I_I(1,b);
2463 goto endr_ende;
2464 }
2465 if (NEGEINSP_INTEGER(a))
2466 {
2467 M_I_I(-1,b);
2468 goto endr_ende;
2469 }
2470 erg += b_ou_b(CALLOCOBJECT(),CALLOCOBJECT(),b);
2471 M_I_I(1,S_B_O(b));
2472 M_I_I(S_I_I(a),S_B_U(b));
2473 C_B_I(b,GEKUERZT);
2474 ENDR("invers_integer");
2475 }
2476 #endif /* BRUCHTRUE */
2477
2478
random_integer(res,para_eins,para_zwei)2479 INT random_integer(res,para_eins,para_zwei) OP res,para_eins,para_zwei;
2480 /* AK 150587 */ /* AK 090688 changed */
2481 /* para_eins = lower limit, para_zwei= upper limit */
2482 /* res will be a pseudo random number
2483 between lower and upper limit. */
2484 /* uses the system function rand() */
2485 /* para_eins and para_zwei may be NULL
2486 in this case an integer between 0 and 10 */
2487 /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */
2488 /* AK 300802 V2.0 */ /* AK 080306 V3.0 */
2489 {
2490 INT untergrenze,obergrenze,ires,zi;
2491 INT erg = OK;
2492 int rand();
2493
2494 if (para_eins==NULL)
2495 untergrenze=0;
2496 else if (S_O_K(para_eins) != INTEGER)
2497 WTO("random_integer(2)",para_eins);
2498 else untergrenze = S_I_I(para_eins);
2499
2500
2501 if (para_zwei==NULL)
2502 obergrenze=untergrenze + 10;
2503 else if (S_O_K(para_zwei) != INTEGER)
2504 #ifdef LONGINTTRUE
2505 {
2506 if (S_O_K(para_zwei)==LONGINT) /* AK 151092 */
2507 {
2508 OP c = callocobject();
2509 COPY(para_zwei,c);
2510 if (para_eins != NULL)
2511 erg += sub(c,para_eins,c);
2512
2513 if (S_O_K(c) == LONGINT)
2514 erg += random_longint(res,c);
2515 else
2516 erg += random_integer(res,NULL,c);
2517
2518 if (para_eins != NULL)
2519 erg += add_apply(para_eins,res);
2520 freeall(c);
2521 goto endr_ende;
2522 }
2523 else
2524 #endif /* LONGINTTRUE */
2525 WTO("random_integer(3)",para_zwei);
2526 #ifdef LONGINTTRUE
2527 }
2528 #endif /* LONGINTTRUE */
2529 else obergrenze = S_I_I(para_zwei);
2530
2531 SYMCHECK(obergrenze < untergrenze,"random_integer: upper limit < lower limit");
2532
2533 if (obergrenze > untergrenze)
2534 {
2535 zi = rand() % (obergrenze - untergrenze);
2536 ires = untergrenze + zi;
2537 }
2538 else
2539 ires = untergrenze;
2540 erg += m_i_i(ires,res);
2541 ENDR("random_integer");
2542 }
2543
tex_integer(a)2544 INT tex_integer(a) OP a;
2545 /* AK 101187 */ /* AK 270689 V1.0 */ /* AK 181289 V1.1 */
2546 /* AK 070291 V1.2 prints to texout instead of stdout */
2547 /* AK 210891 V1.3 */
2548 {
2549 INT ts = texmath_yn; /* AK 190892 */
2550 texposition += /* AK 210291 */ intlog(a);
2551 if (S_I_I(a) <0L) texposition++;
2552 if (ts == 0L)
2553 {
2554 fprintf(texout," $%ld$ ",S_I_I(a));
2555 texposition += 4L;
2556 }
2557 else
2558 fprintf(texout," %ld ",S_I_I(a));
2559 return OK;
2560 }
2561
2562
scan_integer(ergebnis)2563 INT scan_integer(ergebnis) OP ergebnis;
2564 /* liest ein integerobject ein AK 270787 */
2565 /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 080591 V1.2 */
2566 /* AK 210891 V1.3 */
2567 {
2568 char c;
2569 int eingabe;
2570 INT erg = OK;
2571 INT numberofmatches;
2572 CTO(EMPTY,"scan_integer(1)",ergebnis);
2573
2574 sia:
2575 scan_printeingabe("integerobject ");
2576 skip_comment();
2577 numberofmatches = (INT)scanf("%d",&eingabe);
2578 if (numberofmatches == EOF) /* AK 220807 */
2579 {
2580 error("scan_integer:EOF");
2581 goto endr_ende;
2582 }
2583 if (numberofmatches != (INT)1)
2584 {
2585 while ((c = getchar()) != '\n');
2586 error("scan_integer:I did not recognize a number");
2587 goto sia;
2588 }
2589 M_I_I((INT)eingabe,ergebnis);
2590 ENDR("scan_integer");
2591 }
2592
skip_integer(t)2593 INT skip_integer(t) char *t;
2594 /* AK 300998 */
2595 {
2596 INT erg = OK;
2597 char *oldt = t;
2598 int SYM_isdigit();
2599
2600 while (*t == ' ') t++;
2601 if (*t == '-') t++;
2602 if (not SYM_isdigit(*t))
2603 {
2604 error("skip_integer:not a INTEGER");
2605 erg = -10;
2606 goto endr_ende;
2607 }
2608 while (SYM_isdigit(*t)) t++;
2609 return (INT)(t-oldt);
2610 ENDR("skip_integer");
2611 }
2612
sscan_integer(t,a)2613 INT sscan_integer(t,a) OP a; char *t;
2614 /* AK 301293 */
2615 {
2616 long i;
2617 sscanf(t,"%ld",&i);
2618 m_i_i((INT)i,a);
2619 return OK;
2620 }
2621
objectread_integer(filename,obj)2622 INT objectread_integer(filename,obj) FILE *filename; OP obj;
2623 /* AK 131086 */ /* AK 270689 V1.0 */ /* AK 181289 V1.1 */
2624 /* AK 020591 V1.2 */ /* AK 210891 V1.3 */
2625 {
2626 INT eingabe;
2627 INT erg = OK;
2628 COP("objectread_integer(1)",filename);
2629 fscanf(filename, "%" SCNINT ,&eingabe);
2630 M_I_I(eingabe,obj);
2631 ENDR("objectread_integer");
2632 }
2633
objectwrite_integer(filename,obj)2634 INT objectwrite_integer(filename,obj) FILE *filename; OP obj;
2635 /* AK 131086 */ /* AK 270689 V1.0 */ /* AK 181289 V1.1 */
2636 /* AK 210891 V1.3 */
2637 {
2638 INT erg = OK;
2639 COP("objectwrite_integer(1)",filename);
2640 fprintf(filename, " %" PRIINT " %ld\n" ,(INT)INTEGER,S_I_I(obj));
2641 ENDR("objectwrite_integer");
2642 }
2643
sprint_integer(string,a)2644 INT sprint_integer(string,a) char *string; OP a;
2645 /* AK 020295 */
2646 /* AK 240398 V2.0 */
2647 {
2648 INT erg = OK;
2649 CTO(INTEGER,"sprint_integer(2)",a);
2650 sprintf(string,"%ld",S_I_I(a));
2651 ENDR("sprint_integer");
2652 }
2653
fprint_integer(f,a)2654 INT fprint_integer(f,a) FILE *f; OP a;
2655 /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */
2656 /* AK 190298 V2.0 */ /* AK 201204 V3.0 */
2657 {
2658 INT erg = OK;
2659 CTO(INTEGER,"fprint_integer",a);
2660 SYMCHECK(f == NULL,"fprint_integer:NULL file pointer");
2661
2662 {
2663 INT l;
2664 if (f == stdout)
2665 {
2666 l = intlog(a);
2667 zeilenposition += l;
2668
2669 if (l < integer_format)
2670 {
2671 /* we need leading blanks */
2672 l = integer_format-l;
2673 zeilenposition += l;
2674 while (l--) putchar(' ');
2675 }
2676 if (S_I_I(a) < 0)
2677 zeilenposition++; /* for the leading sign */
2678 }
2679 fprintf(f,"%ld",S_I_I(a));
2680 if (f == stdout)
2681 if (zeilenposition >= row_length)
2682 { fprintf(f,"\n"); zeilenposition = 0; }
2683
2684 }
2685 ENDR("fprint_integer");
2686 }
2687
s_i_i(a)2688 INT s_i_i(a) OP a;
2689 /* to be faster, use the macro S_I_I */
2690 /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */
2691 /* AK 201204 V3.0 */
2692 {
2693 INT erg = OK;
2694 CTO(INTEGER,"s_i_i",a);
2695 return a->ob_self.ob_INT;
2696 ENDR("s_i_i");
2697 }
2698
c_i_i(a,b)2699 INT c_i_i(a,b) OP a;INT b;
2700 /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */
2701 {
2702 INT erg = OK;
2703 CTO(INTEGER,"c_i_i",a);
2704 a->ob_self.ob_INT=b;
2705 ENDR("c_i_i");
2706 }
2707
m_i_i(a,b)2708 INT m_i_i(a,b) INT a;OP b;
2709 /* AK 270689 V1.0 AK 181289 V1.1 AK 110291 V1.2 AK 060891 V1.3 */
2710 {
2711 INT erg=OK;
2712 COP("m_i_i",b);
2713 FREESELF(b);
2714 C_O_K(b,INTEGER);
2715 C_I_I(b,a);
2716 ENDR("m_i_i");
2717 }
2718
freeself_integer(a)2719 INT freeself_integer(a) OP a;
2720 /* AK 270689 V1.0 AK 181289 V1.1 AK 210891 V1.3 */
2721 {
2722 C_O_K(a,EMPTY);
2723 return(OK);
2724 }
2725
test_integer()2726 INT test_integer()
2727 /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */
2728 {
2729 OP a=callocobject();
2730 OP b=callocobject();
2731 OP c=callocobject();
2732 INT erg;
2733
2734 m_i_i(5L,a);
2735 printf("test_integer:m_i_i(5L,a)\n");
2736 debugprint_object(a);
2737 C_I_I(a,7L);
2738 printf("test_integer:c_i_i(a,7L)\n");
2739 debugprint_object(a);
2740 printf("test_integer:fprint_integer(stdout,a)\n");
2741 fprint_integer(stdout,a);
2742 printf("\n");
2743 printf("test_integer:tex_integer(a)\n");
2744 tex_integer(a);
2745 printf("\n");
2746 printf("test_integer:copy_integer(a,b)\n");
2747 copy_integer(a,b);
2748 printf("b=");
2749 println(b);
2750 printf("test_integer:comp_integer_integer(a,b)\n");
2751 erg=comp_integer_integer(a,b);
2752 printf( "%" PRIINT "\n" ,erg);
2753 printf("test_integer:binom(a=5L,b=4L,c)\n");
2754 m_i_i(5L,a);
2755 m_i_i(4L,b);
2756 binom(a,b,c);
2757 println(c);
2758 freeall(a);
2759 freeall(b);
2760 freeall(c);
2761 return(OK);
2762 }
2763
2764 #ifdef POLYTRUE
add_apply_scalar_polynom(a,b)2765 INT add_apply_scalar_polynom(a,b) OP a,b;
2766 /* AK 110990 V1.1 */ /* AK 270291 V1.2 */ /* AK 080891 V1.3 */
2767 /* AK 260298 V2.0 */
2768 /* input: a = INTEGER or
2769 BRUCH or
2770 LONGINT */
2771 {
2772 INT erg = OK;
2773 OP c;
2774 CE2A(a,b,add_apply_scalar_polynom);
2775 CTO(POLYNOM,"add_apply_scalar_polynom(2)",b);
2776
2777 c = callocobject();
2778 erg += m_scalar_polynom(a,c);
2779 erg += insert(c,b,add_koeff,comp_monomvector_monomvector);
2780
2781 ENDR("add_apply_scalar_polynom");
2782 }
2783 #endif /* POLYTRUE */
2784
add_apply_integer(a,b)2785 INT add_apply_integer(a,b) OP a,b;
2786 /* AK 120390 V1.1 */ /* AK 080891 V1.3 */
2787 /* AK 260298 V2.0 */
2788 {
2789 INT erg=OK;
2790 OP d;
2791 CTO(INTEGER,"add_apply_integer(1)",a);
2792
2793 switch(S_O_K(b)) {
2794 #ifdef BRUCHTRUE
2795 case BRUCH:
2796 erg += add_apply_scalar_bruch(a,b);
2797 break;
2798 #endif /* BRUCHTRUE */
2799
2800 case INTEGER:
2801 erg += add_apply_integer_integer(a,b);
2802 break;
2803
2804 #ifdef LONGINTTRUE
2805 case LONGINT:
2806 erg += add_apply_integer_longint(a,b);
2807 break;
2808 #endif /* LONGINTTRUE */
2809
2810 #ifdef SCHURTRUE
2811 case SCHUR:
2812 d = callocobject();
2813 erg += m_scalar_schur(a,d);
2814 insert(d,b,add_koeff,comp_monomschur);
2815 break;
2816 #endif /* SCHURTRUE */
2817
2818 #ifdef POLYTRUE
2819 case SCHUBERT:
2820 case POLYNOM:
2821 erg += add_apply_scalar_polynom(a,b);
2822 break;
2823 #endif /* POLYTRUE */
2824
2825 default:
2826 {
2827 OP c;
2828 c = callocobject();
2829 *c = *b;
2830 C_O_K(b,EMPTY);
2831 erg += add_integer(a,c,b);
2832 erg += freeall(c);
2833 }
2834 break;
2835 }
2836 ENDR("add_apply_integer");
2837 }
2838
2839
2840 #ifdef MATRIXTRUE
mult_apply_integer_matrix(a,b)2841 INT mult_apply_integer_matrix(a,b) OP a,b;
2842 /* b = b* a */ /* AK 220390 V1.1 */ /* AK 250291 V1.2 */
2843 /* AK 080891 V1.3 */
2844 /* AK 260298 V2.0 */
2845 {
2846 OP z = S_M_S(b);
2847 INT i = S_M_HI(b)*S_M_LI(b);
2848 INT erg = OK;
2849 CTO(INTEGER,"mult_apply_integer_matrix(1)",a);
2850 CTO(MATRIX,"mult_apply_integer_matrix(2)",b);
2851
2852 for(;i>0L;i--,z++)
2853 MULT_APPLY_INTEGER(a,z);
2854
2855 ENDR("mult_apply_integer_matrix");
2856 }
2857 #endif /* MATRIXTRUE */
2858
2859
mult_apply_integer(a,b)2860 INT mult_apply_integer(a,b) OP a,b;
2861 /* b = b* a */ /* AK 201289 V1.1 */ /* AK 250291 V1.2 */
2862 /* AK 210891 V1.3 */
2863 /* AK 260298 V2.0 */
2864 {
2865 INT erg = OK;
2866 EOP("mult_apply_integer(2)",b);
2867 CTO(INTEGER,"mult_apply_integer(1)",a);
2868
2869 switch(S_O_K(b)) {
2870 #ifdef BRUCHTRUE
2871 case BRUCH:
2872 erg += mult_apply_integer_bruch(a,b);
2873 break;
2874 #endif /* BRUCHTRUE */
2875
2876 case INTEGER:
2877 erg += mult_apply_integer_integer(a,b);
2878 break;
2879
2880 #ifdef LONGINTTRUE
2881 case LONGINT:
2882 erg += mult_apply_integer_longint(a,b);
2883 break;
2884 #endif /* LONGINTTRUE */
2885
2886 #ifdef MATRIXTRUE
2887 case KRANZTYPUS :
2888 case MATRIX:
2889 erg += mult_apply_integer_matrix(a,b);
2890 break;
2891 #endif /* MATRIXTRUE */
2892
2893 #ifdef CHARTRUE
2894 case SYMCHAR:
2895 erg += mult_apply_scalar_symchar(a,b);
2896 break;
2897 #endif /* CHARTRUE */
2898
2899 #ifdef POLYTRUE
2900 case MONOM:
2901 erg += mult_apply_integer_monom(a,b);
2902 break;
2903 case SCHUR:
2904 case POW_SYM:
2905 case ELM_SYM:
2906 case HOM_SYM:
2907 case MONOMIAL:
2908 case SCHUBERT:
2909 case GRAL:
2910 case POLYNOM:
2911 case MONOPOLY:
2912 erg += mult_apply_integer_polynom(a,b);
2913 break;
2914 #endif /* POLYTRUE */
2915
2916 #ifdef NUMBERTRUE
2917 case SQ_RADICAL:
2918 erg += mult_apply_scalar_sqrad(a,b);
2919 break;
2920 case CYCLOTOMIC:
2921 erg += mult_apply_scalar_cyclo(a,b);
2922 break;
2923 #endif /* NUMBERTRUE */
2924
2925 #ifdef VECTORTRUE
2926 case INTEGERVECTOR:
2927 case COMPOSITION:
2928 case WORD:
2929 case VECTOR:
2930 erg += mult_apply_scalar_vector(a,b);
2931 break;
2932 case HASHTABLE:
2933 erg += mult_apply_integer_hashtable(a,b);
2934 break;
2935
2936 #endif /* VECTORTRUE */
2937 default:
2938 if (S_I_I(a) == (INT)1) { }
2939 else if (S_I_I(a) == (INT)-1)
2940 erg += addinvers_apply(b);
2941 else
2942 erg += WTO("mult_apply_integer: wrong second type",b);
2943 }
2944 ENDR("mult_apply_integer");
2945 }
2946
square_apply_integer(a)2947 INT square_apply_integer(a) OP a;
2948 /* AK 271101 */
2949 /* a = a * a */
2950 {
2951 INT erg = OK;
2952 INT i;
2953 CTO(INTEGER,"square_apply_integer(1)",a);
2954 i = S_I_I(a);
2955 if (i<0) i = -i;
2956
2957 if (i < 46340) /* sqrt(2^31 */
2958 {
2959 M_I_I(S_I_I(a) * S_I_I(a),a);
2960 }
2961 else{
2962 OP c;
2963 c = CALLOCOBJECT();
2964 *c = *a;
2965 C_O_K(a,EMPTY);
2966 t_int_longint(c,a);
2967 erg += mult_apply_integer_longint(c,a);
2968 FREEALL(c);
2969 }
2970 ENDR("square_apply_integer");
2971 }
2972
mult_apply_integer_integer(a,b)2973 INT mult_apply_integer_integer(a,b) OP a,b;
2974 /* AK 201289 V1.1 */ /* AK 250291 V1.2 */
2975 /* AK 210891 V1.3 */
2976 /* AK 270298 V2.0 */
2977 {
2978 INT erg = OK;
2979 CTO(INTEGER,"mult_apply_integer_integer(1)",a);
2980 CTO(INTEGER,"mult_apply_integer_integer(2)",b);
2981
2982 if (
2983 (S_I_I(a) < 46300) && (S_I_I(a) > -46300)
2984 &&
2985 (S_I_I(b) < 46300) && (S_I_I(b) > -46300)
2986 )
2987 M_I_I(S_I_I(a)*S_I_I(b),b);
2988 else
2989 {
2990 if ( (INTLOG(a) + INTLOG(b)) > 9L )
2991 {
2992 if (S_I_I(a)==0) M_I_I(0,b);
2993 else if (S_I_I(b)!=0)
2994 {
2995 erg += t_int_longint(b,b);
2996 erg += mult_apply_integer_longint(a,b);
2997 }
2998 }
2999 else
3000 M_I_I(S_I_I(a)*S_I_I(b),b);
3001 }
3002 ENDR("mult_apply_integer_integer");
3003 }
3004
3005
3006
add_apply_integer_integer(a,b)3007 INT add_apply_integer_integer(a,b) OP a,b;
3008 /* AK 120390 V1.1 */ /* AK 250291 V1.2 */ /* AK 210891 V1.3 */
3009 /* AK 270298 V2.0 */
3010 /* AK 050902 V2.1 */
3011 {
3012 INT erg = OK;
3013 INT i;
3014 CTO(INTEGER,"add_apply_integer_integer(1)",a);
3015 CTO(INTEGER,"add_apply_integer_integer(2)",b);
3016
3017 i = S_I_I(a)+S_I_I(b);
3018 if (
3019 ( (S_I_I(a) > 0) && (S_I_I(b) > 0) && (i <= 0) )
3020 ||
3021 ( (S_I_I(a) < 0) && (S_I_I(b) < 0) && (i >= 0) )
3022 )
3023 /* we have to change to longint arithmetic */
3024 {
3025 #ifdef LONGINTTRUE
3026 OP c;
3027 c = CALLOCOBJECT();
3028 erg += t_int_longint(b,c);
3029 FREESELF(b);
3030 *b = *c;
3031 C_O_K(c,EMPTY);
3032 FREEALL(c);
3033 erg += add_apply_integer_longint(a,b);
3034 #else /* LONGINTTRUE */
3035 erg += error("add_apply_integer_integer:Overflow no LONGINT");
3036 #endif /* LONGINTTRUE */
3037 }
3038 else
3039 C_I_I(b,i);
3040
3041 ENDR("add_apply_integer_integer");
3042 }
3043
intlog_int(ai)3044 INT intlog_int(ai) INT ai;
3045 /* number of digits of an int */
3046 /* AK 201204 V3.0 */
3047 {
3048 if (ai < 0L) ai = -ai;
3049 if (ai >= 1000000000L) return(10L);
3050 if (ai >= 100000000L) return(9L);
3051 if (ai >= 10000000L) return(8L);
3052 if (ai >= 1000000L) return(7L);
3053 if (ai >= 100000L) return(6L);
3054 if (ai >= 10000L) return(5L);
3055 if (ai >= 1000L) return(4L);
3056 if (ai >= 100L) return(3L);
3057 if (ai >= 10L) return(2L);
3058 return(1L);
3059 }
3060
intlog(a)3061 INT intlog(a) OP a;
3062 /* number of digits of an integer object */
3063 /* AK 150290 V1.1 */ /* AK 250291 V1.2 */
3064 /* AK 210891 V1.3 */ /* AK 201204 V3.0 */
3065 {
3066 INT erg = OK;
3067 CTTO(LONGINT,INTEGER,"intlog(1)",a);
3068 if (S_O_K(a) == INTEGER)
3069 {
3070 INT ai;
3071 ai = S_I_I(a);
3072 if (ai < 0L) ai = -ai;
3073 if (ai >= 1000000000L) return(10L);
3074 if (ai >= 100000000L) return(9L);
3075 if (ai >= 10000000L) return(8L);
3076 if (ai >= 1000000L) return(7L);
3077 if (ai >= 100000L) return(6L);
3078 if (ai >= 10000L) return(5L);
3079 if (ai >= 1000L) return(4L);
3080 if (ai >= 100L) return(3L);
3081 if (ai >= 10L) return(2L);
3082 return(1L);
3083 }
3084 else if (S_O_K(a) == LONGINT)
3085 {
3086 return intlog_longint(a);
3087 }
3088 ENDR("intlog");
3089 }
3090
init(kind,a)3091 INT init(kind,a) OBJECTKIND kind; OP a;
3092 /* AK 300588 */ /* AK 030789 V1.0 */ /* AK 060390 V1.1 */ /* AK 250291 V1.2 */
3093 /* AK 050891 V1.3 */
3094 {
3095 INT erg=OK;
3096 COP("init(2)",a);
3097 FREESELF(a);
3098
3099 switch (kind) {
3100 case EMPTY:
3101 break;
3102 #ifdef BINTREETRUE
3103 case BINTREE: erg += init_bintree(a); break;
3104 #endif /* BINTREETRUE */
3105 #ifdef BRUCHTRUE
3106 case BRUCH:
3107 erg += b_ou_b(callocobject(),callocobject(),a);
3108 break;
3109 #endif /* BRUCHTRUE */
3110 case INTEGER:
3111 M_I_I(0,a); /* AK 050902 */
3112 break;
3113 #ifdef KRANZTRUE
3114 case KRANZ: erg+= init_kranz(a);
3115 break;
3116 #endif /* KRANZTRUE */
3117 #ifdef LONGINTTRUE
3118 case LONGINT: erg += init_longint(a); break;
3119 #endif /* LONGINTTRUE */
3120 #ifdef MONOMTRUE
3121 case MONOM:
3122 erg += b_sk_mo(callocobject(),callocobject(),a);
3123 break;
3124 #endif /* MONOMMTRUE */
3125 #ifdef NUMBERTRUE
3126 case CYCLOTOMIC:
3127 erg += init_cyclo(a);
3128 break;
3129 case SQ_RADICAL:
3130 /* MD */
3131 erg += init_sqrad(a);
3132 break;
3133 #endif /* NUMBERTRUE */
3134 #ifdef PARTTRUE
3135 case PARTITION:
3136 erg+= b_ks_pa(VECTOR,callocobject(),a);break;
3137 #endif /* PARTTRUE */
3138 #ifdef PERMTRUE
3139 case PERMUTATION:
3140 erg+=b_ks_p(VECTOR,callocobject(),a);break;
3141 #endif /* PERMTRUE */
3142 #ifdef REIHETRUE
3143 case REIHE: erg+=init_reihe(a);break;
3144 #endif /* REIHETRUE */
3145 #ifdef LISTTRUE
3146 case SCHUR:
3147 erg += init_schur(a);
3148 break;
3149 case HOMSYM:
3150 erg += init_homsym(a);
3151 break;
3152
3153 case GRAL: case POW_SYM: case MONOPOLY:
3154 case POLYNOM: case ELM_SYM: case MONOMIAL: case SCHUBERT:
3155 case LIST:
3156 erg += b_sn_l(NULL,NULL,a);
3157 C_O_K(a,kind);
3158 break;
3159 #endif /* LISTTRUE */
3160 #ifdef TABLEAUXTRUE
3161 case TABLEAUX:
3162 erg+=b_us_t(callocobject(),callocobject(),a); break;
3163 #endif /* TABLEAUXTRUE */
3164 #ifdef VECTORTRUE
3165 case BITVECTOR:
3166 erg += m_il_bv((INT)0,a);break;
3167 case INTEGERVECTOR:
3168 case WORD:
3169 case VECTOR:
3170 case COMPOSITION:
3171 case SUBSET:
3172 erg += m_il_v((INT)0,a);
3173 C_O_K(a,kind);
3174 break;
3175 case QUEUE:
3176 erg += init_queue(a);
3177 break;
3178 case HASHTABLE:
3179 erg += init_hashtable(a);
3180 break;
3181 #endif /* VECTORTRUE */
3182 default:
3183 fprintf(stderr, "kind = %" PRIINT "\n" ,(INT) kind);
3184 return error("init:wrong kind");
3185 }
3186
3187 CTO(kind,"init(e2)",a);
3188 ENDR("init");
3189 }
3190
next_apply(obj)3191 INT next_apply(obj) OP obj;
3192 /* AK 300997 */
3193 {
3194 INT erg = OK;
3195 EOP("next_apply(1)",obj);
3196 switch(S_O_K(obj))
3197 {
3198 #ifdef FFTRUE
3199 case FF: /* AK 290304 */
3200 erg = next_apply_ff(obj);
3201 if (erg == ERROR)
3202 goto endr_ende;
3203 return (erg == LAST_FF ? FALSE : TRUE );
3204 #endif /* FFTRUE */
3205
3206
3207
3208 #ifdef PARTTRUE
3209 case SUBSET: /* AK 280901 */
3210 return((next_apply_subset(obj)
3211 ==
3212 LASTSUBSET)?
3213 FALSE : TRUE);
3214 case COMPOSITION:
3215 return((next_apply_composition(obj)
3216 ==
3217 LASTCOMP)?
3218 FALSE : TRUE);
3219 case PARTITION:
3220 return((next_apply_partition(obj)
3221 ==
3222 LASTPARTITION)?
3223 FALSE : TRUE);
3224 #endif /* PARTTRUE */
3225 #ifdef PERMTRUE
3226 case PERMUTATION: /* AK 280901 */
3227 if (S_P_K(obj) == VECTOR)
3228 return (next_apply_permutation(obj) == LASTPERMUTATION)? FALSE : TRUE;
3229 else if (S_P_K(obj) == BAR) /* AK 120902 */
3230 return (next_apply_bar(obj) == LASTPERMUTATION)? FALSE : TRUE;
3231 else
3232 {
3233 error("wrong kind of permutation in next_apply");
3234 goto endr_ende;
3235 }
3236 #endif /* PERMTRUE */
3237 default:
3238 erg+= WTO("next_apply(1)",obj);
3239 break;
3240 }
3241 ENDR("next_apply");
3242 }
3243
next(von,nach)3244 INT next(von,nach) OP von, nach;
3245 /* AK 220488 */ /* AK 030789 V1.0 */ /* AK 081289 V1.1 */ /* AK 250291 V1.2 */
3246 /* AK 050891 V1.3 */
3247 {
3248 INT erg = OK;
3249
3250 EOP("next",von);
3251 /* nicht CE2 wg. return value */
3252 if (check_equal_2(von,nach,next,&erg) == EQUAL)
3253 return erg;
3254
3255 switch(S_O_K(von))
3256 {
3257 #ifdef FFTRUE
3258 case FF: /* AK 170194 */
3259 erg = next_ff(von,nach);
3260 if (erg == ERROR)
3261 goto endr_ende;
3262 return (erg == LAST_FF ? FALSE : TRUE );
3263 #endif /* FFTRUE */
3264 #ifdef PARTTRUE
3265 case PARTITION: {
3266 return((next_partition(von,nach)
3267 ==
3268 LASTPARTITION)?
3269 FALSE : TRUE);
3270 }
3271 case COMPOSITION: {
3272 return((next_composition(von,nach)
3273 ==
3274 LASTCOMP)?
3275 FALSE : TRUE);
3276 }
3277 case SUBSET: {
3278 return((next_subset(von,nach)
3279 ==
3280 LASTSUBSET)?
3281 FALSE : TRUE);
3282 }
3283 #endif /* PARTTRUE */
3284 #ifdef PERMTRUE
3285 case PERMUTATION: {
3286 if (S_P_K(von) == BAR)
3287 return((next_bar(von,nach) == LASTPERMUTATION)?
3288 FALSE : TRUE);
3289 else if (S_P_K(von) == VECTOR)
3290 return((next_permutation(von,nach) == LASTPERMUTATION)?
3291 FALSE : TRUE);
3292 else
3293 return error("next: wrong kind of permutation");
3294 }
3295 #endif /* PERMTRUE */
3296 default: erg+= WTO("next(1)",von);
3297 break;
3298 }
3299 ENDR("next");
3300 }
3301
find(a,b)3302 OP find (a,b) OP a,b;
3303 /* return NULL if a not in b */
3304 /* AK 251103 */
3305 {
3306 INT erg =OK;
3307 if (VECTORP(b)) return find_vector(a,b);
3308 WTO("find(2)",b);
3309 ENDO("find");
3310 }
3311
3312
insert(a,c,eh,cf)3313 INT insert(a,c,eh,cf) OP a,c; INT (*eh)(),(*cf)();
3314 /* AK 221286*/ /* AK 030789 V1.0 */ /* AK 221289 V1.1 */ /* AK 250291 V1.2 */
3315 /* AK 060891 V1.3 */
3316 /* inserts a into c */
3317 /* AK 060498 V2.0 */
3318 {
3319 INT erg = OK;
3320 if (a == NULL)
3321 {
3322 erg += error("insert:first == NULL");
3323 goto endr_ende;
3324 }
3325 if (a == c)
3326 {
3327 erg += error("insert:first == ERGEBNIS");
3328 goto endr_ende;
3329 }
3330 if (EMPTYP(a))
3331 {
3332 erg += freeall(a);
3333 goto endr_ende;
3334 }
3335
3336
3337 switch(S_O_K(c))
3338 {
3339 #ifdef VECTORTRUE
3340 case HASHTABLE:
3341 erg = insert_hashtable(a,c, eh,cf,hash);
3342 goto endr_ende;
3343 #endif
3344
3345 #ifdef BINTREETRUE
3346 case BINTREE:
3347 erg = insert_bintree(a,c, eh,cf);
3348 switch (erg) {
3349 case INSERTOK:
3350 case INSERTEQ:
3351 return erg;
3352 }
3353 goto endr_ende;
3354 #endif /* BINTREETRUE */
3355
3356 #ifdef LISTTRUE
3357 case LIST:
3358 erg += insert_list(a,c,eh,cf);
3359 goto endr_ende;
3360 #endif /* LISTTRUE */
3361
3362 case MONOPOLY:
3363 case SCHUR:
3364 case SCHUBERT:
3365 case POW_SYM:
3366 case HOM_SYM:
3367 case GRAL:
3368 case POLYNOM:
3369 case ELM_SYM:
3370 case MONOMIAL:
3371 #ifdef LISTTRUE
3372 if (cf == NULL)
3373 cf= comp_monomvector_monomvector;
3374 if (eh == NULL)
3375 eh = add_koeff;
3376 erg += insert_list(a,c, eh,cf);
3377 goto endr_ende;
3378 #endif /* LISTTRUE */
3379
3380 default:
3381 ;
3382 };
3383
3384 switch(S_O_K(a))
3385 {
3386 #ifdef POLYTRUE
3387 case GRAL:
3388 case HOM_SYM:
3389 case POW_SYM:
3390 case MONOPOLY:
3391 case SCHUBERT:
3392 case SCHUR:
3393 case POLYNOM:
3394 case ELM_SYM:
3395 case MONOMIAL:
3396 if (cf == NULL)
3397 cf= comp_monomvector_monomvector;
3398 if (eh == NULL)
3399 eh = add_koeff;
3400 erg += insert_list(a,c, eh,cf);
3401 goto endr_ende;
3402 #endif /* POLYTRUE */
3403 default:
3404 erg += WTT("insert(1,2)",a,c);
3405 goto endr_ende;
3406 };
3407 ENDR("insert");
3408 }
3409
3410
first(kind,res,para_eins)3411 INT first(kind,res,para_eins) OBJECTKIND kind; OP res,para_eins;
3412 /* AK 270788 */ /* AK 030789 V1.0 */ /* AK 060390 V1.1 */ /* AK 200691 V1.2 */
3413 /* AK 210891 V1.3 */
3414 {
3415 INT erg = OK;
3416 CE2(res,para_eins,first);
3417 if (not EMPTYP(res))
3418 erg += freeself(res);
3419 switch (kind)
3420 {
3421 #ifdef PERMTRUE
3422 case PERMUTATION: erg += first_permutation(para_eins,res);
3423 break;
3424 #endif /* PERMTRUE */
3425 #ifdef PARTTRUE
3426 case PARTITION: erg += first_partition(para_eins,res);
3427 break;
3428 #endif /* PARTTRUE */
3429 default: return error("first:wrong kind");
3430 };
3431 ENDR("first");
3432 }
3433
b_ks_o(kind,self,object)3434 INT b_ks_o(kind,self,object) OBJECTKIND kind; OBJECTSELF self; OP object;
3435 /* build_kind_self_object */ /* AK 061086 */
3436 /* erzeugt ein object der art kind (z.B. VECTOR)
3437 und einen pointer auf self, das eigentliche
3438 object (z.B. struct vector) 270787/ */
3439 /* AK 270689 V1.0 */ /* AK 060390 V1.1 */ /* AK 210891 V1.3 */
3440 {
3441 INT erg = OK;
3442 COP("b_ks_o",object);
3443 FREESELF(object);
3444 C_O_K(object,kind);
3445 C_O_S(object,self);
3446 ENDR("b_ks_o");
3447 }
3448
3449
3450 /* must be with offset */ INT (*check_time_co)();
3451
3452
check_time()3453 INT check_time()
3454 {
3455 static INT l_callocobject;
3456 if (check_time_co != NULL)
3457 {
3458 (*check_time_co)();
3459 }
3460 runtime(&l_callocobject);
3461 if (l_callocobject > sym_timelimit)
3462 {
3463 fprintf(stderr,"SYMMETRICA stopped due to timelimit\n");
3464 exit(ERROR_TIMELIMIT);
3465 }
3466 return OK;
3467 }
3468
callocobject_magma()3469 OP callocobject_magma()
3470 {
3471 OP res;
3472 res = (OP) SYM_MALLOC(sizeof(struct object));
3473 C_O_K(res,EMPTY);
3474 return res;
3475 }
3476
callocobject()3477 OP callocobject()
3478 /* erzeugt den speicherplatz fuer ein object 270787 */
3479 /* AK 270689 V1.0 */ /* AK 170190 V1.1 */ /* AK 060891 V1.3 */
3480 {
3481 #ifdef SYMMAGMA
3482 return callocobject_magma();
3483 #else
3484 OP c;
3485 if (sym_timelimit > 0L)
3486 check_time();
3487
3488 if (freeall_speicherposition >= 0L) /* AK 111091 */
3489 {
3490 c = freeall_speicher[freeall_speicherposition--];
3491 }
3492 else
3493 c = (OP) SYM_MALLOC(sizeof(struct object));
3494
3495 if (c == NULL)
3496 error("callocobject:NULL object");
3497
3498
3499 C_O_K(c,EMPTY);
3500 return c;
3501 #endif
3502 }
3503
callocobject_fast()3504 OP callocobject_fast()
3505 /* AK 141101 */
3506 {
3507 OP c;
3508 c = (OP) SYM_MALLOC(sizeof(struct object));
3509 C_O_K(c,EMPTY);
3510 return c;
3511 }
3512
s_o_s(a)3513 OBJECTSELF s_o_s(a) OP a;
3514 /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 060891 V1.3 */
3515 {
3516 if (a==NULL)
3517 {
3518 error("s_o_s:object == NULL");
3519 }
3520 return(a->ob_self);
3521 }
3522
s_o_k(a)3523 OBJECTKIND s_o_k(a) OP a;
3524 /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */
3525 {
3526 if (a==NULL) {return((OBJECTKIND) error("s_o_k:object == NULL"));}
3527 return(a->ob_kind);
3528 }
3529
c_o_k(a,b)3530 INT c_o_k(a,b) OP a; OBJECTKIND b;
3531 /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */
3532 {
3533 INT erg = OK;
3534 COP("c_o_k",a);
3535 a->ob_kind = b;
3536 ENDR("c_o_k");
3537 }
3538
c_o_s(a,b)3539 INT c_o_s(a,b) OP a; OBJECTSELF b;
3540 /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */
3541 {
3542 INT erg = OK;
3543 COP("c_o_s",a);
3544 a->ob_self = b;
3545 ENDR("c_o_s");
3546 }
3547
emptyp(a)3548 INT emptyp(a) OP a;
3549 /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */
3550 {
3551 return(s_o_k(a) == EMPTY);
3552 }
3553
test_callocobject()3554 INT test_callocobject()
3555 /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */
3556 {
3557 OP a = callocobject();
3558 printf("test_callocobject: sizeof(OP)=%zu\n",sizeof(a));
3559 printf("test_callocobject: sizeof(*OP)=%zu\n",sizeof(*a));
3560 printf("test_callocobject: sizeof(struct object)=%zu\n",sizeof(struct object));
3561 if (a==NULL) {
3562 printf("test_callocobject: NULL-object");return(OK);
3563 }
3564 printf("test_callocobject: a=%p\n",a);
3565 printf( "test_callocobject: a->ob_kind=%" PRIOBJECTKIND "\n" ,a->ob_kind);
3566 printf( "test_callocobject: a->ob_self.ob_INT=%" PRIdPTR " \n" ,
3567 (a->ob_self).ob_INT);
3568 SYM_free(a);
3569 return(OK);
3570 }
3571
debugprint_object(a)3572 INT debugprint_object(a) OP a;
3573 /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */
3574 {
3575 if (a==NULL) {
3576 fprintf(stderr,"debugprint_object: NULL-object");return(OK);}
3577 fprintf(stderr,"debugprint_object: a=%p\n",a);
3578 fprintf(stderr, "debugprint_object: kind=%" PRIOBJECTKIND "\n" ,a->ob_kind);
3579 fprintf(stderr, "debugprint_object: self.INT=%" PRIdPTR "\n" ,a->ob_self.ob_INT);
3580 return(OK);
3581 }
3582
test_object()3583 INT test_object()
3584 /* AK 270689 V1.0 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */
3585 {
3586 OP a=callocobject();
3587 OBJECTSELF d;
3588 printf("test von callocobject()\n");
3589 test_callocobject();
3590 printf("\nobject vor c_o_k()\n");
3591 debugprint_object(a);
3592 c_o_k(a,(OBJECTKIND)5);
3593 printf("\nobject nach c_o_k(a,5)\n");
3594 debugprint_object(a);
3595 d.ob_INT = 12345L;
3596 c_o_s(a,d);
3597 printf("\nobject nach c_o_s(a,12345L)\n");
3598 debugprint_object(a);
3599 SYM_free(a);
3600 return(OK);
3601 }
3602
3603
3604 #ifdef SKEWPARTTRUE
s_spa_g(a)3605 OP s_spa_g(a) OP a;
3606 /* AK 181289 V1.1 */ /* AK 210891 V1.3 */
3607 {
3608 OBJECTSELF b;
3609 INT erg = OK;
3610 CTO(SKEWPARTITION,"s_spa_g",a);
3611 b = s_o_s(a);
3612 return b.ob_skewpartition->spa_gross;
3613 ENDO("s_spa_g");
3614 }
3615
c_spa_g(a,b)3616 INT c_spa_g(a,b) OP a,b;
3617 /* AK 280789 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */
3618 {
3619 OBJECTSELF c;
3620 c=s_o_s(a);
3621 c.ob_skewpartition->spa_gross=b;
3622 return(OK);
3623 }
3624
s_spa_k(a)3625 OP s_spa_k(a) OP a;
3626 /* AK 181289 V1.1 */ /* AK 210891 V1.3 */
3627 {
3628 OBJECTSELF c;
3629 c = s_o_s(a);
3630 return(c.ob_skewpartition->spa_klein);
3631 }
3632
c_spa_k(a,b)3633 INT c_spa_k(a,b) OP a,b;
3634 /* AK 280789 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */
3635 {
3636 OBJECTSELF c;
3637 c=s_o_s(a);
3638 c.ob_skewpartition->spa_klein=b;
3639 return(OK);
3640 }
3641
s_spa_gi(a,i)3642 OP s_spa_gi(a,i) OP a; INT i;
3643 /* AK 260789 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */
3644 { return(s_pa_i(s_spa_g(a),i)); }
3645
s_spa_ki(a,i)3646 OP s_spa_ki(a,i) OP a; INT i;
3647 /* AK 260789 V1.1 */ /* AK 210891 V1.3 */
3648 { return(s_pa_i(s_spa_k(a),i)); }
3649
s_spa_gii(a,i)3650 INT s_spa_gii(a,i) OP a; INT i;
3651 /* AK 260789 V1.1 */
3652 /* AK 210891 V1.3 */
3653 { return(s_pa_ii(s_spa_g(a),i)); }
3654
s_spa_gli(a)3655 INT s_spa_gli(a) OP a;
3656 /* AK 260789 V1.1 */ /* AK 210891 V1.3 */
3657 { return(s_pa_li(s_spa_g(a))); }
3658
s_spa_kii(a,i)3659 INT s_spa_kii(a,i) OP a; INT i;
3660 /* AK 260789 V1.1 */ /* AK 210891 V1.3 */
3661 { return(s_pa_ii(s_spa_k(a),i)); }
3662
s_spa_kli(a)3663 INT s_spa_kli(a) OP a;
3664 /* AK 260789 V1.1 */ /* AK 210891 V1.3 */
3665 { return(s_pa_li(s_spa_k(a))); }
3666 #endif
3667
comp_skewpartition(a,b)3668 INT comp_skewpartition(a,b) OP a,b;
3669 {
3670 INT erg=OK;
3671 INT res=0;
3672 CTO(SKEWPARTITION,"comp_skewpartition(1)",a);
3673 CTO(ANYTYPE,"comp_skewpartition(2)",b);
3674
3675 if (S_O_K(b) == SKEWPARTITION)
3676 res= comp_skewpartition_skewpartition(a,b);
3677 else
3678 WTO("comp_partition(2)",b);
3679 return res;
3680 ENDR("comp_skewpartition");
3681 }
3682
comp_skewpartition_skewpartition(a,b)3683 INT comp_skewpartition_skewpartition(a,b) OP a,b;
3684 {
3685 INT erg=OK;
3686 CTO(SKEWPARTITION,"comp_skewpartition_skewpartition(1)",a);
3687 CTO(SKEWPARTITION,"comp_skewpartition_skewpartition(2)",b);
3688 erg = comp(S_SPA_G(a), S_SPA_G(b));
3689 if (erg != 0)
3690 return erg;
3691 return comp(S_SPA_K(a), S_SPA_K(b));
3692 ENDR("comp_skewpartition_skewpartition");
3693 }
3694
lastof_skewpartition(a,b)3695 INT lastof_skewpartition(a,b) OP a,b;
3696 /* AK 280789 */ /* AK 181289 V1.1 */
3697 /* AK 210891 V1.3 */
3698 {
3699 #ifdef SKEWPARTTRUE
3700 return(lastof(S_SPA_G(a),b));
3701 #else
3702 return error("lastof_skewpartition:SKEWPARTITION not available");
3703 #endif
3704 }
3705
3706 #ifdef SKEWPARTTRUE
length_skewpartition(a,b)3707 INT length_skewpartition(a,b) OP a,b;
3708 /* AK 280789 */ /* AK 181289 V1.1 */
3709 /* AK 210891 V1.3 */
3710 {
3711 return length(S_SPA_G(a),b);
3712 }
3713
hash_skewpartition(a)3714 INT hash_skewpartition(a) OP a;
3715 /* AK 201201 */
3716 {
3717 INT erg = OK;
3718 CTO(SKEWPARTITION,"hash_skewpartition(1)",a);
3719 return hash_partition(S_SPA_G(a)) + 11 * hash_partition(S_SPA_K(a));
3720 ENDR("hash_skewpartition");
3721 }
3722
freeself_skewpartition(a)3723 INT freeself_skewpartition(a) OP a;
3724 /* AK 280789 V1.1 */ /* AK 210891 V1.3 */
3725 {
3726 INT erg = OK;
3727 CTO(SKEWPARTITION,"freeself_skewpartition(1)",a);
3728
3729 FREEALL(S_SPA_G(a));
3730 FREEALL(S_SPA_K(a));
3731 SYM_free(S_O_S(a).ob_skewpartition);
3732 C_O_K(a,EMPTY);
3733 ENDR("freeself_skewpartition");
3734 }
3735
copy_skewpartition(a,b)3736 INT copy_skewpartition(a,b) OP a,b;
3737 /* AK 280789 V1.1 */ /* AK 140891 V1.3 */
3738 {
3739 INT erg = OK;
3740 CTO(SKEWPARTITION,"copy_skewpartition(1)",a);
3741 CTO(EMPTY,"copy_skewpartition(2)",b);
3742
3743 erg += b_gk_spa(callocobject(),callocobject(),b);
3744 copy_partition(S_SPA_G(a),S_SPA_G(b));
3745 copy_partition(S_SPA_K(a),S_SPA_K(b));
3746
3747 ENDR("copy_skewpartition");
3748 }
3749
weight_skewpartition(a,b)3750 INT weight_skewpartition(a,b) OP a,b;
3751 /* AK 020488 */ /* AK 060390 V1.1 */ /* AK 020591 V1.2 */
3752 /* AK 210891 V1.3 */
3753 {
3754 OP c=callocobject(), d=callocobject();
3755 weight(S_SPA_G(a),c);
3756 weight(s_spa_k(a),d);
3757 sub(c,d,b);
3758 freeall(c);
3759 freeall(d);
3760 return(OK);
3761 }
3762
objectread_skewpartition(f,a)3763 INT objectread_skewpartition(f,a) FILE *f; OP a;
3764 /* AK 210690 V1.1 */ /* AK 020591 V1.2 */
3765 /* AK 210891 V1.3 */
3766 {
3767 b_gk_spa(callocobject(),callocobject(),a);
3768 objectread(f,S_SPA_G(a));
3769 objectread(f,s_spa_k(a));
3770 return OK;
3771 }
3772
objectwrite_skewpartition(f,a)3773 INT objectwrite_skewpartition(f,a) FILE *f; OP a;
3774 /* AK 210690 V1.1 */
3775 /* AK 210891 V1.3 */
3776 {
3777 INT erg = OK;
3778 COP("objectwrite_skewpartition(1)",f);
3779 fprintf(f, "%" PRIINT " ", (INT)SKEWPARTITION);
3780 erg += objectwrite(f,S_SPA_G(a));
3781 erg += objectwrite(f,s_spa_k(a));
3782 ENDR("objectwrite_skewpartition");
3783 }
3784
dimension_skewpartition(a,b)3785 INT dimension_skewpartition(a,b) OP a,b;
3786 /* dimension der dartsellung */
3787 /* AK 020890 V1.1 */ /* AK 210891 V1.3 */
3788 {
3789 OP c = callocobject();
3790 part_part_skewschur(S_SPA_G(a),S_SPA_K(a),c);
3791 dimension(c,b);
3792 freeall(c);
3793 return OK;
3794 }
3795
3796
starpart(a,b,c)3797 INT starpart(a,b,c) OP a,b,c;
3798 /* 020488 AK implementiert staroperation aus REWH */
3799 /* bsp 123 * 222 -> 222345/222 */
3800 /* AK 181289 V1.1 */ /* AK 210891 V1.3 */
3801 {
3802 INT i,letztes;
3803 OP glength = callocobject();
3804 OP klength = callocobject();
3805
3806 b_gk_spa(callocobject(),callocobject(),c);
3807 add(S_PA_L(a),S_PA_L(b),glength);
3808 length(a,klength);
3809 b_kl_pa(VECTOR,glength,S_SPA_G(c));
3810 b_kl_pa(VECTOR,klength,S_SPA_K(c));
3811
3812 letztes = S_PA_II(b,S_PA_LI(b)-1);
3813 for (i=0L;i<S_PA_LI(a);i++) M_I_I(letztes,s_spa_ki(c,i));
3814 for (i=0L;i<S_PA_LI(b);i++)
3815 M_I_I(S_PA_II(b,i),s_spa_gi(c,i));
3816 for (i=0L;i<S_PA_LI(a);i++)
3817 M_I_I(S_PA_II(a,i)+letztes,s_spa_gi(c,i+S_PA_LI(b)));
3818 return OK;
3819 }
3820
3821
ferrers_skewpartition(a)3822 INT ferrers_skewpartition(a) OP a;
3823 {
3824 return error("ferrers_skewpartition: not yet implemented");
3825 }
3826 #endif /* SKEWPARTTRUE */
3827
3828 #ifdef SKEWPARTTRUE
fprint_skewpartition(f,a)3829 INT fprint_skewpartition(f,a) OP a; FILE *f;
3830 /* AK 280789 */ /* AK 181289 V1.1 */ /* AK 210891 V1.3 */
3831 {
3832 INT erg = OK; /* AK 150192 */
3833 erg += fprint(f,S_SPA_G(a));
3834 fprintf(f," / ");
3835 erg += fprint(f,s_spa_k(a));
3836 return erg; /* AK 150192 */
3837 }
3838
sprint_skewpartition(t,s)3839 INT sprint_skewpartition(t,s) char *t; OP s;
3840 {
3841 INT erg = OK;
3842 CTO(SKEWPARTITION,"sprint_skewpartition(2)",s);
3843 sprint_partition(t,S_SPA_G(s));
3844 sprintf(t+strlen(t),"-");
3845 sprint_partition(t+strlen(t),S_SPA_K(s));
3846 ENDR("sprint_skewpartition");
3847 }
3848
3849
3850
scan_skewpartition(a)3851 INT scan_skewpartition(a) OP a;
3852 /* 020488 AK */ /* AK 010889 V1.1 */ /* AK 210891 V1.3 */
3853 {
3854 b_gk_spa(callocobject(),callocobject(),a);
3855 scan_printeingabe("input of a skewpartition, the big partition");
3856 scan(PARTITION,S_SPA_G(a));
3857 scan_printeingabe("input of a skewpartition, the small partition");
3858 scan(PARTITION,s_spa_k(a));
3859 return(OK);
3860 }
3861
3862
callocskewpartition()3863 static struct skewpartition * callocskewpartition()
3864 /* 020488 AK erste prozedur beim einfuehren eines neuen datentyps */
3865 /* AK 181289 V1.1 */ /* AK 210891 V1.3 */
3866 {
3867 struct skewpartition *erg
3868 = (struct skewpartition *) SYM_calloc(1,sizeof(struct skewpartition));
3869 if (erg == NULL) error("erg == NULL in callocskewpartition()");
3870 return(erg);
3871 }
3872
skewpartitionp(a)3873 INT skewpartitionp(a) OP a;
3874 /* AK V2.0 040398 */
3875 /* TRUE if a skewpartition */
3876 {
3877 if (S_O_K(a) != SKEWPARTITION)
3878 return FALSE;
3879 if (not partitionp(S_SPA_G(a)))
3880 return FALSE;
3881 if (not partitionp(S_SPA_K(a)))
3882 return FALSE;
3883 return TRUE;
3884 }
3885
m_gk_spa(gross,klein,res)3886 INT m_gk_spa(gross,klein,res) OP gross,klein,res;
3887 /* AK 110790 V1.1 */ /* AK 140891 V1.3 */
3888 /* AK V2.0 090298 */
3889 /* input: two PARTITION objects gross, klein
3890 output: SKEWPARTITION res = gross/klein
3891 */
3892 {
3893 INT erg = OK;
3894 CTO(PARTITION,"m_gk_spa",gross);
3895 CTO(PARTITION,"m_gk_spa",klein);
3896 CE3(gross,klein,res,m_gk_spa);
3897 erg += b_gk_spa(callocobject(),callocobject(),res);
3898 erg += copy_partition(gross,S_SPA_G(res));
3899 erg += copy_partition(klein,S_SPA_K(res));
3900 ENDR("m_gk_spa");
3901 }
3902
b_gk_spa(gross,klein,ergebnis)3903 INT b_gk_spa(gross,klein,ergebnis) OP gross,klein,ergebnis;
3904 /* AK 020488 */
3905 /* AK 181289 V1.1 */ /* AK 140891 V1.3 */
3906 /* AK 040398 V2.0 */
3907 {
3908 OBJECTSELF d;
3909
3910 if (ergebnis==NULL)
3911 return ERROR;
3912
3913 d.ob_skewpartition = callocskewpartition();
3914 b_ks_o(SKEWPARTITION, d, ergebnis);
3915
3916 c_spa_g(ergebnis,gross); /*change_skewpartition_gross*/
3917 c_spa_k(ergebnis,klein); /*change_skewpartition_klein*/
3918 return(OK);
3919 }
3920 #endif /* SKEWPARTTRUE */
3921
3922 #ifdef WORDTRUE
test_word()3923 INT test_word()
3924 /* AK 030892 */
3925 {
3926 OP c = callocobject();
3927 OP b = callocobject();
3928 OP a = callocobject();
3929 printf("random_word(30,b):");
3930 m_i_i(30L,a); random_word(a,b); println(b);
3931 printf("content(b,c):");
3932 content(b,c); println(c);
3933 freeall(a);
3934 freeall(b);
3935 freeall(c);
3936 return OK;
3937 }
3938 #endif /* WORDTRUE */
3939
3940 #ifdef WORDTRUE
charge_word(a,b)3941 INT charge_word(a,b) OP a,b;
3942 /* AK 151196 */
3943 {
3944 OP c,d,e,f;
3945 INT erg = OK,i,r=0,j,oj;
3946 c = callocobject();
3947 erg += content_word(a,c);
3948 if (einsp(c)) goto aaa;
3949 if (not decreasingp_vector(c))
3950 {
3951 erg += fprint(stderr,a);
3952 erg += fprint(stderr,c);
3953 erg += error("charge_word:not decreasing content of the word");
3954 goto endr_ende;
3955 }
3956 /* decompose into standard words */
3957 d = callocobject();
3958 e = callocobject();
3959 f = callocobject();
3960 erg += m_v_pa(c,d);
3961 erg += conjugate(d,d);
3962 erg += copy(a,c);
3963 erg += m_i_i(0,b);
3964 for (i=S_PA_LI(d)-1;i>=0;i--) /* number of subwords */
3965 {
3966 r = 1;
3967 m_il_w(S_PA_II(d,i),e); /* the subword */
3968 ccc:
3969 j=S_W_LI(c)-1;
3970 ddd:
3971 if (S_W_II(c,j) == r) { r++; M_I_I(-S_W_II(c,j),S_W_I(c,j)); }
3972 j--;
3973 if (r == S_W_LI(e) +1) goto bbb; /* one word finished */
3974 if (j == -1) goto ccc; else goto ddd;
3975 bbb:
3976 for (j=0,r=0;j<S_W_LI(c);j++)
3977 if (S_W_II(c,j) < 0)
3978 {
3979 M_I_I(-S_W_II(c,j),S_W_I(e,r));
3980 r++;
3981 M_I_I(0,S_W_I(c,j));
3982 }
3983 erg += charge_word(e,f);
3984 erg += add_apply(f,b);
3985 }
3986 erg += freeall(d);
3987 erg += freeall(e);
3988 erg += freeall(f);
3989 goto eee;
3990 aaa:
3991 oj = S_V_LI(c);
3992 for (i=1;i<= S_V_LI(c);i++)
3993 {
3994 for (j=0;j<S_W_LI(a);j++)
3995 if (S_W_II(a,j) == i)
3996 {
3997 if (j > oj) r++;
3998 M_I_I(r,S_V_I(c,j));
3999 oj = j;
4000 }
4001 }
4002 erg += SYM_sum(c,b);
4003 eee:
4004 erg += freeall(c);
4005 ENDR("charge_word");
4006 }
4007
random_word(a,b)4008 INT random_word(a,b) OP a,b;
4009 /* AK 030892 */
4010 /* a random word of length a and entries between 1 and 2 * length */
4011 {
4012 OP c;
4013 INT erg = OK, i;
4014 CTO(INTEGER,"random_word(1)",a);
4015 c = CALLOCOBJECT();
4016 M_I_I(S_I_I(a)+S_I_I(a),c);
4017 erg += m_l_w(a,b);
4018 for (i=0L;i<S_W_LI(b);i++)
4019 erg += random_integer(S_W_I(b,i),cons_eins,c);
4020 FREEALL(c);
4021 ENDR("random_word");
4022 }
4023 #endif /* WORDTRUE */
4024
4025 #ifdef WORDTRUE
S_a_rofword(w,a,r)4026 INT S_a_rofword(w,a,r) OP w,a,r;
4027 /* 220488 */ /* AK 160890 V1.1 */ /* AK 210891 V1.3 */
4028 {
4029 OP i=callocobject();
4030 if (ge(a,r)) { fprintln(stderr,a); fprintln(stderr,r);
4031 error("a >= r in S_a_rofword"); }
4032
4033 copy(r,i);
4034 do { dec(i); S_rofword(w,i); } while( ge(i,a) );
4035 freeall(i);
4036 return(OK);
4037 }
4038
4039
4040
S_rofword(w,r)4041 INT S_rofword(w,r) OP w,r;
4042 /* 210488 */ /* AK 160890 V1.1 */
4043 /* liefert TRUE solange ein r-index > 0 */
4044 /* AK 210891 V1.3 */
4045 {
4046 INT erg = OK;
4047 OP m=callocobject();
4048 OP index=callocobject();
4049
4050 erg += maxrindexword(w,r,index,m);
4051 if (S_I_I(m) <= 0L) return(FALSE);
4052 M_I_I(S_I_I(r)-1L,S_W_I(w,S_I_I(index)));
4053 erg += freeall(m);
4054 erg += freeall(index);
4055 return(TRUE);
4056 }
4057
4058
4059
content_word(a,b)4060 INT content_word(a,b) OP a,b;
4061 /* AK 300792 */
4062 {
4063 INT erg=OK,m,i;
4064 CTTO(VECTOR,WORD,"content_word(1)",a);
4065 CTO(EMPTY,"content_word(2)",b);
4066
4067
4068 m=0L;
4069 for (i=0L;i<S_W_LI(a);i++)
4070 if (S_W_II(a,i)>m)
4071 m=S_W_II(a,i);
4072 /* m is max */
4073 erg += m_il_nv(m,b);
4074 for (i=0L;i<S_W_LI(a);i++)
4075 {
4076 if (S_W_II(a,i) < 1L)
4077 {
4078 erg += freeself(b);
4079 return error("content_word: wrong word content");
4080 }
4081 INC_INTEGER(S_V_I(b,S_W_II(a,i)-1L));
4082 }
4083 ENDR("content_word");
4084 }
4085
4086
4087
R_roftableaux(w,r)4088 INT R_roftableaux(w,r) OP w,r;
4089 /* 250488 */ /* AK 160890 V1.1 */
4090 /* AK 210891 V1.3 */
4091 /* der umriss wird nicht gebraucht */
4092 {
4093 INT j,i,k;
4094
4095 i=s_t_hi(w)-S_I_I(r)+1L; /* die zeilenummer in die gewechselt wird */
4096 for (j=0L;j<s_t_li(w);j++)
4097 if (EMPTYP(s_t_ij(w,i,j))) break;
4098 if (j==s_t_li(w)) { inc(w); i=i+1L; };
4099 /* j ist die spaltennummer in die gewechselt wird */
4100
4101 for (k=0L;k<s_t_li(w);k++) if (EMPTYP(s_t_ij(w,i-1L,k))) break;
4102 k = k-1L;
4103 /* k ist die spaltennummer aus der gewechselt wird */
4104
4105 M_I_I(s_t_iji(w,i-1L,k),s_t_ij(w,i,j));
4106 freeself(s_t_ij(w,i-1L,k));return(OK);
4107 }
4108
4109
4110
starttableaux(t,s)4111 INT starttableaux(t,s) OP t,s;
4112 /* berechnet das Tableaux T_0 aus MD */
4113 /* 250488 */ /* AK 160890 V1.1 */
4114 /* AK 210891 V1.3 */
4115 {
4116 OP in = callocobject();
4117 OP m = callocobject();
4118 OP l = callocobject();
4119 OP h = callocobject();
4120
4121 INT i,j,k;
4122
4123 m_us_t(callocobject(),callocobject(),s);
4124 content(t,in); max(in,m);
4125
4126 /* ist der maximale eintrag in content */
4127 copy(s_v_l(in),h); copy(m,l);
4128 m_lh_m(l,h,S_T_S(s));
4129 for (i=S_I_I(h)-1L,k=0L;i>=0L;i--,k++)
4130 for (j=s_v_ii(in,k)-1L;j>=0L;j--)
4131 M_I_I(k+1L,s_t_ij(s,i,j));
4132
4133 freeall(in);
4134 SYM_free(m);
4135 return OK;
4136 }
4137
rm_rindex(word,r)4138 INT rm_rindex(word,r) OP word,r;
4139 /* 250488 */ /* AK 160890 V1.1 */
4140 /* AK 210891 V1.3 */
4141 {
4142 while(S_rofword(word,r))
4143 {
4144 };
4145 return(OK);
4146 }
4147
4148
4149
4150
coroutine250488(i,word,tableaux)4151 static INT coroutine250488(i,word,tableaux) INT i; OP word,tableaux;
4152 /* AK 160890 V1.1 */ /* AK 210891 V1.3 */
4153 {
4154 OP rindex=callocobject();
4155 OP umriss;
4156 INT erg=OK;
4157 M_I_I(i,rindex);
4158 while(S_rofword(word,rindex))
4159 erg += R_roftableaux(tableaux,rindex);
4160 /* simultane operation auf tableaux */
4161
4162
4163 if (i>2)
4164 erg += coroutine250488(i-1L,word,tableaux);
4165
4166 umriss = callocobject(); /* AK 100688 den umriss ausrechnen */
4167 erg+= m_matrix_umriss(S_T_S(tableaux), S_T_U(tableaux));
4168
4169 erg += freeall(rindex);
4170 return erg;
4171 }
4172
4173
4174
m_tableaux_tableauxpair(tab,ergtab_eins,s)4175 INT m_tableaux_tableauxpair(tab,ergtab_eins,s) OP tab,ergtab_eins,s;
4176 /* AK 160890 V1.1 */ /* AK 210891 V1.3 */
4177 {
4178 OP w = callocobject();
4179
4180 INT i,j,l;
4181 INT index;
4182
4183 wordoftableaux(tab,w);
4184 starttableaux(tab,s);
4185 l = s_t_hi(s);
4186 for(i=2L;i<=l;i++)
4187 coroutine250488(i,w,s);
4188 copy(tab,ergtab_eins);
4189 index=0L;
4190 for (i=s_t_hi(ergtab_eins)-1L;i>=0L;i--)
4191 for (j=s_t_li(ergtab_eins)-1L;j>=0L;j--)
4192 if (not EMPTYP(s_t_ij(ergtab_eins,i,j)))
4193 {
4194 M_I_I(S_W_II(w,index),s_t_ij(ergtab_eins,i,j));
4195 index++;
4196 };
4197 freeall(w);
4198 return OK;
4199 }
4200
4201
4202
maxrindexword(w,r,index,erg)4203 INT maxrindexword(w,r,index,erg) OP w,r,erg,index;
4204 /*210488*/ /* AK 160890 V1.1 */
4205 /* berechnet den maximalen wert der r-indices */
4206 /* er wird an der stelle index erreicht */
4207 /* AK 210891 V1.3 */
4208 {
4209 INT i;
4210 OP zw_eins=callocobject();
4211 OP stelle=callocobject();
4212
4213 M_I_I(-1000000L,erg);
4214 M_I_I(0L,index);
4215 for(i=0L;i<s_w_li(w);i++)
4216 {
4217 M_I_I(i,stelle);
4218 rindexword(w,r,stelle,zw_eins);
4219 if (gr(zw_eins,erg)) {copy(zw_eins,erg);M_I_I(i,index);};
4220 };
4221 freeall(zw_eins); freeall(stelle);return(OK);
4222 }
4223
4224
4225
latticepword(w)4226 INT latticepword(w) OP w;
4227 /* 210488 */ /* AK 160890 V1.1 */
4228 /* AK 210891 V1.3 */
4229 {
4230 OP m = callocobject();
4231 OP null = callocobject();
4232 OP stelle = callocobject();
4233 OP r = callocobject();
4234 OP erg = callocobject();
4235 INT i,j,a=FALSE;
4236
4237 max(w,m);
4238 M_I_I(0L,null);
4239 for (i=2L;i<=S_I_I(m);i++)
4240 for(j=0L;j<s_w_li(w);j++)
4241 {
4242 M_I_I(i,r); M_I_I(j,stelle); rindexword(w,r,stelle,erg);
4243 if (gr(erg,null)) goto lwende;
4244 };
4245 a = TRUE;
4246 lwende:
4247 freeall(null); freeall(r); freeall(erg); freeall(stelle);
4248 return(a);
4249 }
4250
4251
4252
rindexword(w,r,stelle,erg)4253 INT rindexword(w,r,stelle,erg) OP w,r,stelle,erg;
4254 /* 210488 */ /* AK 020290 V1.1 */
4255 /* AK 210891 V1.3 */
4256 {
4257 OP zw_eins= callocobject();
4258 OP zw_zwei= callocobject();
4259 if (S_I_I(r) <= 1) error("zu diesem r ist r-index nicht definiert");
4260 dec(r);
4261 rindexword_sub(w,r,stelle,zw_eins);
4262 inc(r);
4263 rindexword_sub(w,r,stelle,zw_zwei);
4264 sub(zw_zwei,zw_eins,erg);
4265 freeall(zw_eins);
4266 freeall(zw_zwei);
4267 return OK;
4268 }
4269
4270
4271
rindexword_sub(w,r,stelle,erg)4272 INT rindexword_sub(w,r,stelle,erg) OP w,r,stelle,erg;
4273 /* 210488 */ /* AK 020290 V1.1 */
4274 /* AK 210891 V1.3 */
4275 {
4276 INT i,z=0L;
4277 if (ge(stelle,s_w_l(w))) { error("so lang ist das wort nicht"); };
4278 for(i=0L;i<=S_I_I(stelle);i++)
4279 if (S_W_II(w,i) == S_I_I(r)) z++;
4280 M_I_I(z,erg);
4281 return(OK);
4282 }
4283
4284
4285
sscan_word(t,a)4286 INT sscan_word(t,a) char *t; OP a;
4287 {
4288 INT erg = OK;
4289 COP("sscan_word(1)",t);
4290 erg += sscan_integervector(t,a);
4291 C_O_K(a,WORD);
4292 ENDR("sscan_word");
4293 }
4294
scan_word(ergebnis)4295 INT scan_word(ergebnis) OP ergebnis;
4296 /* AK 020290 V1.1 */ /* AK 210891 V1.3 */
4297 {
4298 OP l = callocobject();
4299 INT i,erg=OK;
4300 CTO(EMPTY,"scan_word(1)",ergebnis);
4301
4302 erg += scan_printeingabe("length of the word ");
4303 erg += scan(INTEGER,l);
4304
4305 erg += b_l_w(l,ergebnis);
4306 for (i=0L;i < S_I_I(l); erg += scan(INTEGER,S_W_I(ergebnis,i++)));
4307 ENDR("scan_word");
4308 }
4309
4310
4311
s_w_s(a)4312 OP s_w_s(a) OP a;
4313 /* AK 260789 */ /* AK 181289 V1.1 */
4314 /* AK 210891 V1.3 */
4315 {
4316 return(s_v_s(a));
4317 }
4318
s_w_l(a)4319 OP s_w_l(a) OP a;
4320 /* AK 260789 */ /* AK 181289 V1.1 */
4321 /* AK 210891 V1.3 */
4322 {
4323 return(s_v_l(a));
4324 }
4325
s_w_li(a)4326 INT s_w_li(a) OP a;
4327 /* AK 260789 */ /* AK 181289 V1.1 */
4328 /* AK 210891 V1.3 */
4329 {
4330 return(s_v_li(a));
4331 }
4332
s_w_i(a,i)4333 OP s_w_i(a,i) OP a;INT i;
4334 /* AK 260789 */ /* AK 181289 V1.1 */
4335 /* AK 210891 V1.3 */
4336 {
4337 return(s_v_i(a,i));
4338 }
4339
s_w_ii(a,i)4340 INT s_w_ii(a,i) OP a;INT i;
4341 /* AK 260789 */ /* AK 181289 V1.1 */
4342 /* AK 210891 V1.3 */
4343 {
4344 return(s_v_ii(a,i));
4345 }
4346 #endif /* WORDTRUE */
4347
cast_apply_integer(a)4348 INT cast_apply_integer(a) OP a;
4349 /* AK a is a object which should become a INTEGER */
4350 {
4351 INT erg = OK,err;
4352 COP("cast_apply_integer(1)",a);
4353
4354 switch(S_O_K(a)) {
4355 case INTEGER: break;
4356 #ifdef LONGINTTRUE
4357 case LONGINT: erg += t_longint_int(a,a);
4358 if (S_O_K(a) != INTEGER)
4359 erg+= error("cast_apply_integer: LONGINT too big");
4360 break;
4361 #endif
4362 #ifdef BRUCHTRUE
4363 case BRUCH:
4364 erg += kuerzen(a);
4365 if (S_O_K(a) == BRUCH)
4366 {
4367 erg+=
4368 error("cast_apply_integer: BRUCH with nenner != 1");
4369 break;
4370 }
4371 erg += cast_apply_integer(a);
4372 break;
4373 #endif
4374 default:
4375 err = error("cast_apply_integer: cannot cast to INTEGER");
4376 if (err==ERROR_EXPLAIN)
4377 {
4378 fprintf(stderr,"I tried to convert:");
4379 fprintln(stderr,a);
4380 }
4381 erg += ERROR;
4382 }
4383 CTO(INTEGER,"cast_apply_integer(e1)",a);
4384 ENDR("cast_apply_integer");
4385 }
4386
4387
4388
cast_apply(k,a)4389 INT cast_apply(k,a) OBJECTKIND k; OP a;
4390 /* AK 140293 */
4391 /* to cast into correct datatype */
4392 {
4393 INT erg = OK;
4394 COP("cast_apply(1)",a);
4395
4396 if (k == S_O_K(a))
4397 goto cae;
4398 switch (k) {
4399 #ifdef FFTRUE
4400 case FF:
4401 erg += cast_apply_ff(a); break;
4402 #endif /* FFTRUE */
4403 #ifdef BRUCHTRUE
4404 case BRUCH:
4405 erg += cast_apply_bruch(a) ; break;
4406 #endif /* BRUCHTRUE */
4407 case INTEGER:
4408 erg += cast_apply_integer(a); break;
4409 #ifdef MATRIXTRUE
4410 case MATRIX:
4411 erg += cast_apply_matrix(a); break;
4412 #endif
4413 case MONOM:
4414 erg += cast_apply_monom(a); break;
4415 #ifdef PARTTRUE
4416 case PARTITION:
4417 erg += cast_apply_part(a); break;
4418 #endif
4419 #ifdef PERMTRUE
4420 case PERMUTATION:
4421 erg += cast_apply_perm(a); break;
4422 case BARPERM:
4423 erg += cast_apply_barperm(a); break;
4424 #endif
4425 #ifdef SCHURTRUE
4426 case ELMSYM:
4427 erg += cast_apply_elmsym(a); break;
4428 case SCHUR:
4429 erg += cast_apply_schur(a); break;
4430 case POWSYM:
4431 erg += cast_apply_powsym(a); break;
4432 case HOMSYM:
4433 erg += cast_apply_homsym(a); break;
4434 case MONOMIAL:
4435 erg += cast_apply_monomial(a); break;
4436 #endif
4437 #ifdef MONOPOLYTRUE
4438 case MONOPOLY:
4439 erg += cast_apply_monopoly(a);
4440 break;
4441 #endif
4442 #ifdef POLYTRUE
4443 case POLYNOM:
4444 erg += cast_apply_polynom(a); break;
4445 #endif
4446 #ifdef SCHUBERTTRUE
4447 case SCHUBERT:
4448 erg += cast_apply_schubert(a); break;
4449 #endif
4450 #ifdef TABLEAUXTRUE
4451 case TABLEAUX:
4452 erg += cast_apply_tableaux(a); break;
4453 #endif
4454 default:
4455 erg += printobjectkind(a);
4456 erg += print_type(k);
4457 erg += error("cast_apply:can not cast from first kind into second kind");
4458 }
4459 cae:
4460 ENDR("cast_apply");
4461 }
4462
select_i(a,b)4463 OP select_i(a,b) OP a,b;
4464 /* AK 180294 */
4465 {
4466 INT erg = OK;
4467 CTO(INTEGER,"select_i",b);
4468 switch(S_O_K(a)) {
4469 case INTEGERVECTOR:
4470 case VECTOR: return s_v_i(a,S_I_I(b));
4471 case PERMUTATION: return s_p_i(a,S_I_I(b));
4472 case PARTITION: return s_pa_i(a,S_I_I(b));
4473 }
4474 WTO("select_i",a);
4475 ENDO("select_i");
4476 }
4477
4478
4479
4480 /*
4481 Additionne 2 polynomes de Laurent.
4482 La composante 0 de vc1 est plus grande que la composante 0 de vc2
4483 */
4484
q_add_ord(vc1,vc2,res)4485 static INT q_add_ord(vc1,vc2,res) OP vc1,vc2,res;
4486 {
4487 INT delta,lg_vc1,lg_vc2,i;
4488
4489 lg_vc1=S_LA_LI(vc1);
4490 lg_vc2=S_LA_LI(vc2);
4491 delta=S_LA_II(vc1,0L)-S_LA_II(vc2,0L);
4492 if(lg_vc2>=lg_vc1+delta)
4493 m_il_nla(lg_vc2,res);
4494 else
4495 m_il_nla(lg_vc1+delta,res);
4496 M_I_I(S_LA_II(vc2,0L),S_LA_I(res,0L));
4497
4498 for(i=1L;i<lg_vc2;i++)
4499 M_I_I(S_LA_II(vc2,i),S_LA_I(res,i));
4500 for(i=1L;i<lg_vc1;i++)
4501 M_I_I(S_LA_II(res,i+delta)+S_LA_II(vc1,i),S_LA_I(res,i+delta));
4502 return OK;
4503 }
4504
4505 /*
4506 Additionne 2 polynomes de Laurent
4507 */
4508
add_laurent(vc1,vc2,res)4509 INT add_laurent(vc1,vc2,res) OP vc1,vc2,res;
4510 {
4511 INT erg = OK;
4512 CTO(LAURENT,"add_laurent(1)",vc1);
4513
4514 if (S_O_K(vc2) == INTEGER)
4515 {
4516 OP c = callocobject();
4517 t_INTEGER_LAURENT(vc2,c);
4518 add_laurent(vc1,c,res);
4519 freeall(c);
4520 return OK;
4521 }
4522 else if (S_O_K(vc2) != LAURENT)
4523 {
4524 WTO("add_laurent",vc2);
4525 goto endr_ende;
4526 }
4527
4528 if(S_LA_II(vc1,0L)<S_LA_II(vc2,0L))
4529 q_add_ord(vc2,vc1,res);
4530 else
4531 q_add_ord(vc1,vc2,res);
4532 return OK;
4533 ENDR("add_laurent");
4534 }
4535
4536
add_apply_laurent(a,b)4537 INT add_apply_laurent(a,b) OP a,b;
4538 {
4539 OP c;
4540 INT erg = OK;
4541 CTO(LAURENT,"add_apply_laurent(1)",a);
4542 c=callocobject();
4543 erg += add_laurent(a,b,c);
4544 erg += freeself(b);
4545 c_o_s(b,S_O_S(c));
4546 C_O_K(c,EMPTY);
4547 erg += freeall(c);
4548 ENDR("add_apply_laurent");
4549 }
4550
4551 /*
4552 Produit de 2 polynomes de Laurent
4553 */
4554
mult_laurent(vc1,vc2,res)4555 INT mult_laurent(vc1,vc2,res) OP vc1,vc2,res;
4556 {
4557 INT lg_vc1,lg_vc2,i,j;
4558 INT erg = OK;
4559
4560 if (S_O_K(vc2) == INTEGER)
4561 {
4562 OP c = callocobject();
4563 t_INTEGER_LAURENT(vc2,c);
4564 mult_laurent(vc1,c,res);
4565 freeall(c);
4566 return OK;
4567 }
4568 else if (S_O_K(vc2) == BRUCH)
4569 {
4570 copy(vc2,res);
4571 mult(vc1,S_B_O(vc2),S_B_O(res));
4572 kuerzen(res);
4573 return OK;
4574 }
4575 else if (S_O_K(vc2) != LAURENT)
4576 {
4577 WTO("mult_laurent",vc2);
4578 goto endr_ende;
4579 }
4580 lg_vc1=S_LA_LI(vc1);
4581 lg_vc2=S_LA_LI(vc2);
4582 m_il_nla(lg_vc1+lg_vc2-2L,res);
4583 M_I_I(S_LA_II(vc1,0L)+S_LA_II(vc2,0L),S_LA_I(res,0L));
4584 for(i=1L;i<lg_vc1;i++)
4585 if(S_LA_II(vc1,i)!=0L)
4586 for(j=i;j<i+lg_vc2-1L;j++)
4587 M_I_I(S_LA_II(res,j)+(S_LA_II(vc1,i)*S_LA_II(vc2,j-i+1L)),S_LA_I(res,j));
4588 return(OK);
4589 ENDR("mult_laurent");
4590 }
4591
4592 /*
4593 Normalise the Laurent's polynom:
4594 For example [2, 0, 0, 3, 4, 0, 7] becomes [4, 3, 4]
4595 returns 0 if the polynom is null, 1 if not
4596 */
normal_laurent(vc)4597 INT normal_laurent(vc) OP vc;
4598 {
4599 /* CC 290396 */
4600 /*Normalise Laurent polynom. For example, [2,0,0,3,5] becomes [4,3,5]*/
4601
4602 INT tp,tmp,lg_vc,i,lg_w;
4603 OP w;
4604 INT erg = OK;
4605
4606 tp=0L;
4607 lg_vc= S_LA_LI(vc);
4608 for(i=1L;i<lg_vc;i++)
4609 {
4610 if(S_LA_II(vc,i)!=0L) break;
4611 else tp++;
4612 }
4613 if(i>=lg_vc)
4614 {
4615 erg += m_il_nla(2L,vc);
4616 goto endr_ende;
4617 }
4618 tmp=0L;
4619 for(i=lg_vc-1L;i>0L;i--)
4620 {
4621 if(S_LA_II(vc,i)!=0L) break;
4622 else tmp++;
4623 }
4624 w=callocobject();
4625 lg_w=lg_vc-tmp-tp;
4626 erg += m_il_la(lg_w,w);
4627 M_I_I(S_LA_II(vc,0L)+tp,S_LA_I(w,0L));
4628 for(i=1L;i<lg_w;i++)
4629 M_I_I(S_LA_II(vc,i+tp),S_LA_I(w,i));
4630 erg += freeself(vc);
4631 *vc = *w;
4632 C_O_K(w,EMPTY); /* AK 300197 */
4633 freeall(w);
4634 ENDR("normal_laurent");
4635 }
4636
4637
scan_laurent(ergebnis)4638 INT scan_laurent(ergebnis) OP ergebnis;
4639 {
4640 /* CC 010496 */
4641 INT l,erg=OK;
4642 INT i;
4643 erg += printeingabe("length of vector ");
4644 scanf( "%" SCNINT ,&l);
4645 if(l<2L)
4646 {
4647 erg+= m_il_nla(2L,ergebnis);
4648 return OK;
4649 }
4650 erg+=m_il_la(l,ergebnis);
4651 for(i=0L;i<l;erg += scan(INTEGER,S_V_I(ergebnis,i++)));
4652 return OK;
4653 }
4654
4655
t_LAURENT_OBJ(vc,mp)4656 INT t_LAURENT_OBJ(vc,mp) OP vc,mp;
4657 {
4658 /*CC 290496*/
4659 /*
4660 transforms an object vc of type LAURENT into an object mp of type MONOPOLY
4661 or into a BRUCH or into an INTEGER
4662 */
4663 OP oben,unten,mn,sf;
4664 INT erg = OK;
4665 INT i;
4666
4667 CTO(LAURENT,"t_LAURENT_OBJ",vc);
4668
4669 erg += normal_laurent(vc);
4670 if(S_LA_LI(vc)==2L&&S_LA_II(vc,0L)==0L)
4671 {
4672 erg += m_i_i(S_LA_II(vc,1L),mp);
4673 goto endr_ende;
4674 }
4675 sf=callocobject();
4676 if(S_LA_II(vc,0L)>=0L)
4677 {
4678 erg += init(MONOPOLY,mp);
4679 for(i=1L;i<S_LA_LI(vc);i++)
4680 {
4681 if(S_LA_II(vc,i)!=0L)
4682 {
4683 mn=callocobject();
4684 M_I_I(S_LA_II(vc,0L)+i-1L,sf);
4685 erg += m_sk_mo(sf,S_LA_I(vc,i),mn);
4686 insert(mn,mp,add_koeff,NULL);
4687 }
4688 }
4689 }
4690 else
4691 {
4692 unten=callocobject();
4693 init(MONOPOLY,unten);
4694 M_I_I(-S_LA_II(vc,0L),sf);
4695 mn=callocobject();
4696 erg += m_sk_mo(sf,cons_eins,mn);
4697 insert(mn,unten,add_koeff,NULL);
4698 oben=callocobject();
4699 if(S_LA_LI(vc)==2L)
4700 M_I_I(S_LA_II(vc,1L),oben);
4701 else
4702 {
4703 erg += init(MONOPOLY,oben);
4704 M_I_I(0L,sf);
4705 for(i=1L;i<S_LA_LI(vc);i++)
4706 {
4707 if(S_LA_II(vc,i)!=0L)
4708 {
4709 mn=callocobject();
4710 erg += m_sk_mo(sf,S_LA_I(vc,i),mn);
4711 insert(mn,oben,add_koeff,NULL);
4712 }
4713 erg += inc(sf);
4714 }
4715 }
4716 erg += b_ou_b(oben,unten,mp);
4717 }
4718 erg += freeall(sf);
4719 ENDR("t_LAURENT_OBJ");
4720 }
4721
4722
4723
t_MONOPOLY_LAURENT(mp,vc)4724 INT t_MONOPOLY_LAURENT(mp,vc) OP mp,vc;
4725 {
4726 /* CC 010496 */
4727 OP dg,z;
4728 INT dgi,deb,lg_vc,tmp;
4729
4730 if(S_O_K(mp)!=MONOPOLY)
4731 return error("t_MONOPOLY_LAURENT: wrong first type");
4732 if(nullp_monopoly(mp))
4733 {
4734 m_il_nla(2L,vc);
4735 return OK;
4736 }
4737 dg=callocobject();
4738 degree_monopoly(mp,dg);
4739 dgi=S_I_I(dg);
4740 deb=S_I_I(S_PO_S(mp));
4741 lg_vc=dgi-deb+2L;
4742 m_il_nla(lg_vc,vc);
4743 M_I_I(deb,S_LA_I(vc,0L));
4744 z=mp;
4745 while(z!=NULL)
4746 {
4747 tmp=S_I_I(S_PO_S(z));
4748 copy(S_PO_K(z),S_LA_I(vc,tmp-deb+1L));
4749 z=S_L_N(z);
4750 }
4751 freeall(dg);return OK;
4752 }
4753
4754
t_POLYNOM_LAURENT(po,vc)4755 INT t_POLYNOM_LAURENT(po,vc) OP po,vc;
4756 {
4757 /*CC 010496*/
4758 OP dg,z;
4759 INT dgi,deb,lg_vc,tmp;
4760 INT erg = OK;
4761
4762 CTO(POLYNOM,"t_POLYNOM_LAURENT",po);
4763
4764
4765 /*CC 30/07/96*/
4766 if(has_one_variable(po)==FALSE)
4767 {
4768 erg += error("t_POLYNOM_LAURENT: the first polynomial has more than pne variable");
4769 goto endr_ende;
4770 }
4771
4772 if(nullp_polynom(po))
4773 {
4774 erg += m_il_nla(2L,vc);
4775 goto endr_ende;
4776 }
4777 dg=callocobject();
4778 erg += degree_polynom(po,dg);
4779 dgi=S_I_I(dg);
4780 deb=S_PO_SII(po,0L);
4781 lg_vc=dgi-deb+2L;
4782 erg += m_il_nla(lg_vc,vc);
4783 M_I_I(deb,S_LA_I(vc,0L));
4784 z=po;
4785 while(z!=NULL)
4786 {
4787 tmp=S_PO_SII(z,0L);
4788 copy(S_PO_K(z),S_LA_I(vc,tmp-deb+1L));
4789 z=S_L_N(z);
4790 }
4791 erg += freeall(dg);
4792 ENDR("t_POLYNOM_LAURENT");
4793 }
4794
t_INTEGER_LAURENT(n,vc)4795 INT t_INTEGER_LAURENT(n,vc) OP n,vc;
4796 {
4797 if((S_O_K(n)!=INTEGER)&&(S_O_K(n)!=LONGINT))
4798 return error("t_INTEGER_LAURENT: first argument not an integer");
4799 m_il_nla(2L,vc);
4800 copy(n,S_LA_I(vc,1L));
4801 return(OK);
4802 }
4803
4804
4805 /*
4806 transforms an object of type MONOPOLY or POLYNOM or INTEGER or
4807 BRUCH into an object of type LAURENT
4808 */
4809
t_OBJ_LAURENT(obj,vc)4810 INT t_OBJ_LAURENT(obj,vc) OP obj,vc;
4811 {
4812 switch(S_O_K(obj))
4813 {
4814 case MONOPOLY:
4815 return t_MONOPOLY_LAURENT(obj,vc);
4816 case POLYNOM:
4817 return t_POLYNOM_LAURENT(obj,vc);
4818 case INTEGER:
4819 return t_INTEGER_LAURENT(obj,vc);
4820 case BRUCH:
4821 return t_BRUCH_LAURENT(obj,vc);
4822 default:
4823 return error("t_OBJ_LAURENT: wrong first type"); }
4824 }
4825
invers_laurent(lau,res)4826 INT invers_laurent(lau, res) OP lau,res;
4827 {
4828 INT erg = OK;
4829 CTO(LAURENT,"invers_laurent(1)",lau);
4830 erg += t_LAURENT_OBJ(lau,res);
4831 erg += invers(res,res);
4832 /*
4833 erg += b_ou_b(callocobject(),callocobject(),res);
4834 M_I_I((INT)1,S_B_O(res));
4835 erg += copy(lau,S_B_U(res));
4836 C_B_I(res,GEKUERZT);
4837 */
4838 ENDR("invers_laurent");
4839 }
4840
addinvers_apply_laurent(lau)4841 INT addinvers_apply_laurent(lau) OP lau;
4842 {
4843 INT i;
4844 INT erg = OK;
4845 CTO(LAURENT,"addinvers_apply_laurent(1)",lau);
4846 for (i=1;i<S_LA_LI(lau);i++)
4847 erg += addinvers_apply(S_LA_I(lau,i));
4848 ENDR("addinvers_apply_laurent");
4849 }
4850
t_BRUCH_LAURENT(br,vc)4851 INT t_BRUCH_LAURENT(br,vc) OP br,vc;
4852 /*CC 030196*/
4853 {
4854 OP oo,uu,vc1,v,z,hh,u;
4855 INT i;
4856
4857 krz(br);
4858 if(S_O_K(br) != BRUCH)
4859 return t_OBJ_LAURENT(br,vc);
4860 oo=S_B_O(br); uu=S_B_U(br);
4861 if(S_O_K(uu)==INTEGER || S_O_K(uu)==LONGINT)
4862 {
4863 vc1=callocobject();
4864 t_OBJ_LAURENT(oo,vc);
4865 copy(vc,vc1);
4866 for(i=1L;i<S_LA_LI(vc);i++)
4867 div(S_LA_I(vc1,i),uu,S_LA_I(vc,i));
4868 freeall(vc1); return OK;
4869 }
4870 if(S_O_K(uu)==POLYNOM)
4871 {
4872 if(has_one_variable(uu)==FALSE) return FALSE;
4873 u=callocobject(); init(MONOPOLY,u);
4874 z=uu;
4875 while(z!=NULL)
4876 {
4877 hh=callocobject();
4878 m_sk_mo(S_V_I(S_PO_S(z),0L),S_PO_K(z),hh);
4879 insert(hh,u,add_koeff,NULL);
4880 z=S_PO_N(z);
4881 }
4882 copy(u,uu); freeall(u);
4883 }
4884 if(S_O_K(uu)== MONOPOLY)
4885 {
4886 v=callocobject();
4887 t_MONOPOLY_LAURENT(uu,v);
4888 if(S_LA_LI(v) >2L)
4889 {
4890 freeall(v);
4891 return error("t_BRUCH_LAURENT: don't succeed in converting into Laurent polynomial");
4892 }
4893 t_OBJ_LAURENT(oo,vc);
4894 vc1=callocobject();
4895 copy(vc,vc1);
4896 sub(S_LA_I(vc1,0L),S_LA_I(v,0L),S_LA_I(vc,0L));
4897 for(i=1L;i<S_LA_LI(vc);i++)
4898 div(S_LA_I(vc1,i),S_LA_I(v,1L),S_LA_I(vc,i));
4899 freeall(vc1);
4900 freeall(v);
4901 return OK;
4902 }
4903 return OK;
4904 }
4905
4906
4907
4908
unrank_subset(b,c,d)4909 INT unrank_subset(b,c,d) OP b,c,d;
4910 /* AK 241006 V3.1 */
4911 {
4912 INT k = S_I_I(b);
4913 INT i;
4914 INT erg = OK;
4915 OP p ,oi,h,r;
4916
4917 CE3(b,c,d,unrank_subset);
4918
4919 CALLOCOBJECT4(p,oi,h,r);
4920 erg += copy(c,r);
4921 erg += m_l_v(b,d);
4922 for (i=k;i>=1;i--)
4923 {
4924 erg += m_i_i(i-1,p);
4925 erg += m_i_i(i,oi);
4926 do {
4927 erg += inc(p);
4928 erg += binom(p,oi,h);
4929 } while (ge(r,h));
4930 erg += dec(p);
4931 erg += binom(p,oi,h);
4932 erg += sub(r,h,r);
4933 erg += m_i_i(S_I_I(p)+1,S_V_I(d,i-1));
4934 }
4935
4936 FREEALL4(p,oi,h,r);
4937 ENDR("unrank_subset");
4938 }
4939
4940
unrank_k_subset(OP number,OP n,OP k,OP set)4941 INT unrank_k_subset(OP number, OP n, OP k, OP set)
4942 /* die menge ist k-teilmenge von 1...n */
4943 /* sortierung ist lexikographisch */
4944 /* AK 241006 V3.1 */
4945 {
4946 INT erg =OK;
4947 OP h,b;
4948 INT i;
4949 // printf("number= "); print(number); printf(" n = ");print(n); printf(" k= ");println(k);
4950
4951 if (S_O_K(set)!= VECTOR) m_l_v(k,set);
4952 else if (S_V_LI(set)!= S_I_I(k)) m_l_v(k,set);
4953
4954 if (S_I_I(k)==S_I_I(n)) {
4955 for(i=0;i<S_V_LI(set);i++) M_I_I(i+1,S_V_I(set,i));
4956 }
4957 else if (S_I_I(k)==1) { M_I_I(S_I_I(number)+1, S_V_I(set,0)); }
4958 else if (S_I_I(n)==1) { M_I_I(1, S_V_I(set,0)); }
4959 else
4960 {
4961 /* das erste element ist 1 falls number < (n-1 over k-1) */
4962 CALLOCOBJECT2(h,b);
4963 DEC_INTEGER(k);DEC_INTEGER(n);
4964 if (S_I_I(n) <BINOMLIMIT)
4965 binom_small(n,k,b);
4966 else
4967 binom(n,k,b);
4968 INC_INTEGER(n); INC_INTEGER(k);
4969 // printf("binom = ");println(b);
4970 if (LT(number,b)) {
4971 DEC_INTEGER(n);DEC_INTEGER(k);
4972 unrank_k_subset(number,n,k,h);
4973 INC_INTEGER(n);INC_INTEGER(k);
4974 M_I_I(1,S_V_I(set,0));
4975 for(i=0;i<S_V_LI(h);i++)
4976 M_I_I(S_V_II(h,i)+1, S_V_I(set,i+1));
4977 }
4978 else {
4979 DEC_INTEGER(n);
4980 sub(number,b,h);
4981 unrank_k_subset(h,n,k,set);
4982 INC_INTEGER(n);
4983 for(i=0;i<S_V_LI(set);i++)
4984 INC_INTEGER(S_V_I(set,i));
4985 }
4986 FREEALL2(h,b);
4987 // println(set);
4988 }
4989 ENDR("unrank_k_subset");
4990 }
4991
rank_k_subset(OP set,OP n,OP number)4992 INT rank_k_subset(OP set, OP n, OP number)
4993 /* AK 241006 V3.1 */
4994 {
4995 INT erg = OK;
4996 CTTO(VECTOR,INTEGERVECTOR,"rank_k_subset(1)",set);
4997 CTO(INTEGER,"rank_k_subset(2)",n);
4998 {
4999 INT i;
5000 if (S_I_I(n)==1) M_I_I(0,number);
5001 else if (S_V_LI(set)==1) M_I_I(S_V_II(set,0)-1, number);
5002 else {
5003 OP h = CALLOCOBJECT();
5004 if (S_V_II(set,0) == 1) {
5005 OP sp=S_V_S(set);
5006 DEC_INTEGER(n);
5007 DEC_INTEGER(S_V_L(set));
5008 C_V_S(set,sp+1);
5009 for (i=0;i<S_V_LI(set);i++) DEC_INTEGER(S_V_I(set,i));
5010 rank_k_subset(set,n,number);
5011 for (i=0;i<S_V_LI(set);i++) INC_INTEGER(S_V_I(set,i));
5012 C_V_S(set,sp);
5013 INC_INTEGER(S_V_L(set));
5014 INC_INTEGER(n);
5015 }
5016 else {
5017 DEC_INTEGER(n);DEC_INTEGER(S_V_L(set));
5018 if (S_I_I(n) <BINOMLIMIT)
5019 binom_small(n,S_V_L(set),h);
5020 else
5021 binom(n,S_V_L(set),h);
5022 INC_INTEGER(S_V_L(set));
5023 for (i=0;i<S_V_LI(set);i++) DEC_INTEGER(S_V_I(set,i));
5024 rank_k_subset(set,n,number);
5025 for (i=0;i<S_V_LI(set);i++) INC_INTEGER(S_V_I(set,i));
5026 INC_INTEGER(n);
5027 ADD_APPLY(h,number);
5028 }
5029 FREEALL(h);
5030 }
5031 }
5032 CTTO(INTEGER,LONGINT,"rank_k_subset(3e)",number);
5033 ENDR("rank_k_subset");
5034 }
5035
5036
5037
makevectorofsubsets(a,b,c)5038 INT makevectorofsubsets(a,b,c) OP a,b,c;
5039 /* AK 040204 */
5040 /* b-subsets of a a-set */
5041 {
5042 INT erg = OK;
5043 {
5044 OP d=callocobject();
5045 INT i;
5046 erg += binom(a,b,d); b_l_v(d,c);
5047 first_subset(a,b,S_V_I(c,0));
5048 for (i=0;i<S_V_LI(c)-1;i++) next_subset(S_V_I(c,i),S_V_I(c,i+1));
5049 }
5050 ENDR("makevectorofsubsets");
5051 }
5052
5053
5054
5055 INT words_jn=0;
point(a,b,c)5056 INT point(a,b,c) OP a,b,c;
5057 /* a is a permutation pi
5058 c = pi(b) */
5059 { COPY(S_P_I(a,S_I_I(b)-1),c); }
5060
hashv(OP v)5061 INT hashv(OP v) { INT erg = OK; return HASH(S_V_I(v,0)); ENDR("hashv"); }
eqv(OP a,OP b)5062 INT eqv(OP a,OP b) { INT erg = OK;return EQ(S_V_I(a,0),S_V_I(b,0));ENDR("eqv");}
orbit_words(erz,root,res,f,sv)5063 INT orbit_words(erz,root,res,f,sv) OP erz,root,res; INT (*f)(); OP sv;
5064 { words_jn=1; orbit(erz,root,res,f,sv); words_jn=0; }
5065
5066
5067
5068 static INT orbit_max_size = (INT)-1;
orbit_set_max_size(INT s)5069 INT orbit_set_max_size(INT s)
5070 /* sets a limit on the orbit size */
5071 /* -1 = no limit */
5072 /* AK 080306 V3.0 */
5073 { orbit_max_size=s; return OK; }
5074
orbit(erz,root,res,f,sv)5075 INT orbit(erz,root,res,f,sv) OP erz,root,res; INT (*f)(); OP sv;
5076 /* bahn von root unter den erzeuger = res */
5077 /* gruppen operation ist die funktion f */
5078 /* sv wird vector von schreier erzeugern */
5079 /* res ist die bahn = vector von objecten vom typ wie root */
5080 /* sv kann NULL sein */
5081 /* AK 080306 V3.0 */
5082 {
5083 INT erg =OK;
5084 INT anz=0;
5085 OP cand,z,ares,fop,h,z1;INT i;
5086 OP perm;
5087
5088 if (erz == sv) {
5089 z=CALLOCOBJECT();
5090 COPY(erz,z);
5091 erg += orbit(z,root,res,f,sv);
5092 FREEALL(z);
5093 goto endr_ende;
5094 }
5095
5096 cand=CALLOCOBJECT();
5097
5098 h = CALLOCOBJECT(); init(HASHTABLE,h);
5099
5100
5101 if (sv != NULL) erg += m_il_v(0,sv); /* vector of schreier generators */
5102
5103
5104 init(QUEUE,cand);
5105 z = CALLOCOBJECT(); erg += m_il_v(2,z);
5106 COPY(root,S_V_I(z,0));
5107 if (sv != NULL) {
5108 if (words_jn==0)
5109 erg += eins(S_V_I(erz,0),S_V_I(z,1));
5110 else
5111 erg += m_il_v(0,S_V_I(z,1)); /* empty word at first position */
5112 }
5113
5114 z1=CALLOCOBJECT();
5115 COPY(z,z1);
5116 insert_hashtable(z1,h,NULL,NULL,hashv);
5117 push(z,cand);
5118
5119 z=pop(cand);
5120 while (z!=NULL)
5121 {
5122 for (i=0;i<S_V_LI(erz);i++)
5123 {
5124 INT in;OP z2;
5125 ares = CALLOCOBJECT();
5126 erg += m_il_v(2,ares);
5127 (*f)(S_V_I(erz,i),S_V_I(z,0),S_V_I(ares,0));
5128 z2 = find_hashtable(ares,h,eqv,hashv);
5129 if (z2 == NULL)
5130 {
5131 if (sv != NULL) {
5132 if (words_jn==0)
5133 MULT(S_V_I(erz,i),S_V_I(z,1),S_V_I(ares,1));
5134 else
5135 {
5136 COPY(S_V_I(z,1),S_V_I(ares,1));
5137 INC(S_V_I(ares,1));
5138 M_I_I(i+1,S_V_I(S_V_I(ares,1),S_V_LI(S_V_I(ares,1))-1));
5139 }
5140 }
5141
5142 z1=CALLOCOBJECT();
5143 COPY(ares,z1);
5144 anz++;
5145 insert_hashtable(z1,h,NULL,NULL,hashv);
5146 push(ares,cand);
5147 if ( (orbit_max_size != -1) && (anz > orbit_max_size) )
5148 goto end;
5149 }
5150 else
5151 {
5152 OP perm,inv;
5153 if (sv != NULL) {
5154 CALLOCOBJECT2(perm,inv);
5155 if (words_jn==0) {
5156 MULT(S_V_I(erz,i),S_V_I(z,1),perm);
5157 INVERS(S_V_I(z2,1),inv);
5158 MULT_APPLY(inv,perm);
5159 }
5160 else {
5161 INT ii,jj;
5162 m_il_v(S_V_LI(S_V_I(z,1))+1+S_V_LI(S_V_I(z2,1)),perm);
5163 for (ii=0;ii<S_V_LI(S_V_I(z,1));ii++)
5164 M_I_I(S_V_II(S_V_I(z,1),ii),S_V_I(perm,ii));
5165 M_I_I(i+1,S_V_I(perm,ii));ii++;
5166 for (jj=S_V_LI(S_V_I(z2,1))-1;jj>=0;ii++,jj--)
5167 M_I_I(-S_V_II(S_V_I(z2,1),jj),S_V_I(perm,ii));
5168 }
5169
5170 in = index_vector(perm,sv);
5171 if (in == -1) {
5172 INC(sv);
5173 COPY(perm, S_V_I(sv,S_V_LI(sv)-1));
5174 /* add the new schreier generator */
5175 }
5176 FREEALL2(inv,perm);
5177 }
5178 FREEALL(ares);
5179 }
5180 }
5181 FREEALL(z);
5182 z = pop(cand);
5183 }
5184
5185 end:
5186 erg += m_il_v(WEIGHT_HASHTABLE(h),res);
5187 i=0;
5188 FORALL(z,h,{COPY(S_V_I(z,0),S_V_I(res,i)); i++; });
5189 FREEALL2(h,cand);
5190 ENDR("orbit");
5191 }
5192
5193
5194
5195
5196
5197 static int all_orbits_trace=0;
5198 static INT (*all_orbits_rankf)()=NULL;
all_orbits_set_trace()5199 INT all_orbits_set_trace() { all_orbits_trace=1; }
all_orbits_unset_trace()5200 INT all_orbits_unset_trace() { all_orbits_trace=0; }
5201 INT all_orbits_set_rankf(f) INT (*f)(); { all_orbits_rankf=f; }
all_orbits_unset_rankf()5202 INT all_orbits_unset_rankf() { all_orbits_rankf=NULL; }
5203
all_orbits(X,erz,bahnen,no,f)5204 INT all_orbits(X,erz,bahnen,no,f) OP X,erz,bahnen,no; INT (*f)();
5205 /* berechnet alle bahnen von erz auf der menge X
5206 die menge X wird sortiert
5207 in bahnen steht danach die bahnnr beginnend mit 1
5208 die anzahl der bahnen ist in no
5209 */
5210 {
5211 INT erg = OK;
5212 CTO(VECTOR,"all_orbits(1)",X);
5213 CTO(VECTOR,"all_orbits(2)",erz);
5214 {
5215 INT nextbahn=0; // naechste unverbrauchte element
5216 INT bahnnr=1;
5217 OP c;
5218
5219 // ein test ob identität bei den erzeugern
5220 // das kostet zeit
5221 {
5222 INT i;
5223 for (i=0;i<S_V_LI(erz);i++)
5224 {
5225 if (EINSP(S_V_I(erz,i)))
5226 {
5227 OP cerz=CALLOCOBJECT();
5228 delete_entry_vector(erz,i,cerz);
5229 nni:
5230 for (;i<S_V_LI(cerz);i++)
5231 if (EINSP(S_V_I(cerz,i)))
5232 { delete_entry_vector(cerz,i,cerz);
5233 goto nni;
5234 }
5235 all_orbits(X,cerz,bahnen,no,f);
5236 FREEALL(cerz);
5237 goto endr_ende;
5238 }
5239 }
5240 }
5241
5242
5243 // bei den erzeugern ist keine id dabei
5244 erg += qsort_vector(X);
5245 erg += m_l_nv(S_V_L(X),bahnen);
5246
5247 c = CALLOCOBJECT();
5248 nn:
5249 if (all_orbits_trace) printf("orbit number %d\n",bahnnr);
5250 erg += orbit(erz,S_V_I(X,nextbahn), c, f, NULL);
5251
5252
5253 if (all_orbits_rankf != NULL) // mit rankfunktion suchen in X
5254 {
5255 OP ra = CALLOCOBJECT();
5256 INT rai,j;
5257 for (j=0;j<S_V_LI(c);j++)
5258 {
5259 (*all_orbits_rankf)(S_V_I(c,j),ra);
5260 rai=S_I_I(ra);
5261 /*
5262 if (rai==312)
5263 {
5264 printf("orbit number %d nextbahn %d\n",bahnnr,nextbahn);
5265 println(S_V_I(X,nextbahn));
5266 println(S_V_I(c,j));
5267 }
5268 */
5269 if (S_V_II(bahnen,rai)!= 0) error("all_orbits:rank function error");
5270 /*
5271 if (neq(S_V_I(c,j),S_V_I(X,rai))) {
5272 printf("rai=%d\n",rai);
5273 println(S_V_I(c,j));
5274 println(S_V_I(X,rai));
5275 error("all_orbits:diff elements");
5276 }
5277 */
5278 M_I_I(bahnnr,S_V_I(bahnen,rai));
5279 }
5280 nextbahn=-1;
5281 for (j=0;j<S_V_LI(bahnen);j++)
5282 if (S_V_II(bahnen,j)==0) { nextbahn=j; break; }
5283 FREEALL(ra);
5284 }
5285 else
5286 {
5287 INT j,k=0;
5288 erg += qsort_vector(c);
5289 nextbahn=-1;
5290 for (j=0;j<S_V_LI(c);j++)
5291 {
5292 while ( (S_V_II(bahnen,k) > 0) // dies sind elemente zu anderen bahnen AK290607
5293 ||
5294 (NEQ(S_V_I(c,j),S_V_I(X,k)))
5295 )
5296 {
5297 if (S_V_II(bahnen,k)==0) nextbahn=k;
5298 /* nextbahn next element from X not in known orbit */
5299 k++;
5300 }
5301 M_I_I(bahnnr,S_V_I(bahnen,k));
5302 }
5303 while (k<S_V_LI(X))
5304 {
5305 if (S_V_II(bahnen,k)==0) { nextbahn=k; break; }
5306 k++;
5307 }
5308 }
5309
5310 bahnnr++;
5311 FREESELF(c);
5312 if (nextbahn != -1) goto nn;
5313
5314 FREEALL(c);
5315 if (no != NULL) m_i_i(bahnnr-1,no);
5316 }
5317 CTO(VECTOR,"all_orbits(3-e)",bahnen);
5318 ENDR("all_orbits");
5319 }
5320