FORM 4.3
pattern.c
Go to the documentation of this file.
1
12/* #[ License : */
13/*
14 * Copyright (C) 1984-2022 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 occurences
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
96
97WORD 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, match = 0, i, msign = 0, ll2;
102 int numdollars = 0, protosize, oldallnumrhs;
103 CBUF *C = cbuf+AM.rbufnum, *CC;
104 AT.idallflag = 0;
105 do {
106/*
107 #[ Preliminaries :
108*/
109 ll = C->lhs[*level];
110 if ( *ll == TYPEEXPRESSION ) {
111/*
112 Expressions are not subject to anything.
113*/
114 return(0);
115 }
116 else if ( *ll == TYPEREPEAT ) {
117 *++AN.RepPoint = 0;
118 return(0); /* Will force the next level */
119 }
120 else if ( *ll == TYPEENDREPEAT ) {
121 if ( *AN.RepPoint ) {
122 AN.RepPoint[-1] = 1; /* Mark the higher level as dirty */
123 *AN.RepPoint = 0;
124 *level = ll[2]; /* Level to jump back to */
125 }
126 else {
127 AN.RepPoint--;
128 if ( AN.RepPoint < AT.RepCount ) {
129 MLOCK(ErrorMessageLock);
130 MesPrint("Internal problems with REPEAT count");
131 MUNLOCK(ErrorMessageLock);
132 Terminate(-1);
133 }
134 }
135 return(0); /* Force the next level */
136 }
137 else if ( *ll == TYPEOPERATION ) {
138/*
139 Operations have always their own level.
140*/
141 if ( (*(FG.OperaFind[ll[2]]))(BHEAD term,ll) ) return(-1);
142 else return(0);
143 }
144/*
145 #] Preliminaries :
146*/
147 OldWork = AT.WorkPointer;
148 if ( AT.WorkPointer < term + *term ) AT.WorkPointer = term + *term;
149 ww = AT.WorkPointer;
150/*
151 Here we need to make a copy of the subexpression object because we
152 will be writing the values of the wildcards in it.
153 Originally we copied it into the private version of the compiler buffer
154 that is used for scratch space (ebufnum). This caused errors in the
155 routines like ScanFunctions when the ebufnum Buffer was expanded
156 and inpat was still pointing at the old Buffer. This expansion
157 could be done in AddWild and hence cannot be fixed at > 100 places.
158 The solution is to use AN.patternbuffer (JV 16-mar-2009).
159*/
160 {
161 WORD *ta = ll, *ma;
162 int ja = ta[1];
163/*
164 New code (16-mar-2009) JV
165*/
166 if ( ( ja + 2 ) > AN.patternbuffersize ) {
167 if ( AN.patternbuffer ) M_free(AN.patternbuffer,"AN.patternbuffer");
168 AN.patternbuffersize = 2 * ja + 2;
169 AN.patternbuffer = (WORD *)Malloc1(AN.patternbuffersize * sizeof(WORD),
170 "AN.patternbuffer");
171 }
172 ma = AN.patternbuffer;
173 m = ma + IDHEAD;
174 NCOPY(ma,ta,ja);
175 *ma = 0;
176 }
177 AN.FullProto = m;
178 AN.WildValue = w = m + SUBEXPSIZE;
179 protosize = IDHEAD + m[1];
180 m += m[1];
181 AN.WildStop = m;
182 StartWork = ww;
183 ll2 = ll[2];
184/*
185 #[ Expand dollars :
186*/
187 if ( ( ll[4] & DOLLARFLAG ) != 0 ) { /* We have at least one dollar in the pattern */
188 WORD oldRepPoint = *AN.RepPoint, olddefer = AR.DeferFlag;
189 AR.Eside = LHSIDEX;
190/*
191 Copy into WorkSpace. This means that AN.patternbuffer will be free.
192*/
193 ww = AT.WorkPointer; i = m[0]; mm = m;
194 NCOPY(ww,mm,i);
195 *StartWork += 3;
196 *ww++ = 1; *ww++ = 1; *ww++ = 3;
197 AT.WorkPointer = ww;
198 AR.DeferFlag = 0;
199 NewSort(BHEAD0);
200 if ( Generator(BHEAD StartWork,AR.Cnumlhs) ) {
202 AT.WorkPointer = OldWork;
203 AR.DeferFlag = olddefer;
204 return(-1);
205 }
206 AT.WorkPointer = ww;
207 if ( EndSort(BHEAD ww,0) < 0 ) {}
208 AR.DeferFlag = olddefer;
209 if ( *ww == 0 || *(ww+*ww) != 0 ) {
210 if ( AP.lhdollarerror == 0 ) {
211/*
212 If race condition we just get more error messages
213*/
214 MLOCK(ErrorMessageLock);
215 MesPrint("&LHS must be one term");
216 MUNLOCK(ErrorMessageLock);
217 AP.lhdollarerror = 1;
218 }
219 AT.WorkPointer = OldWork;
220 return(-1);
221 }
222 m = ww; ww = m + *m;
223 if ( m[*m-1] < 0 ) { msign = 1; m[*m-1] = -m[*m-1]; }
224 if ( *ww || m[*m-1] != 3 || m[*m-2] != 1 || m[*m-3] != 1 ) {
225 MLOCK(ErrorMessageLock);
226 MesPrint("Dollar variable develops into an illegal pattern in id-statement");
227 MUNLOCK(ErrorMessageLock);
228 return(-1);
229 }
230 *m -= m[*m-1];
231 if ( ( *m + 1 + protosize ) > AN.patternbuffersize ) {
232 if ( AN.patternbuffer ) M_free(AN.patternbuffer,"AN.patternbuffer");
233 AN.patternbuffersize = 2 * (*m) + 2 + protosize;
234 AN.patternbuffer = (WORD *)Malloc1(AN.patternbuffersize * sizeof(WORD),
235 "AN.patternbuffer");
236 mm = ll; ww = AN.patternbuffer; i = protosize;
237 NCOPY(ww,mm,i);
238 AN.FullProto = AN.patternbuffer + IDHEAD;
239 AN.WildValue = w = AN.FullProto + SUBEXPSIZE;
240 AN.WildStop = AN.patternbuffer + protosize;
241 }
242 mm = AN.patternbuffer + protosize;
243 i = *m;
244 NCOPY(mm,m,i);
245 m = AN.patternbuffer + protosize;
246 AR.Eside = RHSIDE;
247 *mm = 0;
248/*
249 Test the pattern. If only wildcard powers -> SUBONCE
250*/
251 {
252 WORD *mmm = m + *m, *m1 = m+1, jm, noveto = 0;
253 while ( m1 < mmm ) {
254 if ( *m1 == SYMBOL ) {
255 for ( jm = 2; jm < m1[1]; jm+=2 ) {
256 if ( m1[jm+1] < MAXPOWER && m1[jm+1] > -MAXPOWER ) break;
257 }
258 if ( jm < m1[1] ) { noveto = 1; break; }
259 }
260 else if ( *m1 == DOTPRODUCT ) {
261 for ( jm = 2; jm < m1[1]; jm+=3 ) {
262 if ( m1[jm+2] < MAXPOWER && m1[jm+2] > -MAXPOWER ) break;
263 }
264 if ( jm < m1[1] ) { noveto = 1; break; }
265 }
266 else { noveto = 1; break; }
267 m1 += m1[1];
268 }
269 if ( noveto == 0 ) {
270 ll2 = ll2 & ~SUBMASK;
271 ll2 |= SUBONCE;
272 }
273 }
274 AT.WorkPointer = ww = StartWork;
275 *AN.RepPoint = oldRepPoint;
276 }
277/*
278 #] Expand dollars :
279
280 In case of id,all we have to check at this point that there are only
281 functions in the pattern.
282*/
283 if ( ( ll2 & SUBMASK ) == SUBALL ) {
284 WORD *t = AN.patternbuffer+IDHEAD, *tt;
285 WORD *tstop, *ttstop, ii;
286 t += t[1]; tstop = t + *t; t++;
287 while ( t < tstop ) {
288 if ( *t < FUNCTION ) break;
289 t += t[1];
290 }
291 if ( t < tstop ) {
292 MLOCK(ErrorMessageLock);
293 MesPrint("Error: id,all can only be used with (products of) functions and/or tensors.");
294 MUNLOCK(ErrorMessageLock);
295 return(-1);
296 }
297 OldTermBuffer = AN.termbuffer;
298 AN.termbuffer = TermMalloc("id,all");
299/*
300 Now make sure that only regular functions and tensors can take part.
301*/
302 tt = term; ttstop = tt+*tt; ttstop -= ABS(ttstop[-1]); tt++;
303 t = AN.termbuffer+1;
304 while ( tt < ttstop ) {
305 if ( *tt >= FUNCTION && *tt != AR.PolyFun && *tt != AR.PolyFunInv ) {
306 ii = tt[1]; NCOPY(t,tt,ii);
307 }
308 else tt += tt[1];
309 }
310 *t++ = 1; *t++ = 1; *t++ = 3; AN.termbuffer[0] = t-AN.termbuffer;
311 }
312/*
313 To be puristic, we need to check that all wildcards in the prototype
314 are actually present. If the LHS contained a replace_ this may not be
315 the case.
316*/
317 ClearWild(BHEAD0);
318 while ( w < AN.WildStop ) {
319 if ( *w == LOADDOLLAR ) numdollars++;
320 w += w[1];
321 }
322 AN.RepFunNum = 0;
323 /* rep = */ AN.RepFunList = AT.WorkPointer;
324 AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer/2);
325 if ( AT.WorkPointer >= AT.WorkTop ) {
326 MLOCK(ErrorMessageLock);
327 MesWork();
328 MUNLOCK(ErrorMessageLock);
329 return(-1);
330 }
331 AN.DisOrderFlag = ll2 & SUBDISORDER;
332 AN.nogroundlevel = 0;
333 switch ( ll2 & SUBMASK ) {
334 case SUBONLY :
335 /* Must be an exact match */
336 AN.UseFindOnly = 1; AN.ForFindOnly = 0;
337 if ( FindRest(BHEAD term,m) && ( AN.UsedOtherFind ||
338 FindOnly(BHEAD term,m) ) ) {
339 power = 1;
340 if ( msign ) term[term[0]-1] = -term[term[0]-1];
341 }
342 else power = 0;
343 break;
344 case SUBMANY :
345 AN.UseFindOnly = -1;
346 if ( ( power = FindRest(BHEAD term,m) ) > 0 ) {
347 if ( ( power = FindOnce(BHEAD term,m) ) > 0 ) {
348 AN.UseFindOnly = 0;
349 do {
350 if ( msign ) term[term[0]-1] = -term[term[0]-1];
351 Substitute(BHEAD term,m,1);
352 if ( numdollars ) {
353 WildDollars(BHEAD (WORD *)0);
354 numdollars = 0;
355 }
356 if ( ww < term+term[0] ) ww = term+term[0];
357 ClearWild(BHEAD0);
358 AT.WorkPointer = ww;
359/* if ( rep < ww ) {*/
360 AN.RepFunNum = 0;
361 /* rep = */ AN.RepFunList = ww;
362 AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer/2);
363 if ( AT.WorkPointer >= AT.WorkTop ) {
364 MLOCK(ErrorMessageLock);
365 MesWork();
366 MUNLOCK(ErrorMessageLock);
367 return(-1);
368 }
369/*
370 }
371 else {
372 AN.RepFunList = rep;
373 AN.RepFunNum = 0;
374 }
375*/
376 AN.nogroundlevel = 0;
377 } while ( FindRest(BHEAD term,m) && ( AN.UsedOtherFind ||
378 FindOnce(BHEAD term,m) ) );
379 match = 1;
380 }
381 else if ( power < 0 ) {
382 do {
383 if ( msign ) term[term[0]-1] = -term[term[0]-1];
384 Substitute(BHEAD term,m,1);
385 if ( numdollars ) {
386 WildDollars(BHEAD (WORD *)0);
387 numdollars = 0;
388 }
389 if ( ww < term+term[0] ) ww = term+term[0];
390 ClearWild(BHEAD0);
391 AT.WorkPointer = ww;
392/* if ( rep < ww ) { */
393 AN.RepFunNum = 0;
394 /* rep = */ AN.RepFunList = ww;
395 AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer/2);
396 if ( AT.WorkPointer >= AT.WorkTop ) {
397 MLOCK(ErrorMessageLock);
398 MesWork();
399 MUNLOCK(ErrorMessageLock);
400 return(-1);
401 }
402/*
403 }
404 else {
405 AN.RepFunList = rep;
406 AN.RepFunNum = 0;
407 }
408*/
409 } while ( FindRest(BHEAD term,m) );
410 match = 1;
411 }
412 }
413 else if ( power < 0 ) {
414 if ( FindOnce(BHEAD term,m) ) {
415 do {
416 if ( msign ) term[term[0]-1] = -term[term[0]-1];
417 Substitute(BHEAD term,m,1);
418 if ( numdollars ) {
419 WildDollars(BHEAD (WORD *)0);
420 numdollars = 0;
421 }
422 if ( ww < term+term[0] ) ww = term+term[0];
423 ClearWild(BHEAD0);
424 AT.WorkPointer = ww;
425/* if ( rep < ww ) { */
426 AN.RepFunNum = 0;
427 /* rep = */ AN.RepFunList = ww;
428 AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer/2);
429 if ( AT.WorkPointer >= AT.WorkTop ) {
430 MLOCK(ErrorMessageLock);
431 MesWork();
432 MUNLOCK(ErrorMessageLock);
433 return(-1);
434 }
435/*
436 }
437 else {
438 AN.RepFunList = rep;
439 AN.RepFunNum = 0;
440 }
441*/
442 } while ( FindOnce(BHEAD term,m) );
443 match = 1;
444 }
445 }
446 if ( match ) {
447 if ( ( ll2 & SUBAFTER ) != 0 ) *level = AC.Labels[ll[3]];
448 }
449 else {
450 if ( ( ll2 & SUBAFTERNOT ) != 0 ) *level = AC.Labels[ll[3]];
451 }
452 goto nextlevel;
453 case SUBONCE :
454 AN.UseFindOnly = 0;
455 if ( FindRest(BHEAD term,m) && ( AN.UsedOtherFind || FindOnce(BHEAD term,m) ) ) {
456 power = 1;
457 if ( msign ) term[term[0]-1] = -term[term[0]-1];
458 }
459 else power = 0;
460 break;
461 case SUBMULTI :
462 power = FindMulti(BHEAD term,m);
463 if ( ( power & 1 ) != 0 && msign ) term[term[0]-1] = -term[term[0]-1];
464 break;
465 case SUBVECTOR :
466 while ( ( power = FindAll(BHEAD term,m,*level,(WORD *)0) ) != 0 ) {
467 if ( ( power & 1 ) != 0 && msign ) term[term[0]-1] = -term[term[0]-1];
468 match = 1;
469 }
470 break;
471 case SUBSELECT :
472 llf = ll + IDHEAD; llf += llf[1]; llf += *llf;
473 AN.UseFindOnly = 1; AN.ForFindOnly = llf;
474 if ( FindRest(BHEAD term,m) && ( AN.UsedOtherFind || FindOnly(BHEAD term,m) ) ) {
475 if ( msign ) term[term[0]-1] = -term[term[0]-1];
476/*
477 The following code needs to be hacked a bit to allow for
478 all types of sets and for occurrence anywhere in the term
479 The code at the end of FindOnly is a bit mysterious.
480*/
481 if ( llf[1] > 2 ) {
482 WORD *t1, *t2;
483 if ( *term > AN.sizeselecttermundo ) {
484 if ( AN.selecttermundo ) M_free(AN.selecttermundo,"AN.selecttermundo");
485 AN.sizeselecttermundo = *term +10;
486 AN.selecttermundo = (WORD *)Malloc1(
487 AN.sizeselecttermundo*sizeof(WORD),"AN.selecttermundo");
488 }
489 t1 = term; t2 = AN.selecttermundo; i = *term;
490 NCOPY(t2,t1,i);
491 }
492 power = 1;
493 Substitute(BHEAD term,m,power);
494 if ( llf[1] > 2 ) {
495 if ( TestSelect(term,llf) ) {
496 WORD *t1, *t2;
497 power = 0;
498 t1 = term; t2 = AN.selecttermundo; i = *t2;
499 NCOPY(t1,t2,i);
500#if IDHEAD > 3
501 if ( ( ll2 & SUBAFTERNOT ) != 0 ) {
502 *level = AC.Labels[ll[3]];
503 }
504#endif
505 goto nextlevel;
506 }
507 }
508 if ( numdollars ) {
509 WildDollars(BHEAD (WORD *)0);
510 numdollars = 0;
511 }
512 match = 1;
513 if ( ( ll2 & SUBAFTER ) != 0 ) {
514 *level = AC.Labels[ll[3]];
515 }
516 }
517 else {
518 if ( ( ll2 & SUBAFTERNOT ) != 0 ) {
519 *level = AC.Labels[ll[3]];
520 }
521 power = 0;
522 }
523 goto nextlevel;
524 case SUBALL:
525 AN.UseFindOnly = 0;
526 CC = cbuf+AT.allbufnum;
527 oldallnumrhs = CC->numrhs;
528 t = AddRHS(AT.allbufnum,1);
529 *t = 0;
530 AT.idallflag = 1;
531 AT.idallmaxnum = ll[5];
532 AT.idallnum = 0;
533 if ( FindRest(BHEAD AN.termbuffer,m) || AT.idallflag > 1 ) {
534 WORD *t, *tstop, *tt, first = 1, ii;
535 power = 1;
536 *CC->Pointer++ = 0;
537 if ( msign ) term[term[0]-1] = -term[term[0]-1];
538/*
539 If we come here the matches are all already in the
540 compiler buffer. All we need to do is take out all
541 functions and replace them by a SUBEXPRESSION that
542 points to this buffer.
543 Note: the PolyFun/PolyRatFun should be excluded from this.
544 This works because each match writes incrementally to
545 the buffer using the routine SubsInAll.
546
547 The call to WildDollars should be made in Generator.....
548*/
549 t = term; tstop = t + *t; ii = ABS(tstop[-1]); tstop -= ii;
550 tt = AT.WorkPointer+1;
551 t++;
552 while ( t < tstop ) {
553 if ( *t >= FUNCTION && *t != AR.PolyFun && *t != AR.PolyFunInv ) {
554 if ( first ) { /* SUBEXPRESSION */
555 *tt++ = SUBEXPRESSION;
556 *tt++ = SUBEXPSIZE;
557 *tt++ = CC->numrhs;
558 *tt++ = 1;
559 *tt++ = AT.allbufnum;
560 FILLSUB(tt)
561 first = 0;
562 }
563 t += t[1];
564 }
565 else {
566 i = t[1]; NCOPY(tt,t,i);
567 }
568 }
569 if ( ( ll[4] & NORMALIZEFLAG ) != 0 ) {
570/*
571 In case of the normalization option, we have to divide
572 by AT.idallnum;
573*/
574 WORD na = t[ii-1];
575 na = REDLENG(na);
576 for ( i = 0; i < ii; i++ ) tt[i] = t[i];
577 Divvy(BHEAD (UWORD *)tt,&na,(UWORD *)(&(AT.idallnum)),1);
578 na = INCLENG(na);
579 ii = ABS(na);
580 tt[ii-1] = na;
581 tt += ii;
582 }
583 else {
584 NCOPY(tt,t,ii);
585 }
586 ii = tt-AT.WorkPointer;
587 *(AT.WorkPointer) = ii;
588 tt = AT.WorkPointer; t = term;
589 NCOPY(t,tt,ii);
590
591 if ( ( ll2 & SUBAFTER ) != 0 ) { /* ifmatch -> */
592 *level = AC.Labels[ll[3]];
593 }
594 TermFree(AN.termbuffer,"id,all");
595 AN.termbuffer = OldTermBuffer;
596 AT.WorkPointer = AN.RepFunList;
597 AT.idallflag = 0;
598 CC->Pointer[0] = 0;
599 TransferBuffer(AT.aebufnum,AT.ebufnum,AT.allbufnum);
600 return(1);
601 }
602 AT.idallflag = 0;
603 power = 0;
604 CC->numrhs = oldallnumrhs;
605 TermFree(AN.termbuffer,"id,all");
606 AN.termbuffer = OldTermBuffer;
607 break;
608 default :
609 break;
610 }
611 if ( power ) {
612 Substitute(BHEAD term,m,power);
613 if ( numdollars ) {
614 WildDollars(BHEAD (WORD *)0);
615 numdollars = 0;
616 }
617 match = 1;
618 if ( ( ll2 & SUBAFTER ) != 0 ) { /* ifmatch -> */
619 *level = AC.Labels[ll[3]];
620 }
621 }
622 else {
623 AT.WorkPointer = AN.RepFunList;
624 if ( ( ll2 & SUBAFTERNOT ) != 0 ) { /* ifnomatch -> */
625 *level = AC.Labels[ll[3]];
626 }
627 }
628nextlevel:;
629 } while ( (*level)++ < AR.Cnumlhs && C->lhs[*level][0] == TYPEIDOLD );
630 (*level)--;
631 AT.WorkPointer = AN.RepFunList;
632 return(match);
633}
634
635/*
636 #] TestMatch :
637 #[ Substitute : VOID Substitute(term,pattern,power)
638*/
639
640VOID Substitute(PHEAD WORD *term, WORD *pattern, WORD power)
641{
642 GETBIDENTITY
643 WORD *TemTerm;
644 WORD *t, *m;
645 WORD *tstop, *mstop;
646 WORD *xstop, *ystop;
647 WORD nt, *fill, nq, mt;
648 WORD *q, *subterm, *tcoef, oldval1 = 0, newval3, i = 0;
649 WORD PutExpr = 0, sign = 0;
650 TemTerm = AT.WorkPointer;
651 if ( ( (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer*2) ) > AT.WorkTop ) {
652 MLOCK(ErrorMessageLock);
653 MesWork();
654 MUNLOCK(ErrorMessageLock);
655 Terminate(-1);
656 }
657 m = pattern;
658 mstop = m + *m;
659 m++;
660 t = term;
661 t += *term - 1;
662 tcoef = t;
663 tstop = t - ABS(*t) + 1;
664 t = term;
665 t++;
666 fill = TemTerm;
667 fill++;
668 if ( m < mstop ) { do {
669/*
670 #[ SYMBOLS :
671*/
672 if ( *m == SYMBOL ) {
673 ystop = m + m[1];
674 m += 2;
675 while ( *t != SYMBOL && t < tstop ) {
676 nq = t[1];
677 NCOPY(fill,t,nq);
678 }
679 if ( t >= tstop ) goto SubCoef;
680 *fill++ = SYMBOL;
681 fill++;
682 subterm = fill;
683 xstop = t + t[1];
684 t += 2;
685 do {
686 if ( *m == *t && t < xstop ) {
687 nt = t[1];
688 mt = m[1];
689 if ( mt >= 2*MAXPOWER ) {
690 if ( CheckWild(BHEAD mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
691 nt -= AN.oldvalue;
692 goto SubsL1;
693 }
694 }
695 else if ( mt <= -2*MAXPOWER ) {
696 if ( CheckWild(BHEAD -mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
697 nt += AN.oldvalue;
698 goto SubsL1;
699 }
700 }
701 else {
702 nt -= mt * power;
703SubsL1: if ( nt ) {
704 *fill++ = *t;
705 *fill++ = nt;
706 }
707 }
708 m += 2; t+= 2;
709 }
710 else if ( *m >= 2*MAXPOWER ) {
711 while ( t < xstop ) { *fill++ = *t++; *fill++ = *t++; }
712 nq = WORDDIF(fill,subterm);
713 fill = subterm;
714 while ( nq > 0 ) {
715 if ( !CheckWild(BHEAD *m-2*MAXPOWER,SYMTOSYM,*fill,&newval3) ) {
716 mt = m[1];
717 if ( mt >= 2*MAXPOWER ) {
718 if ( CheckWild(BHEAD mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
719 if ( fill[1] -= AN.oldvalue ) goto SubsL2;
720 }
721 }
722 else if ( mt <= -2*MAXPOWER ) {
723 if ( CheckWild(BHEAD -mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
724 if ( fill[1] += AN.oldvalue ) goto SubsL2;
725 }
726 }
727 else {
728 if ( fill[1] -= mt * power ) {
729SubsL2: fill += nq;
730 nq = 0;
731 }
732 }
733 break;
734 }
735 nq -= 2;
736 fill += 2;
737 }
738 if ( nq ) {
739 nq -= 2;
740 q = fill + 2;
741 while ( --nq >= 0 ) *fill++ = *q++;
742 }
743 m += 2;
744 }
745 else if ( *m < *t || t >= xstop ) { m += 2; }
746 else { *fill++ = *t++; *fill++ = *t++; }
747 } while ( m < ystop );
748 while ( t < xstop ) *fill++ = *t++;
749 nq = WORDDIF(fill,subterm);
750 if ( nq > 0 ) {
751 nq += 2;
752 subterm[-1] = nq;
753 }
754 else { fill = subterm; fill -= 2; }
755 }
756/*
757 #] SYMBOLS :
758 #[ DOTPRODUCTS :
759*/
760 else if ( *m == DOTPRODUCT ) {
761 ystop = m + m[1];
762 m += 2;
763 while ( *t > DOTPRODUCT && t < tstop ) {
764 nq = t[1];
765 NCOPY(fill,t,nq);
766 }
767 if ( t >= tstop ) goto SubCoef;
768 if ( *t != DOTPRODUCT ) {
769 m = ystop;
770 goto EndLoop;
771 }
772 *fill++ = DOTPRODUCT;
773 fill++;
774 subterm = fill;
775 xstop = t + t[1];
776 t += 2;
777 do {
778 if ( *m == *t && m[1] == t[1] && t < xstop ) {
779 nt = t[2];
780 mt = m[2];
781 if ( mt >= 2*MAXPOWER ) {
782 if ( CheckWild(BHEAD mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
783 nt -= AN.oldvalue;
784 goto SubsL3;
785 }
786 }
787 else if ( mt <= -2*MAXPOWER ) {
788 if ( CheckWild(BHEAD -mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
789 nt += AN.oldvalue;
790 goto SubsL3;
791 }
792 }
793 else {
794 nt -= mt * power;
795SubsL3: if ( nt ) {
796 *fill++ = *t++;
797 *fill++ = *t;
798 *fill++ = nt;
799 t += 2;
800 }
801 else t += 3;
802 }
803 m += 3;
804 }
805 else if ( *m >= (AM.OffsetVector+WILDOFFSET) ) {
806 while ( t < xstop ) {
807 *fill++ = *t++; *fill++ = *t++; *fill++ = *t++;
808 }
809 oldval1 = 1;
810 goto SubsL4;
811 }
812 else if ( m[1] >= (AM.OffsetVector+WILDOFFSET) ) {
813 while ( *m >= *t && t < xstop ) {
814 *fill++ = *t++; *fill++ = *t++; *fill++ = *t++;
815 }
816 oldval1 = 0;
817SubsL4: nq = WORDDIF(fill,subterm);
818 fill = subterm;
819 while ( nq > 0 ) {
820 if ( ( oldval1 && ( (
821 !CheckWild(BHEAD *m-WILDOFFSET,VECTOVEC,*fill,&newval3)
822 && !CheckWild(BHEAD m[1]-WILDOFFSET,VECTOVEC,fill[1],&newval3)
823 ) || (
824 !CheckWild(BHEAD m[1]-WILDOFFSET,VECTOVEC,*fill,&newval3)
825 && !CheckWild(BHEAD *m-WILDOFFSET,VECTOVEC,fill[1],&newval3)
826 ) ) ) || ( !oldval1 && ( (
827 *m == *fill
828 && !CheckWild(BHEAD m[1]-WILDOFFSET,VECTOVEC,fill[1],&newval3)
829 ) || (
830 !CheckWild(BHEAD m[1]-WILDOFFSET,VECTOVEC,*fill,&newval3)
831 && *m == fill[1] ) ) ) ) {
832 mt = m[2];
833 if ( mt >= 2*MAXPOWER ) {
834 if ( CheckWild(BHEAD mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
835 if ( fill[2] -= AN.oldvalue )
836 goto SubsL5;
837 }
838 }
839 else if ( mt <= -2*MAXPOWER ) {
840 if ( CheckWild(BHEAD -mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
841 if ( fill[2] += AN.oldvalue )
842 goto SubsL5;
843 }
844 }
845 else {
846 if ( fill[2] -= mt * power ) {
847SubsL5: fill += nq;
848 nq = 0;
849 }
850 }
851 m += 3;
852 break;
853 }
854 fill += 3; nq -= 3;
855 }
856 if ( nq ) {
857 nq -= 3;
858 q = fill + 3;
859 while ( --nq >= 0 ) *fill++ = *q++;
860 }
861 }
862 else if ( t >= xstop || *m < *t || ( *m == *t && m[1] < t[1] ) )
863 { m += 3; }
864 else {
865 *fill++ = *t++; *fill++ = *t++; *fill++ = *t++;
866 }
867 } while ( m < ystop );
868 while ( t < xstop ) *fill++ = *t++;
869 nq = WORDDIF(fill,subterm);
870 if ( nq > 0 ) {
871 nq += 2;
872 subterm[-1] = nq;
873 }
874 else { fill = subterm; fill -= 2; }
875 }
876/*
877 #] DOTPRODUCTS :
878 #[ FUNCTIONS :
879*/
880 else if ( *m >= FUNCTION ) {
881 while ( *t >= FUNCTION || *t == SUBEXPRESSION ) {
882 nt = WORDDIF(t,term);
883 for ( mt = 0; mt < AN.RepFunNum; mt += 2 ) {
884 if ( nt == AN.RepFunList[mt] ) break;
885 }
886 if ( mt >= AN.RepFunNum ) {
887 nq = t[1];
888 NCOPY(fill,t,nq);
889 }
890 else {
891 WORD *oldt = 0;
892 if ( *m == GAMMA && m[1] != FUNHEAD+1 ) {
893 oldt = t;
894 if ( ( i = AN.RepFunList[mt+1] ) > 0 ) {
895 *fill++ = GAMMA;
896 *fill++ = i + FUNHEAD+1;
897 FILLFUN(fill)
898 nq = i + 1;
899 t += FUNHEAD;
900 NCOPY(fill,t,nq);
901 }
902 t = oldt;
903 }
904 else if ( ( *t == LEVICIVITA ) || ( *t >= FUNCTION
905 && (functions[*t-FUNCTION].symmetric & ~REVERSEORDER) == ANTISYMMETRIC )
906 ) sign += AN.RepFunList[mt+1];
907 else if ( *m >= FUNCTION+WILDOFFSET
908 && (functions[*m-FUNCTION-WILDOFFSET].symmetric & ~REVERSEORDER) == ANTISYMMETRIC
909 ) sign += AN.RepFunList[mt+1];
910 if ( !PutExpr ) {
911 xstop = t + t[1];
912 t = AN.FullProto;
913 nq = t[1];
914 t[3] = power;
915 NCOPY(fill,t,nq);
916 t = xstop;
917 PutExpr = 1;
918 }
919 else t += t[1];
920 if ( *m == GAMMA && m[1] != FUNHEAD+1 ) {
921 i = oldt[1] - m[1] - i;
922 if ( i > 0 ) {
923 *fill++ = GAMMA;
924 *fill++ = i + FUNHEAD+1;
925 FILLFUN(fill)
926 *fill++ = oldt[FUNHEAD];
927 t = t - i;
928 NCOPY(fill,t,i);
929 }
930 }
931 break;
932 }
933 }
934 m += m[1];
935 }
936/*
937 #] FUNCTIONS :
938 #[ VECTORS :
939*/
940 else if ( *m == VECTOR ) {
941 while ( *t > VECTOR ) {
942 nq = t[1];
943 NCOPY(fill,t,nq);
944 }
945 xstop = t + t[1];
946 ystop = m + m[1];
947 t += 2;
948 m += 2;
949 *fill++ = VECTOR;
950 fill++;
951 subterm = fill;
952 do {
953 if ( *m == *t && m[1] == t[1] ) {
954 m += 2; t += 2;
955 }
956 else if ( *m >= (AM.OffsetVector+WILDOFFSET) ) {
957 while ( t < xstop ) *fill++ = *t++;
958 nq = WORDDIF(fill,subterm);
959 fill = subterm;
960 if ( m[1] < (AM.OffsetIndex+WILDOFFSET) ) {
961 do {
962 if ( m[1] == fill[1] &&
963 !CheckWild(BHEAD *m-WILDOFFSET,VECTOVEC,*fill,&newval3) )
964 break;
965 fill += 2;
966 nq -= 2;
967 } while ( nq > 0 );
968 }
969 else { /* Double wildcard */
970 do {
971 if ( !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,fill[1],&newval3)
972 && !CheckWild(BHEAD *m-WILDOFFSET,VECTOVEC,*fill,&newval3) )
973 break;
974 if ( *fill == oldval1 && fill[1] == AN.oldvalue ) break;
975 fill += 2;
976 nq -= 2;
977 } while ( nq > 0 );
978 }
979 nq -= 2;
980 q = fill + 2;
981 if ( nq > 0 ) { NCOPY(fill,q,nq); }
982 m += 2;
983 }
984 else if ( *m <= *t &&
985 m[1] >= (AM.OffsetIndex + WILDOFFSET) ) {
986 while ( *m == *t && t < xstop )
987 { *fill++ = *t++; *fill++ = *t++; }
988 nq = WORDDIF(fill,subterm);
989 fill = subterm;
990 do {
991 if ( *m == *fill &&
992 !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,fill[1],&newval3) )
993 break;
994 nq -= 2;
995 fill += 2;
996 } while ( nq > 0 );
997 nq -= 2;
998 q = fill + 2;
999 if ( nq > 0 ) { NCOPY(fill,q,nq); }
1000 m += 2;
1001 }
1002 else { *fill++ = *t++; *fill++ = *t++; }
1003 } while ( m < ystop );
1004 while ( t < xstop ) *fill++ = *t++;
1005 nq = WORDDIF(fill,subterm);
1006 if ( nq > 0 ) {
1007 nq += 2;
1008 subterm[-1] = nq;
1009 }
1010 else { fill = subterm; fill -= 2; }
1011 }
1012/*
1013 #] VECTORS :
1014 #[ INDICES :
1015
1016 Currently without wildcards
1017*/
1018 else if ( *m == INDEX ) {
1019 while ( *t > INDEX ) {
1020 nq = t[1];
1021 NCOPY(fill,t,nq);
1022 }
1023 xstop = t + t[1];
1024 ystop = m + m[1];
1025 t += 2;
1026 m += 2;
1027 *fill++ = INDEX;
1028 fill++;
1029 subterm = fill;
1030 do {
1031 if ( *m == *t ) {
1032 m += 1; t += 1;
1033 }
1034 else if ( *m >= (AM.OffsetIndex+WILDOFFSET) ) {
1035 while ( t < xstop ) *fill++ = *t++;
1036 nq = WORDDIF(fill, subterm);
1037 fill = subterm;
1038 do {
1039 if ( !CheckWild(BHEAD *m-WILDOFFSET,INDTOIND,*fill,&newval3) ) {
1040 break;
1041 }
1042 fill += 1;
1043 nq -= 1;
1044 } while ( nq > 0 );
1045 nq -= 1;
1046 if ( nq > 0 ) {
1047 q = fill + 1;
1048 NCOPY(fill,q,nq);
1049 }
1050 m += 1;
1051 }
1052 else {
1053 *fill++ = *t++;
1054 }
1055 } while ( m < ystop );
1056 while ( t < xstop ) *fill++ = *t++;
1057 nq = WORDDIF(fill,subterm);
1058 if ( nq > 0 ) {
1059 nq += 2;
1060 subterm[-1] = nq;
1061 }
1062 else { fill = subterm; fill -= 2; }
1063 }
1064/*
1065 #] INDICES :
1066 #[ DELTAS :
1067*/
1068 else if ( *m == DELTA ) {
1069 while ( *t > DELTA ) {
1070 nq = t[1];
1071 NCOPY(fill,t,nq);
1072 }
1073 xstop = t + t[1];
1074 ystop = m + m[1];
1075 t += 2;
1076 m += 2;
1077 *fill++ = DELTA;
1078 fill++;
1079 subterm = fill;
1080 do {
1081 if ( *t == *m && t[1] == m[1] ) { m += 2; t += 2; }
1082 else if ( *m >= (AM.OffsetIndex+WILDOFFSET) ) { /* Two dummies */
1083 while ( t < xstop ) *fill++ = *t++;
1084/* fill = subterm; */
1085 oldval1 = 1;
1086 goto SubsL6;
1087 }
1088 else if ( m[1] >= (AM.OffsetIndex+WILDOFFSET) ) {
1089 while ( (*m == *t || *m == t[1] ) && ( t < xstop ) ) {
1090 *fill++ = *t++; *fill++ = *t++;
1091 }
1092 oldval1 = 0;
1093SubsL6: nq = WORDDIF(fill,subterm);
1094 fill = subterm;
1095 do {
1096 if ( ( oldval1 && ( (
1097 !CheckWild(BHEAD *m-WILDOFFSET,INDTOIND,*fill,&newval3)
1098 && !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,fill[1],&newval3)
1099 ) || (
1100 !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,*fill,&newval3)
1101 && !CheckWild(BHEAD *m-WILDOFFSET,INDTOIND,fill[1],&newval3)
1102 ) ) ) || ( !oldval1 && ( (
1103 *m == *fill
1104 && !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,fill[1],&newval3)
1105 ) || (
1106 *m == fill[1]
1107 && !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,*fill,&newval3)
1108 ) ) ) ) break;
1109 fill += 2;
1110 nq -= 2;
1111 } while ( nq > 0 );
1112 nq -= 2;
1113 if ( nq > 0 ) {
1114 q = fill + 2;
1115 NCOPY(fill,q,nq);
1116 }
1117 m += 2;
1118 }
1119 else {
1120 *fill++ = *t++; *fill++ = *t++;
1121 }
1122 } while ( m < ystop );
1123 while ( t < xstop ) *fill++ = *t++;
1124 nq = WORDDIF(fill,subterm);
1125 if ( nq > 0 ) {
1126 nq += 2;
1127 subterm[-1] = nq;
1128 }
1129 else { fill = subterm; fill -= 2; }
1130 }
1131/*
1132 #] DELTAS :
1133*/
1134EndLoop:;
1135 } while ( m < mstop ); }
1136 while ( t < tstop ) *fill++ = *t++;
1137SubCoef:
1138 if ( !PutExpr ) {
1139 t = AN.FullProto;
1140 nq = t[1];
1141 t[3] = power;
1142 NCOPY(fill,t,nq);
1143 }
1144 t = tcoef;
1145 nq = ABS(*t);
1146 t = tstop;
1147 NCOPY(fill,t,nq);
1148 nq = WORDDIF(fill,TemTerm);
1149 fill = term;
1150 t = TemTerm;
1151 *fill++ = nq--;
1152 t++;
1153 NCOPY(fill,t,nq);
1154 if ( sign ) {
1155 if ( ( sign & 1 ) != 0 ) fill[-1] = -fill[-1];
1156 }
1157 if ( AT.WorkPointer < fill ) AT.WorkPointer = fill;
1158 AN.RepFunNum = 0;
1159}
1160
1161/*
1162 #] Substitute :
1163 #[ FindSpecial : WORD FindSpecial(term)
1164
1165 Routine to detect symplifications regarding the special functions
1166 exponent, denominator.
1167
1168
1169WORD FindSpecial(WORD *term)
1170{
1171 WORD *t;
1172 WORD *tstop;
1173 t = term; t += *t - 1; tstop = t - ABS(*t) + 1; t = term;
1174 t++;
1175 if ( t < tstop ) { do {
1176 if ( *t == EXPONENT ) {
1177 Exponents can become simpler when:
1178 a: the exponent of an expression becomes an integer.
1179 b: The expression becomes zero.
1180 }
1181 else if ( *t == DENOMINATOR ) {
1182 Denominators can become simpler when:
1183 a: The denominator is a single term without functions.
1184 b: An overall coefficient can be removed.
1185 c: An overall object can be removed.
1186 The task is here to bring the denominator in an unique form.
1187 }
1188 t += *t;
1189 } while ( t < tstop ); }
1190 return(0);
1191}
1192
1193 #] FindSpecial :
1194 #[ FindAll : WORD FindAll(term,pattern,level,par)
1195*/
1196
1197WORD 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 ) {
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 TranferBuffer.
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
WORD * AddRHS(int num, int type)
Definition comtool.c:214
int AddNtoC(int bufnum, int n, WORD *array, int par)
Definition comtool.c:317
WORD NewSort(PHEAD0)
Definition sort.c:592
LONG EndSort(PHEAD WORD *, int)
Definition sort.c:682
WORD Generator(PHEAD WORD *, WORD)
Definition proces.c:3101
WORD TestMatch(PHEAD WORD *term, WORD *level)
Definition pattern.c:97
VOID LowerSortLevel()
Definition sort.c:4727
WORD ** rhs
Definition structs.h:943
WORD ** lhs
Definition structs.h:942
WORD * Pointer
Definition structs.h:941
struct CbUf CBUF