FORM v5.0.0-35-g6318119
pattern.c
Go to the documentation of this file.
1
12/* #[ License : */
13/*
14 * Copyright (C) 1984-2026 J.A.M. Vermaseren
15 * When using this file you are requested to refer to the publication
16 * J.A.M.Vermaseren "New features of FORM" math-ph/0010025
17 * This is considered a matter of courtesy as the development was paid
18 * for by FOM the Dutch physics granting agency and we would like to
19 * be able to track its scientific use to convince FOM of its value
20 * for the community.
21 *
22 * This file is part of FORM.
23 *
24 * FORM is free software: you can redistribute it and/or modify it under the
25 * terms of the GNU General Public License as published by the Free Software
26 * Foundation, either version 3 of the License, or (at your option) any later
27 * version.
28 *
29 * FORM is distributed in the hope that it will be useful, but WITHOUT ANY
30 * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
31 * FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
32 * details.
33 *
34 * You should have received a copy of the GNU General Public License along
35 * with FORM. If not, see <http://www.gnu.org/licenses/>.
36 */
37/* #] License : */
38/*
39!!! Notice the change in OnePV in FindAll (7-may-2008 JV).
40
41 #[ Includes : pattern.c
42*/
43
44#include "form3.h"
45
46/*
47 #] Includes :
48 #[ Patterns :
49 #[ Rules :
50
51 There are several rules governing the allowable replacements.
52 1: Multi with anything but symbols or dotproducts reverts
53 to many.
54 2: Each symbol can have only one (wildcard) power, so
55 x^2*x^n? is illegal.
56 3: when a single vector is used it replaces all occurrences
57 of the vector. Therefore q*q(mu) or q*q(mu) cannot occur.
58 Also q*q cannot be done.
59 4: Loose vector elements are replaced with p(mu), dotproducts
60 with p?.q.
61 5: p?.q? is allowed.
62 6: x^n? can revert to n = 0 if there is no power of x.
63 7: x?^n? must match some x. There could be an ambiguity otherwise.
64
65 #] Rules :
66 #[ TestMatch : WORD TestMatch(term,level)
67*/
68
97int TestMatch(PHEAD WORD *term, WORD *level)
98{
99 GETBIDENTITY
100 WORD *ll, *m, *w, *llf, *OldWork, *StartWork, *ww, *mm, *t, *OldTermBuffer = 0;
101 WORD power = 0, i, msign = 0, ll2;
102 int match = 0;
103 int numdollars = 0, protosize, oldallnumrhs;
104 CBUF *C = cbuf+AM.rbufnum, *CC;
105 AT.idallflag = 0;
106 do {
107/*
108 #[ Preliminaries :
109*/
110 ll = C->lhs[*level];
111 if ( *ll == TYPEEXPRESSION ) {
112/*
113 Expressions are not subject to anything.
114*/
115 return(0);
116 }
117 else if ( *ll == TYPEREPEAT ) {
118 *++AN.RepPoint = 0;
119 return(0); /* Will force the next level */
120 }
121 else if ( *ll == TYPEENDREPEAT ) {
122 if ( *AN.RepPoint ) {
123 AN.RepPoint[-1] = 1; /* Mark the higher level as dirty */
124 *AN.RepPoint = 0;
125 *level = ll[2]; /* Level to jump back to */
126 }
127 else {
128 AN.RepPoint--;
129 if ( AN.RepPoint < AT.RepCount ) {
130 MLOCK(ErrorMessageLock);
131 MesPrint("Internal problems with REPEAT count");
132 MUNLOCK(ErrorMessageLock);
133 Terminate(-1);
134 }
135 }
136 return(0); /* Force the next level */
137 }
138 else if ( *ll == TYPEOPERATION ) {
139/*
140 Operations have always their own level.
141*/
142 if ( (*(FG.OperaFind[ll[2]]))(BHEAD term,ll) ) return(-1);
143 else return(0);
144 }
145/*
146 #] Preliminaries :
147*/
148 OldWork = AT.WorkPointer;
149 if ( AT.WorkPointer < term + *term ) AT.WorkPointer = term + *term;
150 ww = AT.WorkPointer;
151/*
152 Here we need to make a copy of the subexpression object because we
153 will be writing the values of the wildcards in it.
154 Originally we copied it into the private version of the compiler buffer
155 that is used for scratch space (ebufnum). This caused errors in the
156 routines like ScanFunctions when the ebufnum Buffer was expanded
157 and inpat was still pointing at the old Buffer. This expansion
158 could be done in AddWild and hence cannot be fixed at > 100 places.
159 The solution is to use AN.patternbuffer (JV 16-mar-2009).
160*/
161 {
162 WORD *ta = ll, *ma;
163 int ja = ta[1];
164/*
165 New code (16-mar-2009) JV
166*/
167 if ( ( ja + 2 ) > AN.patternbuffersize ) {
168 if ( AN.patternbuffer ) M_free(AN.patternbuffer,"AN.patternbuffer");
169 AN.patternbuffersize = 2 * ja + 2;
170 AN.patternbuffer = (WORD *)Malloc1(AN.patternbuffersize * sizeof(WORD),
171 "AN.patternbuffer");
172 }
173 ma = AN.patternbuffer;
174 m = ma + IDHEAD;
175 NCOPY(ma,ta,ja);
176 *ma = 0;
177 }
178 AN.FullProto = m;
179 AN.WildValue = w = m + SUBEXPSIZE;
180 protosize = IDHEAD + m[1];
181 m += m[1];
182 AN.WildStop = m;
183 StartWork = ww;
184 ll2 = ll[2];
185/*
186 #[ Expand dollars :
187*/
188 if ( ( ll[4] & DOLLARFLAG ) != 0 ) { /* We have at least one dollar in the pattern */
189 WORD oldRepPoint = *AN.RepPoint, olddefer = AR.DeferFlag;
190 AR.Eside = LHSIDEX;
191/*
192 Copy into WorkSpace. This means that AN.patternbuffer will be free.
193*/
194 ww = AT.WorkPointer; i = m[0]; mm = m;
195 NCOPY(ww,mm,i);
196 *StartWork += 3;
197 *ww++ = 1; *ww++ = 1; *ww++ = 3;
198 AT.WorkPointer = ww;
199 AR.DeferFlag = 0;
200 NewSort(BHEAD0);
201 if ( Generator(BHEAD StartWork,AR.Cnumlhs) ) {
202 LowerSortLevel();
203 AT.WorkPointer = OldWork;
204 AR.DeferFlag = olddefer;
205 return(-1);
206 }
207 AT.WorkPointer = ww;
208 if ( EndSort(BHEAD ww,0) < 0 ) {}
209 AR.DeferFlag = olddefer;
210 if ( *ww == 0 || *(ww+*ww) != 0 ) {
211 if ( AP.lhdollarerror == 0 ) {
212/*
213 If race condition we just get more error messages
214*/
215 MLOCK(ErrorMessageLock);
216 MesPrint("&LHS must be one term");
217 MUNLOCK(ErrorMessageLock);
218 AP.lhdollarerror = 1;
219 }
220 AT.WorkPointer = OldWork;
221 return(-1);
222 }
223 m = ww; ww = m + *m;
224 if ( m[*m-1] < 0 ) { msign = 1; m[*m-1] = -m[*m-1]; }
225 if ( *ww || m[*m-1] != 3 || m[*m-2] != 1 || m[*m-3] != 1 ) {
226 MLOCK(ErrorMessageLock);
227 MesPrint("Dollar variable develops into an illegal pattern in id-statement");
228 MUNLOCK(ErrorMessageLock);
229 return(-1);
230 }
231 *m -= m[*m-1];
232 if ( ( *m + 1 + protosize ) > AN.patternbuffersize ) {
233 if ( AN.patternbuffer ) M_free(AN.patternbuffer,"AN.patternbuffer");
234 AN.patternbuffersize = 2 * (*m) + 2 + protosize;
235 AN.patternbuffer = (WORD *)Malloc1(AN.patternbuffersize * sizeof(WORD),
236 "AN.patternbuffer");
237 mm = ll; ww = AN.patternbuffer; i = protosize;
238 NCOPY(ww,mm,i);
239 AN.FullProto = AN.patternbuffer + IDHEAD;
240 AN.WildValue = w = AN.FullProto + SUBEXPSIZE;
241 AN.WildStop = AN.patternbuffer + protosize;
242 }
243 mm = AN.patternbuffer + protosize;
244 i = *m;
245 NCOPY(mm,m,i);
246 m = AN.patternbuffer + protosize;
247 AR.Eside = RHSIDE;
248 *mm = 0;
249/*
250 Test the pattern. If only wildcard powers -> SUBONCE
251*/
252 {
253 WORD *mmm = m + *m, *m1 = m+1, jm, noveto = 0;
254 while ( m1 < mmm ) {
255 if ( *m1 == SYMBOL ) {
256 for ( jm = 2; jm < m1[1]; jm+=2 ) {
257 if ( m1[jm+1] < MAXPOWER && m1[jm+1] > -MAXPOWER ) break;
258 }
259 if ( jm < m1[1] ) { noveto = 1; break; }
260 }
261 else if ( *m1 == DOTPRODUCT ) {
262 for ( jm = 2; jm < m1[1]; jm+=3 ) {
263 if ( m1[jm+2] < MAXPOWER && m1[jm+2] > -MAXPOWER ) break;
264 }
265 if ( jm < m1[1] ) { noveto = 1; break; }
266 }
267 else { noveto = 1; break; }
268 m1 += m1[1];
269 }
270 if ( noveto == 0 ) {
271 ll2 = ll2 & ~SUBMASK;
272 ll2 |= SUBONCE;
273 }
274 }
275 AT.WorkPointer = ww = StartWork;
276 *AN.RepPoint = oldRepPoint;
277 }
278/*
279 #] Expand dollars :
280
281 In case of id,all we have to check at this point that there are only
282 functions in the pattern.
283*/
284 if ( ( ll2 & SUBMASK ) == SUBALL ) {
285 WORD *t = AN.patternbuffer+IDHEAD, *tt;
286 WORD *tstop, *ttstop, ii;
287 t += t[1]; tstop = t + *t; t++;
288 while ( t < tstop ) {
289 if ( *t < FUNCTION ) break;
290 t += t[1];
291 }
292 if ( t < tstop ) {
293 MLOCK(ErrorMessageLock);
294 MesPrint("Error: id,all can only be used with (products of) functions and/or tensors.");
295 MUNLOCK(ErrorMessageLock);
296 return(-1);
297 }
298 OldTermBuffer = AN.termbuffer;
299 AN.termbuffer = TermMalloc("id,all");
300/*
301 Now make sure that only regular functions and tensors can take part.
302*/
303 tt = term; ttstop = tt+*tt; ttstop -= ABS(ttstop[-1]); tt++;
304 t = AN.termbuffer+1;
305 while ( tt < ttstop ) {
306 if ( *tt >= FUNCTION && *tt != AR.PolyFun && *tt != AR.PolyFunInv ) {
307 ii = tt[1]; NCOPY(t,tt,ii);
308 }
309 else tt += tt[1];
310 }
311 *t++ = 1; *t++ = 1; *t++ = 3; AN.termbuffer[0] = t-AN.termbuffer;
312 }
313/*
314 To be puristic, we need to check that all wildcards in the prototype
315 are actually present. If the LHS contained a replace_ this may not be
316 the case.
317*/
318 ClearWild(BHEAD0);
319 while ( w < AN.WildStop ) {
320 if ( *w == LOADDOLLAR ) numdollars++;
321 w += w[1];
322 }
323 AN.RepFunNum = 0;
324 /* rep = */ AN.RepFunList = AT.WorkPointer;
325 AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer/2);
326 if ( AT.WorkPointer >= AT.WorkTop ) {
327 MLOCK(ErrorMessageLock);
328 MesWork();
329 MUNLOCK(ErrorMessageLock);
330 return(-1);
331 }
332 AN.DisOrderFlag = ll2 & SUBDISORDER;
333 AN.nogroundlevel = 0;
334 switch ( ll2 & SUBMASK ) {
335 case SUBONLY :
336 /* Must be an exact match */
337 AN.UseFindOnly = 1; AN.ForFindOnly = 0;
338 if ( FindRest(BHEAD term,m) && ( AN.UsedOtherFind ||
339 FindOnly(BHEAD term,m) ) ) {
340 power = 1;
341 if ( msign ) term[term[0]-1] = -term[term[0]-1];
342 }
343 else power = 0;
344 break;
345 case SUBMANY :
346 AN.UseFindOnly = -1;
347 if ( ( power = FindRest(BHEAD term,m) ) > 0 ) {
348 if ( ( power = FindOnce(BHEAD term,m) ) > 0 ) {
349 AN.UseFindOnly = 0;
350 do {
351 if ( msign ) term[term[0]-1] = -term[term[0]-1];
352 Substitute(BHEAD term,m,1);
353 if ( numdollars ) {
354 WildDollars(BHEAD (WORD *)0);
355 numdollars = 0;
356 }
357 if ( ww < term+term[0] ) ww = term+term[0];
358 ClearWild(BHEAD0);
359 AT.WorkPointer = ww;
360/* if ( rep < ww ) {*/
361 AN.RepFunNum = 0;
362 /* rep = */ AN.RepFunList = ww;
363 AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer/2);
364 if ( AT.WorkPointer >= AT.WorkTop ) {
365 MLOCK(ErrorMessageLock);
366 MesWork();
367 MUNLOCK(ErrorMessageLock);
368 return(-1);
369 }
370/*
371 }
372 else {
373 AN.RepFunList = rep;
374 AN.RepFunNum = 0;
375 }
376*/
377 AN.nogroundlevel = 0;
378 } while ( FindRest(BHEAD term,m) && ( AN.UsedOtherFind ||
379 FindOnce(BHEAD term,m) ) );
380 match = 1;
381 }
382 else if ( power < 0 ) {
383 do {
384 if ( msign ) term[term[0]-1] = -term[term[0]-1];
385 Substitute(BHEAD term,m,1);
386 if ( numdollars ) {
387 WildDollars(BHEAD (WORD *)0);
388 numdollars = 0;
389 }
390 if ( ww < term+term[0] ) ww = term+term[0];
391 ClearWild(BHEAD0);
392 AT.WorkPointer = ww;
393/* if ( rep < ww ) { */
394 AN.RepFunNum = 0;
395 /* rep = */ AN.RepFunList = ww;
396 AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer/2);
397 if ( AT.WorkPointer >= AT.WorkTop ) {
398 MLOCK(ErrorMessageLock);
399 MesWork();
400 MUNLOCK(ErrorMessageLock);
401 return(-1);
402 }
403/*
404 }
405 else {
406 AN.RepFunList = rep;
407 AN.RepFunNum = 0;
408 }
409*/
410 } while ( FindRest(BHEAD term,m) );
411 match = 1;
412 }
413 }
414 else if ( power < 0 ) {
415 if ( FindOnce(BHEAD term,m) ) {
416 do {
417 if ( msign ) term[term[0]-1] = -term[term[0]-1];
418 Substitute(BHEAD term,m,1);
419 if ( numdollars ) {
420 WildDollars(BHEAD (WORD *)0);
421 numdollars = 0;
422 }
423 if ( ww < term+term[0] ) ww = term+term[0];
424 ClearWild(BHEAD0);
425 AT.WorkPointer = ww;
426/* if ( rep < ww ) { */
427 AN.RepFunNum = 0;
428 /* rep = */ AN.RepFunList = ww;
429 AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer/2);
430 if ( AT.WorkPointer >= AT.WorkTop ) {
431 MLOCK(ErrorMessageLock);
432 MesWork();
433 MUNLOCK(ErrorMessageLock);
434 return(-1);
435 }
436/*
437 }
438 else {
439 AN.RepFunList = rep;
440 AN.RepFunNum = 0;
441 }
442*/
443 } while ( FindOnce(BHEAD term,m) );
444 match = 1;
445 }
446 }
447 if ( match ) {
448 if ( ( ll2 & SUBAFTER ) != 0 ) *level = AC.Labels[ll[3]];
449 }
450 else {
451 if ( ( ll2 & SUBAFTERNOT ) != 0 ) *level = AC.Labels[ll[3]];
452 }
453 goto nextlevel;
454 case SUBONCE :
455 AN.UseFindOnly = 0;
456 if ( FindRest(BHEAD term,m) && ( AN.UsedOtherFind || FindOnce(BHEAD term,m) ) ) {
457 power = 1;
458 if ( msign ) term[term[0]-1] = -term[term[0]-1];
459 }
460 else power = 0;
461 break;
462 case SUBMULTI :
463 power = FindMulti(BHEAD term,m);
464 if ( ( power & 1 ) != 0 && msign ) term[term[0]-1] = -term[term[0]-1];
465 break;
466 case SUBVECTOR :
467 while ( ( power = FindAll(BHEAD term,m,*level,(WORD *)0) ) != 0 ) {
468 if ( ( power & 1 ) != 0 && msign ) term[term[0]-1] = -term[term[0]-1];
469 match = 1;
470 }
471 break;
472 case SUBSELECT :
473 llf = ll + IDHEAD; llf += llf[1]; llf += *llf;
474 AN.UseFindOnly = 1; AN.ForFindOnly = llf;
475 if ( FindRest(BHEAD term,m) && ( AN.UsedOtherFind || FindOnly(BHEAD term,m) ) ) {
476 if ( msign ) term[term[0]-1] = -term[term[0]-1];
477/*
478 The following code needs to be hacked a bit to allow for
479 all types of sets and for occurrence anywhere in the term
480 The code at the end of FindOnly is a bit mysterious.
481*/
482 if ( llf[1] > 2 ) {
483 WORD *t1, *t2;
484 if ( *term > AN.sizeselecttermundo ) {
485 if ( AN.selecttermundo ) M_free(AN.selecttermundo,"AN.selecttermundo");
486 AN.sizeselecttermundo = *term +10;
487 AN.selecttermundo = (WORD *)Malloc1(
488 AN.sizeselecttermundo*sizeof(WORD),"AN.selecttermundo");
489 }
490 t1 = term; t2 = AN.selecttermundo; i = *term;
491 NCOPY(t2,t1,i);
492 }
493 power = 1;
494 Substitute(BHEAD term,m,power);
495 if ( llf[1] > 2 ) {
496 if ( TestSelect(term,llf) ) {
497 WORD *t1, *t2;
498 power = 0;
499 t1 = term; t2 = AN.selecttermundo; i = *t2;
500 NCOPY(t1,t2,i);
501#if IDHEAD > 3
502 if ( ( ll2 & SUBAFTERNOT ) != 0 ) {
503 *level = AC.Labels[ll[3]];
504 }
505#endif
506 goto nextlevel;
507 }
508 }
509 if ( numdollars ) {
510 WildDollars(BHEAD (WORD *)0);
511 numdollars = 0;
512 }
513 match = 1;
514 if ( ( ll2 & SUBAFTER ) != 0 ) {
515 *level = AC.Labels[ll[3]];
516 }
517 }
518 else {
519 if ( ( ll2 & SUBAFTERNOT ) != 0 ) {
520 *level = AC.Labels[ll[3]];
521 }
522 power = 0;
523 }
524 goto nextlevel;
525 case SUBALL:
526 AN.UseFindOnly = 0;
527 CC = cbuf+AT.allbufnum;
528 oldallnumrhs = CC->numrhs;
529 t = AddRHS(AT.allbufnum,1);
530 *t = 0;
531 AT.idallflag = 1;
532 AT.idallmaxnum = ll[5];
533 AT.idallnum = 0;
534 if ( FindRest(BHEAD AN.termbuffer,m) || AT.idallflag > 1 ) {
535 WORD *t, *tstop, *tt, first = 1, ii;
536 power = 1;
537 *CC->Pointer++ = 0;
538 if ( msign ) term[term[0]-1] = -term[term[0]-1];
539/*
540 If we come here the matches are all already in the
541 compiler buffer. All we need to do is take out all
542 functions and replace them by a SUBEXPRESSION that
543 points to this buffer.
544 Note: the PolyFun/PolyRatFun should be excluded from this.
545 This works because each match writes incrementally to
546 the buffer using the routine SubsInAll.
547
548 The call to WildDollars should be made in Generator.....
549*/
550 t = term; tstop = t + *t; ii = ABS(tstop[-1]); tstop -= ii;
551 tt = AT.WorkPointer+1;
552 t++;
553 while ( t < tstop ) {
554 if ( *t >= FUNCTION && *t != AR.PolyFun && *t != AR.PolyFunInv ) {
555 if ( first ) { /* SUBEXPRESSION */
556 *tt++ = SUBEXPRESSION;
557 *tt++ = SUBEXPSIZE;
558 *tt++ = CC->numrhs;
559 *tt++ = 1;
560 *tt++ = AT.allbufnum;
561 FILLSUB(tt)
562 first = 0;
563 }
564 t += t[1];
565 }
566 else {
567 i = t[1]; NCOPY(tt,t,i);
568 }
569 }
570 if ( ( ll[4] & NORMALIZEFLAG ) != 0 ) {
571/*
572 In case of the normalization option, we have to divide
573 by AT.idallnum;
574*/
575 WORD na = t[ii-1];
576 na = REDLENG(na);
577 for ( i = 0; i < ii; i++ ) tt[i] = t[i];
578 Divvy(BHEAD (UWORD *)tt,&na,(UWORD *)(&(AT.idallnum)),1);
579 na = INCLENG(na);
580 ii = ABS(na);
581 tt[ii-1] = na;
582 tt += ii;
583 }
584 else {
585 NCOPY(tt,t,ii);
586 }
587 ii = tt-AT.WorkPointer;
588 *(AT.WorkPointer) = ii;
589 tt = AT.WorkPointer; t = term;
590 NCOPY(t,tt,ii);
591
592 if ( ( ll2 & SUBAFTER ) != 0 ) { /* ifmatch -> */
593 *level = AC.Labels[ll[3]];
594 }
595 TermFree(AN.termbuffer,"id,all");
596 AN.termbuffer = OldTermBuffer;
597 AT.WorkPointer = AN.RepFunList;
598 AT.idallflag = 0;
599 CC->Pointer[0] = 0;
600 TransferBuffer(AT.aebufnum,AT.ebufnum,AT.allbufnum);
601 return(1);
602 }
603 AT.idallflag = 0;
604 power = 0;
605 CC->numrhs = oldallnumrhs;
606 TermFree(AN.termbuffer,"id,all");
607 AN.termbuffer = OldTermBuffer;
608 break;
609 default :
610 break;
611 }
612 if ( power ) {
613 Substitute(BHEAD term,m,power);
614 if ( numdollars ) {
615 WildDollars(BHEAD (WORD *)0);
616 numdollars = 0;
617 }
618 match = 1;
619 if ( ( ll2 & SUBAFTER ) != 0 ) { /* ifmatch -> */
620 *level = AC.Labels[ll[3]];
621 }
622 }
623 else {
624 AT.WorkPointer = AN.RepFunList;
625 if ( ( ll2 & SUBAFTERNOT ) != 0 ) { /* ifnomatch -> */
626 *level = AC.Labels[ll[3]];
627 }
628 }
629nextlevel:;
630 } while ( (*level)++ < AR.Cnumlhs && C->lhs[*level][0] == TYPEIDOLD );
631 (*level)--;
632 AT.WorkPointer = AN.RepFunList;
633 return(match);
634}
635
636/*
637 #] TestMatch :
638 #[ Substitute : void Substitute(term,pattern,power)
639*/
640
641void Substitute(PHEAD WORD *term, WORD *pattern, WORD power)
642{
643 GETBIDENTITY
644 WORD *TemTerm;
645 WORD *t, *m;
646 WORD *tstop, *mstop;
647 WORD *xstop, *ystop;
648 WORD nt, *fill, nq, mt;
649 WORD *q, *subterm, *tcoef, oldval1 = 0, newval3, i = 0;
650 WORD PutExpr = 0, sign = 0;
651 TemTerm = AT.WorkPointer;
652 if ( ( (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer*2) ) > AT.WorkTop ) {
653 MLOCK(ErrorMessageLock);
654 MesWork();
655 MUNLOCK(ErrorMessageLock);
656 Terminate(-1);
657 }
658 m = pattern;
659 mstop = m + *m;
660 m++;
661 t = term;
662 t += *term - 1;
663 tcoef = t;
664 tstop = t - ABS(*t) + 1;
665 t = term;
666 t++;
667 fill = TemTerm;
668 fill++;
669 if ( m < mstop ) { do {
670/*
671 #[ SYMBOLS :
672*/
673 if ( *m == SYMBOL ) {
674 ystop = m + m[1];
675 m += 2;
676 while ( *t != SYMBOL && t < tstop ) {
677 nq = t[1];
678 NCOPY(fill,t,nq);
679 }
680 if ( t >= tstop ) goto SubCoef;
681 *fill++ = SYMBOL;
682 fill++;
683 subterm = fill;
684 xstop = t + t[1];
685 t += 2;
686 do {
687 if ( *m == *t && t < xstop ) {
688 nt = t[1];
689 mt = m[1];
690 if ( mt >= 2*MAXPOWER ) {
691 if ( CheckWild(BHEAD mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
692 nt -= AN.oldvalue;
693 goto SubsL1;
694 }
695 }
696 else if ( mt <= -2*MAXPOWER ) {
697 if ( CheckWild(BHEAD -mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
698 nt += AN.oldvalue;
699 goto SubsL1;
700 }
701 }
702 else {
703 nt -= mt * power;
704SubsL1: if ( nt ) {
705 *fill++ = *t;
706 *fill++ = nt;
707 }
708 }
709 m += 2; t+= 2;
710 }
711 else if ( *m >= 2*MAXPOWER ) {
712 while ( t < xstop ) { *fill++ = *t++; *fill++ = *t++; }
713 nq = WORDDIF(fill,subterm);
714 fill = subterm;
715 while ( nq > 0 ) {
716 if ( !CheckWild(BHEAD *m-2*MAXPOWER,SYMTOSYM,*fill,&newval3) ) {
717 mt = m[1];
718 if ( mt >= 2*MAXPOWER ) {
719 if ( CheckWild(BHEAD mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
720 if ( fill[1] -= AN.oldvalue ) goto SubsL2;
721 }
722 }
723 else if ( mt <= -2*MAXPOWER ) {
724 if ( CheckWild(BHEAD -mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
725 if ( fill[1] += AN.oldvalue ) goto SubsL2;
726 }
727 }
728 else {
729 if ( fill[1] -= mt * power ) {
730SubsL2: fill += nq;
731 nq = 0;
732 }
733 }
734 break;
735 }
736 nq -= 2;
737 fill += 2;
738 }
739 if ( nq ) {
740 nq -= 2;
741 q = fill + 2;
742 while ( --nq >= 0 ) *fill++ = *q++;
743 }
744 m += 2;
745 }
746 else if ( *m < *t || t >= xstop ) { m += 2; }
747 else { *fill++ = *t++; *fill++ = *t++; }
748 } while ( m < ystop );
749 while ( t < xstop ) *fill++ = *t++;
750 nq = WORDDIF(fill,subterm);
751 if ( nq > 0 ) {
752 nq += 2;
753 subterm[-1] = nq;
754 }
755 else { fill = subterm; fill -= 2; }
756 }
757/*
758 #] SYMBOLS :
759 #[ DOTPRODUCTS :
760*/
761 else if ( *m == DOTPRODUCT ) {
762 ystop = m + m[1];
763 m += 2;
764 while ( *t > DOTPRODUCT && t < tstop ) {
765 nq = t[1];
766 NCOPY(fill,t,nq);
767 }
768 if ( t >= tstop ) goto SubCoef;
769 if ( *t != DOTPRODUCT ) {
770 m = ystop;
771 goto EndLoop;
772 }
773 *fill++ = DOTPRODUCT;
774 fill++;
775 subterm = fill;
776 xstop = t + t[1];
777 t += 2;
778 do {
779 if ( *m == *t && m[1] == t[1] && t < xstop ) {
780 nt = t[2];
781 mt = m[2];
782 if ( mt >= 2*MAXPOWER ) {
783 if ( CheckWild(BHEAD mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
784 nt -= AN.oldvalue;
785 goto SubsL3;
786 }
787 }
788 else if ( mt <= -2*MAXPOWER ) {
789 if ( CheckWild(BHEAD -mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
790 nt += AN.oldvalue;
791 goto SubsL3;
792 }
793 }
794 else {
795 nt -= mt * power;
796SubsL3: if ( nt ) {
797 *fill++ = *t++;
798 *fill++ = *t;
799 *fill++ = nt;
800 t += 2;
801 }
802 else t += 3;
803 }
804 m += 3;
805 }
806 else if ( *m >= (AM.OffsetVector+WILDOFFSET) ) {
807 while ( t < xstop ) {
808 *fill++ = *t++; *fill++ = *t++; *fill++ = *t++;
809 }
810 oldval1 = 1;
811 goto SubsL4;
812 }
813 else if ( m[1] >= (AM.OffsetVector+WILDOFFSET) ) {
814 while ( *m >= *t && t < xstop ) {
815 *fill++ = *t++; *fill++ = *t++; *fill++ = *t++;
816 }
817 oldval1 = 0;
818SubsL4: nq = WORDDIF(fill,subterm);
819 fill = subterm;
820 while ( nq > 0 ) {
821 if ( ( oldval1 && ( (
822 !CheckWild(BHEAD *m-WILDOFFSET,VECTOVEC,*fill,&newval3)
823 && !CheckWild(BHEAD m[1]-WILDOFFSET,VECTOVEC,fill[1],&newval3)
824 ) || (
825 !CheckWild(BHEAD m[1]-WILDOFFSET,VECTOVEC,*fill,&newval3)
826 && !CheckWild(BHEAD *m-WILDOFFSET,VECTOVEC,fill[1],&newval3)
827 ) ) ) || ( !oldval1 && ( (
828 *m == *fill
829 && !CheckWild(BHEAD m[1]-WILDOFFSET,VECTOVEC,fill[1],&newval3)
830 ) || (
831 !CheckWild(BHEAD m[1]-WILDOFFSET,VECTOVEC,*fill,&newval3)
832 && *m == fill[1] ) ) ) ) {
833 mt = m[2];
834 if ( mt >= 2*MAXPOWER ) {
835 if ( CheckWild(BHEAD mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
836 if ( fill[2] -= AN.oldvalue )
837 goto SubsL5;
838 }
839 }
840 else if ( mt <= -2*MAXPOWER ) {
841 if ( CheckWild(BHEAD -mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
842 if ( fill[2] += AN.oldvalue )
843 goto SubsL5;
844 }
845 }
846 else {
847 if ( fill[2] -= mt * power ) {
848SubsL5: fill += nq;
849 nq = 0;
850 }
851 }
852 m += 3;
853 break;
854 }
855 fill += 3; nq -= 3;
856 }
857 if ( nq ) {
858 nq -= 3;
859 q = fill + 3;
860 while ( --nq >= 0 ) *fill++ = *q++;
861 }
862 }
863 else if ( t >= xstop || *m < *t || ( *m == *t && m[1] < t[1] ) )
864 { m += 3; }
865 else {
866 *fill++ = *t++; *fill++ = *t++; *fill++ = *t++;
867 }
868 } while ( m < ystop );
869 while ( t < xstop ) *fill++ = *t++;
870 nq = WORDDIF(fill,subterm);
871 if ( nq > 0 ) {
872 nq += 2;
873 subterm[-1] = nq;
874 }
875 else { fill = subterm; fill -= 2; }
876 }
877/*
878 #] DOTPRODUCTS :
879 #[ FUNCTIONS :
880*/
881 else if ( *m >= FUNCTION ) {
882 while ( *t >= FUNCTION || *t == SUBEXPRESSION ) {
883 nt = WORDDIF(t,term);
884 for ( mt = 0; mt < AN.RepFunNum; mt += 2 ) {
885 if ( nt == AN.RepFunList[mt] ) break;
886 }
887 if ( mt >= AN.RepFunNum ) {
888 nq = t[1];
889 NCOPY(fill,t,nq);
890 }
891 else {
892 WORD *oldt = 0;
893 if ( *m == GAMMA && m[1] != FUNHEAD+1 ) {
894 oldt = t;
895 if ( ( i = AN.RepFunList[mt+1] ) > 0 ) {
896 *fill++ = GAMMA;
897 *fill++ = i + FUNHEAD+1;
898 FILLFUN(fill)
899 nq = i + 1;
900 t += FUNHEAD;
901 NCOPY(fill,t,nq);
902 }
903 t = oldt;
904 }
905 else if ( ( *t == LEVICIVITA ) || ( *t >= FUNCTION
906 && (functions[*t-FUNCTION].symmetric & ~REVERSEORDER) == ANTISYMMETRIC )
907 ) sign += AN.RepFunList[mt+1];
908 else if ( *m >= FUNCTION+WILDOFFSET
909 && (functions[*m-FUNCTION-WILDOFFSET].symmetric & ~REVERSEORDER) == ANTISYMMETRIC
910 ) sign += AN.RepFunList[mt+1];
911 if ( !PutExpr ) {
912 xstop = t + t[1];
913 t = AN.FullProto;
914 nq = t[1];
915 t[3] = power;
916 NCOPY(fill,t,nq);
917 t = xstop;
918 PutExpr = 1;
919 }
920 else t += t[1];
921 if ( *m == GAMMA && m[1] != FUNHEAD+1 ) {
922 i = oldt[1] - m[1] - i;
923 if ( i > 0 ) {
924 *fill++ = GAMMA;
925 *fill++ = i + FUNHEAD+1;
926 FILLFUN(fill)
927 *fill++ = oldt[FUNHEAD];
928 t = t - i;
929 NCOPY(fill,t,i);
930 }
931 }
932 break;
933 }
934 }
935 m += m[1];
936 }
937/*
938 #] FUNCTIONS :
939 #[ VECTORS :
940*/
941 else if ( *m == VECTOR ) {
942 while ( *t > VECTOR ) {
943 nq = t[1];
944 NCOPY(fill,t,nq);
945 }
946 xstop = t + t[1];
947 ystop = m + m[1];
948 t += 2;
949 m += 2;
950 *fill++ = VECTOR;
951 fill++;
952 subterm = fill;
953 do {
954 if ( *m == *t && m[1] == t[1] ) {
955 m += 2; t += 2;
956 }
957 else if ( *m >= (AM.OffsetVector+WILDOFFSET) ) {
958 while ( t < xstop ) *fill++ = *t++;
959 nq = WORDDIF(fill,subterm);
960 fill = subterm;
961 if ( m[1] < (AM.OffsetIndex+WILDOFFSET) ) {
962 do {
963 if ( m[1] == fill[1] &&
964 !CheckWild(BHEAD *m-WILDOFFSET,VECTOVEC,*fill,&newval3) )
965 break;
966 fill += 2;
967 nq -= 2;
968 } while ( nq > 0 );
969 }
970 else { /* Double wildcard */
971 do {
972 if ( !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,fill[1],&newval3)
973 && !CheckWild(BHEAD *m-WILDOFFSET,VECTOVEC,*fill,&newval3) )
974 break;
975 if ( *fill == oldval1 && fill[1] == AN.oldvalue ) break;
976 fill += 2;
977 nq -= 2;
978 } while ( nq > 0 );
979 }
980 nq -= 2;
981 q = fill + 2;
982 if ( nq > 0 ) { NCOPY(fill,q,nq); }
983 m += 2;
984 }
985 else if ( *m <= *t &&
986 m[1] >= (AM.OffsetIndex + WILDOFFSET) ) {
987 while ( *m == *t && t < xstop )
988 { *fill++ = *t++; *fill++ = *t++; }
989 nq = WORDDIF(fill,subterm);
990 fill = subterm;
991 do {
992 if ( *m == *fill &&
993 !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,fill[1],&newval3) )
994 break;
995 nq -= 2;
996 fill += 2;
997 } while ( nq > 0 );
998 nq -= 2;
999 q = fill + 2;
1000 if ( nq > 0 ) { NCOPY(fill,q,nq); }
1001 m += 2;
1002 }
1003 else { *fill++ = *t++; *fill++ = *t++; }
1004 } while ( m < ystop );
1005 while ( t < xstop ) *fill++ = *t++;
1006 nq = WORDDIF(fill,subterm);
1007 if ( nq > 0 ) {
1008 nq += 2;
1009 subterm[-1] = nq;
1010 }
1011 else { fill = subterm; fill -= 2; }
1012 }
1013/*
1014 #] VECTORS :
1015 #[ INDICES :
1016
1017 Currently without wildcards
1018*/
1019 else if ( *m == INDEX ) {
1020 while ( *t > INDEX ) {
1021 nq = t[1];
1022 NCOPY(fill,t,nq);
1023 }
1024 xstop = t + t[1];
1025 ystop = m + m[1];
1026 t += 2;
1027 m += 2;
1028 *fill++ = INDEX;
1029 fill++;
1030 subterm = fill;
1031 do {
1032 if ( *m == *t ) {
1033 m += 1; t += 1;
1034 }
1035 else if ( *m >= (AM.OffsetIndex+WILDOFFSET) ) {
1036 while ( t < xstop ) *fill++ = *t++;
1037 nq = WORDDIF(fill, subterm);
1038 fill = subterm;
1039 do {
1040 if ( !CheckWild(BHEAD *m-WILDOFFSET,INDTOIND,*fill,&newval3) ) {
1041 break;
1042 }
1043 fill += 1;
1044 nq -= 1;
1045 } while ( nq > 0 );
1046 nq -= 1;
1047 if ( nq > 0 ) {
1048 q = fill + 1;
1049 NCOPY(fill,q,nq);
1050 }
1051 m += 1;
1052 }
1053 else {
1054 *fill++ = *t++;
1055 }
1056 } while ( m < ystop );
1057 while ( t < xstop ) *fill++ = *t++;
1058 nq = WORDDIF(fill,subterm);
1059 if ( nq > 0 ) {
1060 nq += 2;
1061 subterm[-1] = nq;
1062 }
1063 else { fill = subterm; fill -= 2; }
1064 }
1065/*
1066 #] INDICES :
1067 #[ DELTAS :
1068*/
1069 else if ( *m == DELTA ) {
1070 while ( *t > DELTA ) {
1071 nq = t[1];
1072 NCOPY(fill,t,nq);
1073 }
1074 xstop = t + t[1];
1075 ystop = m + m[1];
1076 t += 2;
1077 m += 2;
1078 *fill++ = DELTA;
1079 fill++;
1080 subterm = fill;
1081 do {
1082 if ( *t == *m && t[1] == m[1] ) { m += 2; t += 2; }
1083 else if ( *m >= (AM.OffsetIndex+WILDOFFSET) ) { /* Two dummies */
1084 while ( t < xstop ) *fill++ = *t++;
1085/* fill = subterm; */
1086 oldval1 = 1;
1087 goto SubsL6;
1088 }
1089 else if ( m[1] >= (AM.OffsetIndex+WILDOFFSET) ) {
1090 while ( (*m == *t || *m == t[1] ) && ( t < xstop ) ) {
1091 *fill++ = *t++; *fill++ = *t++;
1092 }
1093 oldval1 = 0;
1094SubsL6: nq = WORDDIF(fill,subterm);
1095 fill = subterm;
1096 do {
1097 if ( ( oldval1 && ( (
1098 !CheckWild(BHEAD *m-WILDOFFSET,INDTOIND,*fill,&newval3)
1099 && !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,fill[1],&newval3)
1100 ) || (
1101 !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,*fill,&newval3)
1102 && !CheckWild(BHEAD *m-WILDOFFSET,INDTOIND,fill[1],&newval3)
1103 ) ) ) || ( !oldval1 && ( (
1104 *m == *fill
1105 && !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,fill[1],&newval3)
1106 ) || (
1107 *m == fill[1]
1108 && !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,*fill,&newval3)
1109 ) ) ) ) break;
1110 fill += 2;
1111 nq -= 2;
1112 } while ( nq > 0 );
1113 nq -= 2;
1114 if ( nq > 0 ) {
1115 q = fill + 2;
1116 NCOPY(fill,q,nq);
1117 }
1118 m += 2;
1119 }
1120 else {
1121 *fill++ = *t++; *fill++ = *t++;
1122 }
1123 } while ( m < ystop );
1124 while ( t < xstop ) *fill++ = *t++;
1125 nq = WORDDIF(fill,subterm);
1126 if ( nq > 0 ) {
1127 nq += 2;
1128 subterm[-1] = nq;
1129 }
1130 else { fill = subterm; fill -= 2; }
1131 }
1132/*
1133 #] DELTAS :
1134*/
1135EndLoop:;
1136 } while ( m < mstop ); }
1137 while ( t < tstop ) *fill++ = *t++;
1138SubCoef:
1139 if ( !PutExpr ) {
1140 t = AN.FullProto;
1141 nq = t[1];
1142 t[3] = power;
1143 NCOPY(fill,t,nq);
1144 }
1145 t = tcoef;
1146 nq = ABS(*t);
1147 t = tstop;
1148 NCOPY(fill,t,nq);
1149 nq = WORDDIF(fill,TemTerm);
1150 fill = term;
1151 t = TemTerm;
1152 *fill++ = nq--;
1153 t++;
1154 NCOPY(fill,t,nq);
1155 if ( sign ) {
1156 if ( ( sign & 1 ) != 0 ) fill[-1] = -fill[-1];
1157 }
1158 if ( AT.WorkPointer < fill ) AT.WorkPointer = fill;
1159 AN.RepFunNum = 0;
1160}
1161
1162/*
1163 #] Substitute :
1164 #[ FindSpecial : WORD FindSpecial(term)
1165
1166 Routine to detect simplifications regarding the special functions
1167 exponent, denominator.
1168
1169
1170void FindSpecial(WORD *term)
1171{
1172 WORD *t;
1173 WORD *tstop;
1174 t = term; t += *t - 1; tstop = t - ABS(*t) + 1; t = term;
1175 t++;
1176 if ( t < tstop ) { do {
1177 if ( *t == EXPONENT ) {
1178 Exponents can become simpler when:
1179 a: the exponent of an expression becomes an integer.
1180 b: The expression becomes zero.
1181 }
1182 else if ( *t == DENOMINATOR ) {
1183 Denominators can become simpler when:
1184 a: The denominator is a single term without functions.
1185 b: An overall coefficient can be removed.
1186 c: An overall object can be removed.
1187 The task is here to bring the denominator in an unique form.
1188 }
1189 t += *t;
1190 } while ( t < tstop ); }
1191}
1192
1193 #] FindSpecial :
1194 #[ FindAll : WORD FindAll(term,pattern,level,par)
1195*/
1196
1197int FindAll(PHEAD WORD *term, WORD *pattern, WORD level, WORD *par)
1198{
1199 GETBIDENTITY
1200 WORD *t, *m, *r, *mm, rnum;
1201 WORD *tstop, *mstop, *TwoProto, *vwhere = 0, oldv, oldvv, vv, level2;
1202 WORD v, nq, OffNum = AM.OffsetVector + WILDOFFSET, i, ii = 0, jj;
1203 WORD fromindex, *intens, notflag1 = 0, notflag2 = 0;
1204 CBUF *C;
1205 C = cbuf+AM.rbufnum;
1206 v = pattern[3]; /* The vector to be found */
1207 m = t = term;
1208 m += *m;
1209 m -= ABS(m[-1]);
1210 t++;
1211 if ( t < m ) do {
1212 tstop = t + t[1];
1213 fromindex = 2;
1214/*
1215 #[ VECTOR :
1216*/
1217 if ( *t == VECTOR ) {
1218 r = t;
1219 r += 2;
1220InVect:
1221 while ( r < tstop ) {
1222 oldv = *r;
1223 if ( v >= OffNum ) {
1224 vwhere = AN.FullProto + 3 + SUBEXPSIZE;
1225 if ( vwhere[1] == FROMSET || vwhere[1] == SETTONUM ) {
1226 WORD *afirst, *alast, j;
1227 j = vwhere[3];
1228 if ( j > WILDOFFSET ) { j -= 2*WILDOFFSET; notflag1 = 1; }
1229 else { notflag1 = 0; }
1230 afirst = SetElements + Sets[j].first;
1231 alast = SetElements + Sets[j].last;
1232 ii = 1;
1233 if ( notflag1 == 0 ) {
1234 do {
1235 if ( *afirst == *r ) {
1236 if ( vwhere[1] == SETTONUM ) {
1237 AN.FullProto[8+SUBEXPSIZE] = SYMTONUM;
1238 AN.FullProto[11+SUBEXPSIZE] = ii;
1239 }
1240 else if ( vwhere[4] >= 0 ) {
1241 oldv = *(afirst - Sets[j].first
1242 + Sets[vwhere[4]].first);
1243 }
1244 goto DoVect;
1245 }
1246 ii++;
1247 } while ( ++afirst < alast );
1248 }
1249 else {
1250 do {
1251 if ( *afirst == *r ) break;
1252 } while ( ++afirst < alast );
1253 if ( afirst >= alast ) goto DoVect;
1254 }
1255 }
1256 else goto DoVect;
1257 }
1258 else if ( v == *r ) {
1259DoVect: m = AT.WorkPointer;
1260 tstop = t;
1261 t = term;
1262 mstop = t + *t;
1263 do { *m++ = *t++; } while ( t < tstop );
1264 vwhere = m;
1265 t = AN.FullProto;
1266 nq = t[1];
1267 t[3] = 1;
1268 NCOPY(m,t,nq);
1269 t = tstop;
1270 if ( fromindex == 1 ) m[-1] = FUNNYVEC;
1271 else m[-1] = r[1]; /* The index is always here! */
1272 if ( v >= OffNum ) vwhere[3+SUBEXPSIZE] = oldv;
1273 if ( vwhere[1] > 12+SUBEXPSIZE ) {
1274 vwhere[11+SUBEXPSIZE] = ii;
1275 vwhere[8+SUBEXPSIZE] = SYMTONUM;
1276 }
1277 if ( t[1] > fromindex+2 ) {
1278 *m++ = *t++;
1279 *m++ = *t++ - fromindex;
1280 while ( t < r ) *m++ = *t++;
1281 t += fromindex;
1282 }
1283 else t += t[1];
1284 do { *m++ = *t++; } while ( t < mstop );
1285 *AT.WorkPointer = nq = WORDDIF(m,AT.WorkPointer);
1286 m = AT.WorkPointer;
1287 t = term;
1288 NCOPY(t,m,nq);
1289 AT.WorkPointer = t;
1290 return(1);
1291 }
1292 r += fromindex;
1293 }
1294 }
1295/*
1296 #] VECTOR :
1297 #[ DOTPRODUCT :
1298*/
1299 else if ( *t == DOTPRODUCT ) {
1300 r = t;
1301 r += 2;
1302 do {
1303 if ( ( i = r[2] ) < 0 ) goto NextDot;
1304 if ( *r == r[1] ) { /* p.p */
1305 oldv = *r;
1306 if ( v == *r ) { /* v.v */
1307TwoVec: m = AT.WorkPointer;
1308 tstop = t;
1309 t = term;
1310 mstop = t + *t;
1311 do { *m++ = *t++; } while ( t < tstop );
1312 do {
1313 vwhere = m;
1314 t = AN.FullProto;
1315 nq = t[1];
1316 t[3] = 2;
1317 NCOPY(m,t,nq);
1318 m[-1] = ++AR.CurDum;
1319 if ( v >= OffNum ) vwhere[3+SUBEXPSIZE] = oldv;
1320 } while ( --i > 0 );
1321CopRest: t = tstop;
1322 if ( t[1] > 5 ) {
1323 *m++ = *t++;
1324 *m++ = *t++ - 3;
1325 while ( t < r ) *m++ = *t++;
1326 t += 3;
1327 }
1328 else t += t[1];
1329 do { *m++ = *t++; } while ( t < mstop );
1330 *AT.WorkPointer = nq = WORDDIF(m,AT.WorkPointer);
1331 m = AT.WorkPointer;
1332 t = term;
1333 NCOPY(t,m,nq);
1334 AT.WorkPointer = t;
1335 return(1);
1336 }
1337 else if ( v >= OffNum ) { /* v?.v? */
1338 vwhere = AN.FullProto + 3+SUBEXPSIZE;
1339 if ( vwhere[1] == FROMSET || vwhere[1] == SETTONUM ) {
1340 WORD *afirst, *alast, j;
1341 j = vwhere[3];
1342 if ( j > WILDOFFSET ) { j -= 2*WILDOFFSET; notflag1 = 1; }
1343 else { notflag1 = 0; }
1344 afirst = SetElements + Sets[j].first;
1345 alast = SetElements + Sets[j].last;
1346 ii = 1;
1347 if ( notflag1 == 0 ) {
1348 do {
1349 if ( *afirst == *r ) {
1350 if ( vwhere[1] == SETTONUM ) {
1351 AN.FullProto[8+SUBEXPSIZE] = SYMTONUM;
1352 AN.FullProto[11+SUBEXPSIZE] = ii;
1353 }
1354 else if ( vwhere[4] >= 0 ) {
1355 oldv = *(afirst - Sets[j].first
1356 + Sets[vwhere[4]].first);
1357 }
1358 goto TwoVec;
1359 }
1360 ii++;
1361 } while ( ++afirst < alast );
1362 }
1363 else {
1364 do {
1365 if ( *afirst == *r ) break;
1366 } while ( ++afirst < alast );
1367 if ( afirst >= alast ) goto TwoVec;
1368 }
1369 }
1370 else goto TwoVec;
1371 }
1372 }
1373 else {
1374 if ( v == r[1] ) { r[1] = *r; *r = v; }
1375 oldv = *r;
1376 oldvv = r[1];
1377 if ( v == *r ) {
1378 if ( !par ) { while ( ++level <= AR.Cnumlhs
1379 && C->lhs[level][0] == TYPEIDOLD ) {
1380 m = C->lhs[level];
1381 m += IDHEAD;
1382 if ( m[-IDHEAD+2] == SUBVECTOR ) {
1383 if ( ( vv = m[m[1]+3] ) == r[1] ) {
1384OnePV: TwoProto = AN.FullProto;
1385TwoPV: m = AT.WorkPointer;
1386 tstop = t;
1387 t = term;
1388 mstop = t + *t;
1389 do { *m++ = *t++; } while ( t < tstop );
1390 do {
1391 t = AN.FullProto;
1392 vwhere = m + 3 +SUBEXPSIZE;
1393 nq = t[1];
1394 t[3] = 1;
1395 NCOPY(m,t,nq);
1396 m[-1] = ++AR.CurDum;
1397 if ( v >= OffNum ) *vwhere = oldv;
1398 if ( vwhere[-2-SUBEXPSIZE] > 12+SUBEXPSIZE ) {
1399 vwhere[8] = ii;
1400 vwhere[5] = SYMTONUM;
1401 }
1402 t = TwoProto;
1403 vwhere = m + 3+SUBEXPSIZE;
1404 mm = m;
1405 nq = t[1];
1406 t[3] = 1;
1407 NCOPY(m,t,nq);
1408/*
1409 The next two lines repair a bug. without them it takes twice
1410 the rhs of the first vector.
1411*/
1412 mm[2] = C->lhs[level][IDHEAD+2];
1413 mm[4] = C->lhs[level][IDHEAD+4];
1414 m[-1] = AR.CurDum;
1415 if ( vv >= OffNum ) *vwhere = oldvv;
1416 } while ( --i > 0 );
1417 goto CopRest;
1418 }
1419 else if ( vv > OffNum ) {
1420 vwhere = AN.FullProto + 3+SUBEXPSIZE;
1421 if ( vwhere[1] == FROMSET || vwhere[1] == SETTONUM ) {
1422 WORD *afirst, *alast, j;
1423 j = vwhere[3];
1424 if ( j > WILDOFFSET ) { j -= 2*WILDOFFSET; notflag1 = 1; }
1425 else { notflag1 = 0; }
1426 afirst = SetElements + Sets[j].first;
1427 alast = SetElements + Sets[j].last;
1428 if ( notflag1 == 0 ) {
1429 ii = 1;
1430 do {
1431 if ( *afirst == r[1] ) {
1432 if ( vwhere[1] == SETTONUM ) {
1433 AN.FullProto[8+SUBEXPSIZE] = SYMTONUM;
1434 AN.FullProto[11+SUBEXPSIZE] = ii;
1435 }
1436 else if ( vwhere[4] >= 0 ) {
1437 oldvv = *(afirst - Sets[j].first
1438 + Sets[vwhere[4]].first);
1439 }
1440 goto OnePV;
1441 }
1442 ii++;
1443 } while ( ++afirst < alast );
1444 }
1445 else {
1446 do {
1447 if ( *afirst == *r ) break;
1448 } while ( ++afirst < alast );
1449 if ( afirst >= alast ) goto OnePV;
1450 }
1451 }
1452 else goto OnePV;
1453 }
1454 }
1455 }}
1456/*
1457 v.q with v matching and no match for the q, also
1458 not in following idold statements.
1459 Notice that a following q.p? cannot match.
1460*/
1461 rnum = r[1];
1462OneOnly: m = AT.WorkPointer;
1463 tstop = t;
1464 t = term;
1465 mstop = t + *t;
1466 do { *m++ = *t++; } while ( t < tstop );
1467 vwhere = m;
1468 t = AN.FullProto;
1469 nq = t[1];
1470 t[3] = i;
1471 NCOPY(m,t,nq);
1472 m[-4] = INDTOIND;
1473 m[-1] = rnum;
1474 if ( v >= OffNum ) vwhere[3+SUBEXPSIZE] = oldv;
1475 goto CopRest;
1476 }
1477 else if ( v >= OffNum ) {
1478 vwhere = AN.FullProto + 3+SUBEXPSIZE;
1479 if ( vwhere[1] == FROMSET || vwhere[1] == SETTONUM ) {
1480 WORD *afirst, *alast, *bfirst, *blast, j;
1481 j = vwhere[3];
1482 if ( j > WILDOFFSET ) { j -= 2*WILDOFFSET; notflag1 = 1; }
1483 else { notflag1 = 0; }
1484 afirst = SetElements + Sets[j].first;
1485 alast = SetElements + Sets[j].last;
1486 ii = 1;
1487 if ( notflag1 == 0 ) {
1488 do {
1489 if ( *afirst == *r ) {
1490 if ( vwhere[1] == SETTONUM ) {
1491 AN.FullProto[8+SUBEXPSIZE] = SYMTONUM;
1492 AN.FullProto[11+SUBEXPSIZE] = ii;
1493 }
1494 else if ( vwhere[4] >= 0 ) {
1495 oldv = *(afirst - Sets[j].first
1496 + Sets[vwhere[4]].first);
1497 }
1498Hitlevel1: level2 = level;
1499 do {
1500 if ( !par ) m = C->lhs[level2];
1501 else m = par;
1502 m += IDHEAD;
1503 if ( m[-IDHEAD+2] == SUBVECTOR ) {
1504 if ( ( vv = m[m[1]+3] ) == r[1] )
1505 goto OnePV;
1506 else if ( vv >= OffNum ) {
1507 if ( m[SUBEXPSIZE+4] != FROMSET &&
1508 m[SUBEXPSIZE+4] != SETTONUM ) goto OnePV;
1509 j = m[SUBEXPSIZE+6];
1510 if ( j > WILDOFFSET ) { j -= 2*WILDOFFSET; notflag2 = 1; }
1511 else { notflag2 = 0; }
1512 bfirst = SetElements + Sets[j].first;
1513 blast = SetElements + Sets[j].last;
1514 jj = 1;
1515 if ( notflag2 == 0 ) {
1516 do {
1517 if ( *bfirst == r[1] ) {
1518 if ( m[SUBEXPSIZE+4] == SETTONUM ) {
1519 m[SUBEXPSIZE+8] = SYMTONUM;
1520 m[SUBEXPSIZE+11] = jj;
1521 }
1522 else if ( m[SUBEXPSIZE+7] >= 0 ) {
1523 oldvv = *(bfirst - Sets[j].first
1524 + Sets[m[SUBEXPSIZE+7]].first);
1525 }
1526 goto OnePV;
1527 }
1528 jj++;
1529 } while ( ++bfirst < blast );
1530 }
1531 else {
1532 do {
1533 if ( *bfirst == r[1] ) break;
1534 } while ( ++bfirst < blast );
1535 if ( bfirst >= blast ) goto OnePV;
1536 }
1537 }
1538 }
1539 } while ( ++level2 < AR.Cnumlhs &&
1540 C->lhs[level2][0] == TYPEIDOLD );
1541 rnum = r[1];
1542 goto OneOnly;
1543 }
1544 else if ( *afirst == r[1] ) {
1545 if ( vwhere[1] == SETTONUM ) {
1546 AN.FullProto[8+SUBEXPSIZE] = SYMTONUM;
1547 AN.FullProto[11+SUBEXPSIZE] = ii;
1548 }
1549 else if ( vwhere[4] >= 0 ) {
1550 oldv = *(afirst - Sets[j].first
1551 + Sets[vwhere[4]].first);
1552 }
1553Hitlevel2: level2 = level;
1554 while ( ++level2 < AR.Cnumlhs &&
1555 C->lhs[level2][0] == TYPEIDOLD ) {
1556 if ( !par ) m = C->lhs[level2];
1557 else m = par;
1558 m += IDHEAD;
1559 if ( m[-IDHEAD+2] == SUBVECTOR ) {
1560 if ( ( vv = m[6] ) == *r )
1561 goto OnePV;
1562 else if ( vv >= OffNum ) {
1563 if ( m[SUBEXPSIZE+4] != FROMSET && m[SUBEXPSIZE+4]
1564 != SETTONUM ) {
1565 j = *r;
1566 *r = r[1];
1567 r[1] = j;
1568 goto OnePV;
1569 }
1570 j = m[SUBEXPSIZE+6];
1571 bfirst = SetElements + Sets[j].first;
1572 blast = SetElements + Sets[j].last;
1573 jj = 1;
1574 do {
1575 if ( *bfirst == *r ) {
1576 if ( m[SUBEXPSIZE+4] == SETTONUM ) {
1577 m[SUBEXPSIZE+8] = SYMTONUM;
1578 m[SUBEXPSIZE+11] = jj;
1579 }
1580 else if ( m[SUBEXPSIZE+7] >= 0 ) {
1581 oldvv = *(bfirst - Sets[j].first
1582 + Sets[m[SUBEXPSIZE+7]].first);
1583 }
1584 j = *r;
1585 *r = r[1];
1586 r[1] = j;
1587 j = oldv; oldv = oldvv; oldvv = j;
1588 goto OnePV;
1589 }
1590 jj++;
1591 } while ( ++bfirst < blast );
1592 }
1593 }
1594 }
1595 jj = *r; *r = r[1]; r[1] = jj;
1596 jj = oldv; oldv = oldvv; oldvv = j;
1597 rnum = r[1];
1598 goto OneOnly;
1599 }
1600 ii++;
1601 } while ( ++afirst < alast );
1602 }
1603 else {
1604 do {
1605 if ( *afirst == *r ) break;
1606 } while ( ++afirst < alast );
1607 if ( afirst >= alast ) goto Hitlevel1;
1608 do {
1609 if ( *afirst == r[1] ) break;
1610 } while ( ++afirst < alast );
1611 if ( afirst >= alast ) goto Hitlevel2;
1612 }
1613 }
1614 else { /* Matches twice */
1615 vv = v;
1616 TwoProto = AN.FullProto;
1617 goto TwoPV;
1618 }
1619 }
1620 }
1621NextDot: r += 3;
1622 } while ( r < tstop );
1623 }
1624/*
1625 #] DOTPRODUCT :
1626 #[ LEVICIVITA :
1627*/
1628 else if ( *t == LEVICIVITA ) {
1629 intens = 0;
1630 r = t;
1631 r += FUNHEAD;
1632OneVect:;
1633 while ( r < tstop ) {
1634 oldv = *r;
1635 if ( v >= OffNum && *r < -10 ) {
1636 vwhere = AN.FullProto + 3+SUBEXPSIZE;
1637 if ( vwhere[1] == FROMSET || vwhere[1] == SETTONUM ) {
1638 WORD *afirst, *alast, j;
1639 j = vwhere[3];
1640 if ( j > WILDOFFSET ) { j -= 2*WILDOFFSET; notflag1 = 1; }
1641 else { notflag1 = 0; }
1642 afirst = SetElements + Sets[j].first;
1643 alast = SetElements + Sets[j].last;
1644 ii = 1;
1645 if ( notflag1 == 0 ) {
1646 do {
1647 if ( *afirst == *r ) {
1648 if ( vwhere[1] == SETTONUM ) {
1649 AN.FullProto[8+SUBEXPSIZE] = SYMTONUM;
1650 AN.FullProto[11+SUBEXPSIZE] = ii;
1651 }
1652 else if ( vwhere[4] >= 0 ) {
1653 oldv = *(afirst - Sets[j].first
1654 + Sets[vwhere[4]].first);
1655 }
1656 goto DoVect;
1657 }
1658 ii++;
1659 } while ( ++afirst < alast );
1660 }
1661 else {
1662 do {
1663 if ( *afirst == *r ) break;
1664 } while ( ++afirst < alast );
1665 if ( afirst >= alast ) goto DoVect;
1666 }
1667 }
1668 else goto LeVect;
1669 }
1670 else if ( v == *r ) {
1671LeVect: m = AT.WorkPointer;
1672 mstop = term + *term;
1673 t = term;
1674 *r = ++AR.CurDum;
1675 if ( intens ) *intens = DIRTYSYMFLAG;
1676 do { *m++ = *t++; } while ( t < tstop );
1677 t = AN.FullProto;
1678 nq = t[1];
1679 t[3] = 1;
1680 if ( v >= OffNum ) *vwhere = oldv;
1681 NCOPY(m,t,nq);
1682 m[-1] = AR.CurDum;
1683 t = tstop;
1684 do { *m++ = *t++; } while ( t < mstop );
1685 *AT.WorkPointer = nq = WORDDIF(m,AT.WorkPointer);
1686 m = AT.WorkPointer;
1687 t = term;
1688 NCOPY(t,m,nq);
1689 AT.WorkPointer = t;
1690 return(1);
1691 }
1692 r++;
1693 }
1694 }
1695/*
1696 #] LEVICIVITA :
1697 #[ GAMMA :
1698*/
1699 else if ( *t == GAMMA ) {
1700 intens = 0;
1701 r = t;
1702 r += FUNHEAD+1;
1703 if ( r < tstop ) goto OneVect;
1704 }
1705/*
1706 #] GAMMA :
1707 #[ INDEX :
1708*/
1709 else if ( *t == INDEX ) { /* The 'forgotten' part */
1710 r = t;
1711 r += 2;
1712 fromindex = 1;
1713 goto InVect;
1714 }
1715/*
1716 #] INDEX :
1717 #[ FUNCTION :
1718*/
1719 else if ( *t >= FUNCTION ) {
1720 if ( *t >= FUNCTION
1721 && functions[*t-FUNCTION].spec >= TENSORFUNCTION
1722 && t[1] > FUNHEAD ) {
1723/*
1724 Tensors are linear in their vectors!
1725*/
1726 r = t;
1727 r += FUNHEAD;
1728 intens = t+2;
1729 goto OneVect;
1730 }
1731 }
1732/*
1733 #] FUNCTION :
1734*/
1735 t += t[1];
1736 } while ( t < m );
1737 return(0);
1738}
1739
1740/*
1741 #] FindAll :
1742 #[ TestSelect :
1743
1744 Returns 1 if any of the objects in any of the sets in setp
1745 occur anywhere in the term
1746*/
1747
1748int TestSelect(WORD *term, WORD *setp)
1749{
1750 WORD *tstop, *t, *s, *el, *elstop, *termstop, *tt, n, ns;
1751 GETSTOP(term,tstop);
1752 term += 1;
1753 while ( term < tstop ) {
1754 switch ( *term ) {
1755 case SYMBOL:
1756 n = term[1] - 2;
1757 t = term + 2;
1758 while ( n > 0 ) {
1759 ns = setp[1] - 2;
1760 s = setp + 2;
1761 while ( --ns >= 0 ) {
1762 if ( Sets[*s].type != CSYMBOL ) { s++; continue; }
1763 el = SetElements + Sets[*s].first;
1764 elstop = SetElements + Sets[*s].last;
1765 while ( el < elstop ) {
1766 if ( *el++ == *t ) return(1);
1767 }
1768 s++;
1769 }
1770 n -= 2;
1771 t += 2;
1772 }
1773 break;
1774 case VECTOR:
1775 n = term[1] - 2;
1776 t = term + 2;
1777 while ( n > 0 ) {
1778 ns = setp[1] - 2;
1779 s = setp + 2;
1780 while ( --ns >= 0 ) {
1781 if ( Sets[*s].type != CVECTOR ) { s++; continue; }
1782 el = SetElements + Sets[*s].first;
1783 elstop = SetElements + Sets[*s].last;
1784 while ( el < elstop ) {
1785 if ( *el++ == *t ) return(1);
1786 }
1787 s++;
1788 }
1789 t++;
1790 ns = setp[1] - 2;
1791 s = setp + 2;
1792 while ( --ns >= 0 ) {
1793 if ( Sets[*s].type != CINDEX
1794 && Sets[*s].type != CNUMBER ) { s++; continue; }
1795 el = SetElements + Sets[*s].first;
1796 elstop = SetElements + Sets[*s].last;
1797 while ( el < elstop ) {
1798 if ( *el++ == *t ) return(1);
1799 }
1800 s++;
1801 }
1802 n -= 2;
1803 t++;
1804 }
1805 break;
1806 case INDEX:
1807 n = term[1] - 2;
1808 t = term + 2;
1809 goto dotensor;
1810 case DOTPRODUCT:
1811 n = term[1] - 2;
1812 t = term + 2;
1813 while ( n > 0 ) {
1814 ns = setp[1] - 2;
1815 s = setp + 2;
1816 while ( --ns >= 0 ) {
1817 if ( Sets[*s].type != CVECTOR ) { s++; continue; }
1818 el = SetElements + Sets[*s].first;
1819 elstop = SetElements + Sets[*s].last;
1820 while ( el < elstop ) {
1821 if ( *el++ == *t ) return(1);
1822 }
1823 s++;
1824 }
1825 t++;
1826 ns = setp[1] - 2;
1827 s = setp + 2;
1828 while ( --ns >= 0 ) {
1829 if ( Sets[*s].type != CVECTOR ) { s++; continue; }
1830 el = SetElements + Sets[*s].first;
1831 elstop = SetElements + Sets[*s].last;
1832 while ( el < elstop ) {
1833 if ( *el++ == *t ) return(1);
1834 }
1835 s++;
1836 }
1837 n -= 3;
1838 t += 2;
1839 }
1840 break;
1841 case DELTA:
1842 n = term[1] - 2;
1843 t = term + 2;
1844 goto dotensor;
1845 default:
1846 if ( *term < FUNCTION ) break;
1847 ns = setp[1] - 2;
1848 s = setp + 2;
1849 while ( --ns >= 0 ) {
1850 if ( Sets[*s].type != CFUNCTION ) { s++; continue; }
1851 el = SetElements + Sets[*s].first;
1852 elstop = SetElements + Sets[*s].last;
1853 while ( el < elstop ) {
1854 if ( *el++ == *term ) return(1);
1855 }
1856 s++;
1857 }
1858 if ( functions[*term-FUNCTION].spec > 0 ) {
1859 n = term[1] - FUNHEAD;
1860 t = term + FUNHEAD;
1861dotensor:
1862 while ( n > 0 ) {
1863 ns = setp[1] - 2;
1864 s = setp + 2;
1865 while ( --ns >= 0 ) {
1866 if ( *t < MINSPEC ) {
1867 if ( Sets[*s].type != CVECTOR ) { s++; continue; }
1868 }
1869 else if ( *t >= 0 ) {
1870 if ( Sets[*s].type != CINDEX
1871 && Sets[*s].type != CNUMBER ) { s++; continue; }
1872 }
1873 else { s++; continue; }
1874 el = SetElements + Sets[*s].first;
1875 elstop = SetElements + Sets[*s].last;
1876 while ( el < elstop ) {
1877 if ( *el++ == *t ) return(1);
1878 }
1879 s++;
1880 }
1881 t++;
1882 n--;
1883 }
1884 }
1885 else {
1886 termstop = term + term[1];
1887 tt = term + FUNHEAD;
1888 while ( tt < termstop ) {
1889 if ( *tt < 0 ) {
1890 if ( *tt == -SYMBOL ) {
1891 ns = setp[1] - 2;
1892 s = setp + 2;
1893 while ( --ns >= 0 ) {
1894 if ( Sets[*s].type != CSYMBOL ) { s++; continue; }
1895 el = SetElements + Sets[*s].first;
1896 elstop = SetElements + Sets[*s].last;
1897 while ( el < elstop ) {
1898 if ( *el++ == tt[1] ) return(1);
1899 }
1900 s++;
1901 }
1902 tt += 2;
1903 }
1904 else if ( *tt == -VECTOR || *tt == -MINVECTOR ) {
1905 ns = setp[1] - 2;
1906 s = setp + 2;
1907 while ( --ns >= 0 ) {
1908 if ( Sets[*s].type != CVECTOR ) { s++; continue; }
1909 el = SetElements + Sets[*s].first;
1910 elstop = SetElements + Sets[*s].last;
1911 while ( el < elstop ) {
1912 if ( *el++ == tt[1] ) return(1);
1913 }
1914 s++;
1915 }
1916 tt += 2;
1917 }
1918 else if ( *tt == -INDEX ) {
1919 ns = setp[1] - 2;
1920 s = setp + 2;
1921 while ( --ns >= 0 ) {
1922 if ( Sets[*s].type != CINDEX
1923 && Sets[*s].type != CNUMBER ) { s++; continue; }
1924 el = SetElements + Sets[*s].first;
1925 elstop = SetElements + Sets[*s].last;
1926 while ( el < elstop ) {
1927 if ( *el++ == tt[1] ) return(1);
1928 }
1929 s++;
1930 }
1931 tt += 2;
1932 }
1933 else if ( *tt <= -FUNCTION ) {
1934 ns = setp[1] - 2;
1935 s = setp + 2;
1936 while ( --ns >= 0 ) {
1937 if ( Sets[*s].type != CFUNCTION ) { s++; continue; }
1938 el = SetElements + Sets[*s].first;
1939 elstop = SetElements + Sets[*s].last;
1940 while ( el < elstop ) {
1941 if ( *el++ == -(*tt) ) return(1);
1942 }
1943 s++;
1944 }
1945 tt++;
1946 }
1947 else tt += 2;
1948 }
1949 else {
1950 t = tt + ARGHEAD;
1951 tt += *tt;
1952 while ( t < tt ) {
1953 if ( TestSelect(t,setp) ) return(1);
1954 t += *t;
1955 }
1956 }
1957 }
1958 }
1959 break;
1960 }
1961 term += term[1];
1962 }
1963 return(0);
1964}
1965
1966/*
1967 #] TestSelect :
1968 #[ SubsInAll : void SubsInAll()
1969
1970 This routine takes a match in id,all and stores it away in
1971 the AT.allbufnum 'compiler' buffer, after taking out the pattern.
1972 The main problem here is that id,all usually has (lots of) wildcards
1973 and their assignments are on stack and the difficult ones are in
1974 AT.ebufnum. Popping the stack while looking for more matches would
1975 loose those. Hence we have to copy them into yet another compiler
1976 buffer: AT.aebufnum. Because this may involve many matches and
1977 because the original term has only a limited number of arguments,
1978 it will pay to look for already existing ones in this buffer.
1979 (to be done later).
1980*/
1981
1982void SubsInAll(PHEAD0)
1983{
1984 GETBIDENTITY
1985 WORD *TemTerm;
1986 WORD *t, *m, *term;
1987 WORD *tstop, *mstop, *xstop;
1988 WORD nt, *fill, nq, mt;
1989 WORD *tcoef, i = 0;
1990 WORD PutExpr = 0, sign = 0;
1991/*
1992 We start with building the term in the WorkSpace.
1993 Afterwards we will transfer it to AT.allbufnum.
1994 We have to make sure there is room in the WorkSpace.
1995*/
1996 AT.idallflag = 2;
1997 TemTerm = AT.WorkPointer;
1998 if ( ( (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer*2) ) > AT.WorkTop ) {
1999 MLOCK(ErrorMessageLock);
2000 MesWork();
2001 MUNLOCK(ErrorMessageLock);
2002 Terminate(-1);
2003 }
2004 m = AN.patternbuffer + IDHEAD; m += m[1];
2005 mstop = m + *m;
2006 m++;
2007 term = AN.termbuffer;
2008 tstop = term + *term; tcoef = tstop-1; tstop -= ABS(tstop[-1]);
2009 t = term;
2010 t++;
2011 fill = TemTerm;
2012 fill++;
2013 while ( m < mstop ) {
2014 while ( t < tstop ) {
2015 nt = WORDDIF(t,term);
2016 for ( mt = 0; mt < AN.RepFunNum; mt += 2 ) {
2017 if ( nt == AN.RepFunList[mt] ) break;
2018 }
2019 if ( mt >= AN.RepFunNum ) {
2020 nq = t[1];
2021 NCOPY(fill,t,nq);
2022 }
2023 else {
2024 WORD *oldt = 0;
2025 if ( *m == GAMMA && m[1] != FUNHEAD+1 ) {
2026 oldt = t;
2027 if ( ( i = AN.RepFunList[mt+1] ) > 0 ) {
2028 *fill++ = GAMMA;
2029 *fill++ = i + FUNHEAD+1;
2030 FILLFUN(fill)
2031 nq = i + 1;
2032 t += FUNHEAD;
2033 NCOPY(fill,t,nq);
2034 }
2035 t = oldt;
2036 }
2037 else if ( ( *t == LEVICIVITA ) || ( *t >= FUNCTION
2038 && (functions[*t-FUNCTION].symmetric & ~REVERSEORDER) == ANTISYMMETRIC )
2039 ) sign += AN.RepFunList[mt+1];
2040 else if ( *m >= FUNCTION+WILDOFFSET
2041 && (functions[*m-FUNCTION-WILDOFFSET].symmetric & ~REVERSEORDER) == ANTISYMMETRIC
2042 ) sign += AN.RepFunList[mt+1];
2043 if ( !PutExpr ) {
2044 WORD *pstart = fill, *p, *w, *ww;
2045 xstop = t + t[1];
2046 t = AN.FullProto;
2047 nq = t[1];
2048 t[3] = 1;
2049 NCOPY(fill,t,nq);
2050 t = xstop;
2051 PutExpr = 1;
2052/*
2053 Here we need provisions for keeping wildcard matches
2054 that reside in AT.ebufnum. We will move them to
2055 AT.aebufnum.
2056 Problem: the SUBEXPRESSION assumes automatically
2057 that the compiler buffer is AT.ebufnum. We have to
2058 correct that in TransferBuffer.
2059*/
2060 p = pstart + SUBEXPSIZE;
2061 while ( p < fill ) {
2062 switch ( *p ) {
2063 case SYMTOSUB:
2064 case VECTOSUB:
2065 case INDTOSUB:
2066 case ARGTOARG:
2067 case ARLTOARL:
2068 w = cbuf[AT.ebufnum].rhs[p[3]];
2069 ww = cbuf[AT.ebufnum].rhs[p[3]+1];
2070/*
2071 Here we could search for whether this
2072 object sits in the buffer already.
2073 To be done later.
2074 By the way: ww-w fits inside a WORD.
2075*/
2076 AddRHS(AT.aebufnum,1);
2077 AddNtoC(AT.aebufnum,ww-w,w,11);
2078 p[3] = cbuf[AT.aebufnum].numrhs;
2079 cbuf[AT.aebufnum].rhs[p[3]+1] = cbuf[AT.aebufnum].Pointer;
2080 p += p[1];
2081 break;
2082 case FROMSET:
2083 case SETTONUM:
2084 case LOADDOLLAR:
2085 p += p[1];
2086 break;
2087 default:
2088 p += p[1];
2089 break;
2090 }
2091
2092 }
2093 }
2094 else t += t[1];
2095 if ( *m == GAMMA && m[1] != FUNHEAD+1 ) {
2096 i = oldt[1] - m[1] - i;
2097 if ( i > 0 ) {
2098 *fill++ = GAMMA;
2099 *fill++ = i + FUNHEAD+1;
2100 FILLFUN(fill)
2101 *fill++ = oldt[FUNHEAD];
2102 t = t - i;
2103 NCOPY(fill,t,i);
2104 }
2105 }
2106 break;
2107 }
2108 }
2109 m += m[1];
2110 }
2111 while ( t < tstop ) *fill++ = *t++;
2112 if ( !PutExpr ) {
2113 t = AN.FullProto;
2114 nq = t[1];
2115 t[3] = 1;
2116 NCOPY(fill,t,nq);
2117 }
2118 t = tcoef;
2119 nq = ABS(*t);
2120 t = tstop;
2121 NCOPY(fill,t,nq);
2122 if ( sign ) {
2123 if ( ( sign & 1 ) != 0 ) fill[-1] = -fill[-1];
2124 }
2125 *TemTerm = fill-TemTerm;
2126/*
2127 And now we copy this to AT.allbufnum
2128*/
2129 AddNtoC(AT.allbufnum,TemTerm[0],TemTerm,12);
2130 cbuf[AT.allbufnum].Pointer[0] = 0;
2131 AN.RepFunNum = 0;
2132}
2133
2134/*
2135 #] SubsInAll :
2136 #[ TransferBuffer :
2137
2138 Adds the whole content of a (compiler)buffer to another buffer.
2139 In spectator we have an expression in the RHS that needs the
2140 wildcard resolutions adapted by an offset.
2141*/
2142
2143void TransferBuffer(int from,int to,int spectator)
2144{
2145 CBUF *C = cbuf + spectator;
2146 CBUF *Cf = cbuf + from;
2147 CBUF *Ct = cbuf + to;
2148 int offset = Ct->numrhs;
2149 LONG i;
2150 WORD *t, *tt, *ttt, *tstop, size;
2151 for ( i = 1; i <= Cf->numrhs; i++ ) {
2152 size = Cf->rhs[i+1]-Cf->rhs[i];
2153 AddRHS(to,1);
2154 AddNtoC(to,size,Cf->rhs[i],13);
2155 }
2156 Ct->rhs[Ct->numrhs+1] = Ct->Pointer;
2157 Cf->numrhs = 0;
2158/*
2159 Now we have to update the 'pointers' in the spectator.
2160*/
2161 t = C->rhs[C->numrhs];
2162 while ( *t ) {
2163 tt = t+1; t += *t;
2164 tstop = t-ABS(t[-1]);
2165 while ( tt < tstop ) {
2166 if ( *tt == SUBEXPRESSION ) {
2167 ttt = tt+SUBEXPSIZE; tt += tt[1];
2168 while ( ttt < tt ) {
2169 switch ( *ttt ) {
2170 case SYMTOSUB:
2171 case VECTOSUB:
2172 case INDTOSUB:
2173 case ARGTOARG:
2174 case ARLTOARL:
2175 ttt[3] += offset;
2176 break;
2177 default:
2178 break;
2179 }
2180 ttt += 4;
2181 }
2182 }
2183 else tt += tt[1];
2184 }
2185 }
2186}
2187
2188/*
2189 #] TransferBuffer :
2190 #[ TakeIDfunction :
2191*/
2192
2193#define PutInBuffers(pow) \
2194 AddRHS(AT.ebufnum,1); \
2195 *out++ = SUBEXPRESSION; \
2196 *out++ = SUBEXPSIZE; \
2197 *out++ = C->numrhs; \
2198 *out++ = pow; \
2199 *out++ = AT.ebufnum; \
2200 FILLSUB(out) \
2201 r = AT.pWorkSpace[rhs+i]; \
2202 if ( *r > 0 ) { \
2203 oldinr = r[*r]; r[*r] = 0; \
2204 AddNtoC(AT.ebufnum,(*r+1-ARGHEAD),(r+ARGHEAD),14); \
2205 r[*r] = oldinr; \
2206 } \
2207 else { \
2208 ToGeneral(r,buffer,1); \
2209 buffer[buffer[0]] = 0; \
2210 AddNtoC(AT.ebufnum,buffer[0]+1,buffer,15); \
2211 }
2212
2213int TakeIDfunction(PHEAD WORD *term)
2214{
2215 WORD *tstop, *t, *r, *m, *f, *nextf, *funstop, *left, *l, *newterm;
2216 WORD *out, oldinr, pow;
2217 WORD buffer[20];
2218 int i, ii, j, numsub, numfound = 0, first;
2219 LONG lhs,rhs;
2220 CBUF *C;
2221 GETSTOP(term,tstop);
2222 for ( t = term+1; t < tstop; t += t[1] ) { if ( *t == IDFUNCTION ) break; }
2223 if ( t >= tstop ) return(0);
2224/*
2225 Step 1: test validity
2226*/
2227 funstop = t + t[1]; f = t + FUNHEAD;
2228 left = term + *term;
2229 l = left+1; numsub = 0;
2230 while ( f < funstop ) {
2231 nextf = f; NEXTARG(nextf)
2232 if ( nextf >= funstop ) { return(0); } /* odd number of arguments */
2233 if ( *f == -SYMBOL ) { *l++ = SYMBOL; *l++ = 4; *l++ = f[1]; *l++ = 1; }
2234 else if ( *f < -FUNCTION ) { *l++ = *f; *l++ = FUNHEAD; FILLFUN(l) }
2235 else if ( *f > 0 ) {
2236 if ( *f != f[ARGHEAD]+ARGHEAD ) goto noaction;
2237 if ( nextf[-1] != 3 || nextf[-2] != 1 || nextf[-3] != 1 ) goto noaction;
2238 if ( f[ARGHEAD] <= 4 ) goto noaction;
2239 if ( f[ARGHEAD] != f[ARGHEAD+2]+4 ) goto noaction;
2240 if ( f[ARGHEAD] == 8 && f[ARGHEAD+1] == SYMBOL ) {
2241 for ( i = 0; i < 4; i++ ) *l++ = f[ARGHEAD+1+i];
2242 }
2243 else if ( f[ARGHEAD] == 9 && f[ARGHEAD+1] == DOTPRODUCT ) {
2244 for ( i = 0; i < 5; i++ ) *l++ = f[ARGHEAD+1+i];
2245 }
2246 else if ( f[ARGHEAD+1] >= FUNCTION ) {
2247 for ( i = 0; i < f[ARGHEAD+1]-4; i++ ) *l++ = f[ARGHEAD+1+i];
2248 }
2249 else goto noaction;
2250 }
2251 else goto noaction;
2252 numsub++;
2253 f = nextf;
2254 NEXTARG(f)
2255 }
2256 C = cbuf+AT.ebufnum;
2257 AT.WorkPointer = l;
2258 *left = l-left;
2259/*
2260 Put the pointers to the lhs and the rhs in the pointer workspace
2261*/
2262 WantAddPointers(2*numsub);
2263 lhs = AT.pWorkPointer;
2264 rhs = lhs+numsub;
2265 AT.pWorkPointer = rhs+numsub;
2266 f = t + FUNHEAD; l = left+1;
2267 for ( i = 0; i < numsub; i++ ) {
2268 AT.pWorkSpace[lhs+i] = l; l += l[1];
2269 NEXTARG(f);
2270 AT.pWorkSpace[rhs+i] = f;
2271 NEXTARG(f);
2272 }
2273/*
2274 Take out the patterns and replace them by SUBEXPRESSIONs pointing at
2275 the e buffer. We put the resulting term above the left sides.
2276 Note that we take out only the first id_ if there is more than one!
2277*/
2278 first = 1;
2279 t = term+1; newterm = AT.WorkPointer; out = newterm+1;
2280 while ( t < tstop ) {
2281 if ( *t == IDFUNCTION && first ) { first = 0; t += t[1]; continue; }
2282 if ( *t >= FUNCTION ) {
2283 for ( i = 0; i < numsub; i++ ) {
2284 m = AT.pWorkSpace[lhs+i];
2285 if ( *m != *t ) continue;
2286 for ( j = 1; j < t[1]; j++ ) {
2287 if ( m[j] != t[j] ) break;
2288 }
2289 if ( j != t[1] ) continue;
2290 numfound++;
2291/*
2292 We have a match! Set up a SUBEXPRESSION subterm and put the
2293 corresponding rhs in the eBuffer.
2294*/
2295 PutInBuffers(1)
2296 t += t[1];
2297 }
2298 if ( i == numsub ) { /* no match. Just copy to output. */
2299 j = t[1]; NCOPY(out,t,j)
2300 }
2301 }
2302 else if ( *t == SYMBOL ) {
2303 for ( i = 0; i < numsub; i++ ) {
2304 m = AT.pWorkSpace[lhs+i];
2305 if ( *m != SYMBOL ) continue;
2306 for ( ii = 2; ii < t[1]; ii += 2 ) {
2307 if ( m[2] != t[ii] ) continue;
2308 pow = t[ii+1]/m[3];
2309 if ( pow <= 0 ) continue;
2310 t[ii+1] = t[ii+1]%m[3];
2311 numfound++;
2312/*
2313 Create the proper rhs in the eBuffer and set up a
2314 SUBEXPRESSION subterm.
2315*/
2316 PutInBuffers(pow)
2317 }
2318 }
2319/*
2320 Now we copy whatever remains of the SYMBOL subterm to the output
2321*/
2322 m = out; *out++ = t[0]; *out++ = t[1];
2323 for ( ii = 2; ii < t[1]; ii += 2 ) {
2324 if ( t[ii+1] ) { *out++ = t[ii]; *out++ = t[ii+1]; }
2325 }
2326 m[1] = out-m;
2327 if ( m[1] == 2 ) out = m;
2328 t += t[1];
2329 }
2330 else if ( *t == DOTPRODUCT ) {
2331 for ( i = 0; i < numsub; i++ ) {
2332 m = AT.pWorkSpace[lhs+i];
2333 if ( *m != DOTPRODUCT ) continue;
2334 for ( ii = 2; ii < t[1]; ii += 3 ) {
2335 if ( m[2] != t[ii] || m[3] != t[ii+1] ) continue;
2336 pow = t[ii+2]/m[4];
2337 if ( pow <= 0 ) continue;
2338 t[ii+2] = t[ii+2]%m[4];
2339 numfound++;
2340/*
2341 Create the proper rhs in the eBuffer and set up a
2342 SUBEXPRESSION subterm.
2343*/
2344 PutInBuffers(pow)
2345 }
2346 }
2347/*
2348 Now we copy whatever remains of the DOTPRODUCT subterm to the output
2349*/
2350 m = out; *out++ = t[0]; *out++ = t[1];
2351 for ( ii = 2; ii < t[1]; ii += 3 ) {
2352 if ( t[ii+2] ) { *out++ = t[ii]; *out++ = t[ii+1]; *out++ = t[ii+2]; }
2353 }
2354 m[1] = out-m;
2355 if ( m[1] == 2 ) out = m;
2356 t += t[1];
2357 }
2358 else {
2359 j = t[1]; NCOPY(out,t,j)
2360 }
2361 }
2362/*
2363 Copy the coefficient and set the size.
2364*/
2365 t = tstop; r = term+*term; while ( t < r ) *out++ = *t++;
2366 *newterm = out-newterm;
2367/*
2368 Finally we move the new term over the original term.
2369*/
2370 i = *newterm;
2371 t = term; r = newterm; NCOPY(t,r,i)
2372/*
2373 At this point we can return and if the calling Generator jumps back to
2374 its start, TestSub can take care of the expansions of SUBEXPRESSIONs.
2375*/
2376 AT.pWorkPointer = lhs;
2377 AT.WorkPointer = t;
2378 return(numfound);
2379noaction:
2380 return(0);
2381}
2382
2383/*
2384 #] TakeIDfunction :
2385 #] Patterns :
2386*/
2387
AddRHS
WORD * AddRHS(int num, int type)
Definition comtool.c:214
AddNtoC
int AddNtoC(int bufnum, int n, WORD *array, int par)
Definition comtool.c:317
EndSort
LONG EndSort(PHEAD WORD *, int)
Definition sort.c:454
Generator
int Generator(PHEAD WORD *, WORD)
Definition proces.c:3249
LowerSortLevel
void LowerSortLevel(void)
Definition sort.c:4661
NewSort
int NewSort(PHEAD0)
Definition sort.c:359
TestMatch
int TestMatch(PHEAD WORD *term, WORD *level)
Definition pattern.c:97
CbUf::rhs
WORD ** rhs
Definition structs.h:975
CbUf::lhs
WORD ** lhs
Definition structs.h:974
CbUf::Pointer
WORD * Pointer
Definition structs.h:973
Generated by doxygen 1.9.8