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