FORM v5.0.1-33-gdf7fc94
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.OffsetIndex+WILDOFFSET) ) {
1038 while ( t < xstop ) *fill++ = *t++;
1039 nq = WORDDIF(fill, subterm);
1040 fill = subterm;
1041 do {
1042 if ( !CheckWild(BHEAD *m-WILDOFFSET,INDTOIND,*fill,&newval3) ) {
1043 break;
1044 }
1045 fill += 1;
1046 nq -= 1;
1047 } while ( nq > 0 );
1048 nq -= 1;
1049 if ( nq > 0 ) {
1050 q = fill + 1;
1051 NCOPY(fill,q,nq);
1052 }
1053 m += 1;
1054 }
1055 else {
1056 *fill++ = *t++;
1057 }
1058 } while ( m < ystop );
1059 while ( t < xstop ) *fill++ = *t++;
1060 nq = WORDDIF(fill,subterm);
1061 if ( nq > 0 ) {
1062 nq += 2;
1063 subterm[-1] = nq;
1064 }
1065 else { fill = subterm; fill -= 2; }
1066 }
1067/*
1068 #] INDICES :
1069 #[ DELTAS :
1070*/
1071 else if ( *m == DELTA ) {
1072 while ( *t > DELTA ) {
1073 nq = t[1];
1074 NCOPY(fill,t,nq);
1075 }
1076 xstop = t + t[1];
1077 ystop = m + m[1];
1078 t += 2;
1079 m += 2;
1080 *fill++ = DELTA;
1081 fill++;
1082 subterm = fill;
1083 do {
1084 if ( *t == *m && t[1] == m[1] ) { m += 2; t += 2; }
1085 else if ( *m >= (AM.OffsetIndex+WILDOFFSET) ) { /* Two dummies */
1086 while ( t < xstop ) *fill++ = *t++;
1087/* fill = subterm; */
1088 oldval1 = 1;
1089 goto SubsL6;
1090 }
1091 else if ( m[1] >= (AM.OffsetIndex+WILDOFFSET) ) {
1092 while ( (*m == *t || *m == t[1] ) && ( t < xstop ) ) {
1093 *fill++ = *t++; *fill++ = *t++;
1094 }
1095 oldval1 = 0;
1096SubsL6: nq = WORDDIF(fill,subterm);
1097 fill = subterm;
1098 do {
1099 if ( ( oldval1 && ( (
1100 !CheckWild(BHEAD *m-WILDOFFSET,INDTOIND,*fill,&newval3)
1101 && !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,fill[1],&newval3)
1102 ) || (
1103 !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,*fill,&newval3)
1104 && !CheckWild(BHEAD *m-WILDOFFSET,INDTOIND,fill[1],&newval3)
1105 ) ) ) || ( !oldval1 && ( (
1106 *m == *fill
1107 && !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,fill[1],&newval3)
1108 ) || (
1109 *m == fill[1]
1110 && !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,*fill,&newval3)
1111 ) ) ) ) break;
1112 fill += 2;
1113 nq -= 2;
1114 } while ( nq > 0 );
1115 nq -= 2;
1116 if ( nq > 0 ) {
1117 q = fill + 2;
1118 NCOPY(fill,q,nq);
1119 }
1120 m += 2;
1121 }
1122 else {
1123 *fill++ = *t++; *fill++ = *t++;
1124 }
1125 } while ( m < ystop );
1126 while ( t < xstop ) *fill++ = *t++;
1127 nq = WORDDIF(fill,subterm);
1128 if ( nq > 0 ) {
1129 nq += 2;
1130 subterm[-1] = nq;
1131 }
1132 else { fill = subterm; fill -= 2; }
1133 }
1134/*
1135 #] DELTAS :
1136*/
1137EndLoop:;
1138 } while ( m < mstop ); }
1139 while ( t < tstop ) *fill++ = *t++;
1140SubCoef:
1141 if ( !PutExpr ) {
1142 t = AN.FullProto;
1143 nq = t[1];
1144 t[3] = power;
1145 NCOPY(fill,t,nq);
1146 }
1147 t = tcoef;
1148 nq = ABS(*t);
1149 t = tstop;
1150 NCOPY(fill,t,nq);
1151 nq = WORDDIF(fill,TemTerm);
1152 fill = term;
1153 t = TemTerm;
1154 *fill++ = nq--;
1155 t++;
1156 NCOPY(fill,t,nq);
1157 if ( sign ) {
1158 if ( ( sign & 1 ) != 0 ) fill[-1] = -fill[-1];
1159 }
1160 if ( AT.WorkPointer < fill ) AT.WorkPointer = fill;
1161 AN.RepFunNum = 0;
1162}
1163
1164/*
1165 #] Substitute :
1166 #[ FindSpecial : WORD FindSpecial(term)
1167
1168 Routine to detect simplifications regarding the special functions
1169 exponent, denominator.
1170
1171
1172void FindSpecial(WORD *term)
1173{
1174 WORD *t;
1175 WORD *tstop;
1176 t = term; t += *t - 1; tstop = t - ABS(*t) + 1; t = term;
1177 t++;
1178 if ( t < tstop ) { do {
1179 if ( *t == EXPONENT ) {
1180 Exponents can become simpler when:
1181 a: the exponent of an expression becomes an integer.
1182 b: The expression becomes zero.
1183 }
1184 else if ( *t == DENOMINATOR ) {
1185 Denominators can become simpler when:
1186 a: The denominator is a single term without functions.
1187 b: An overall coefficient can be removed.
1188 c: An overall object can be removed.
1189 The task is here to bring the denominator in an unique form.
1190 }
1191 t += *t;
1192 } while ( t < tstop ); }
1193}
1194
1195 #] FindSpecial :
1196 #[ FindAll : WORD FindAll(term,pattern,level,par)
1197*/
1198
1199int FindAll(PHEAD WORD *term, WORD *pattern, WORD level, WORD *par)
1200{
1201 GETBIDENTITY
1202 WORD *t, *m, *r, *mm, rnum;
1203 WORD *tstop, *mstop, *TwoProto, *vwhere = 0, oldv, oldvv, vv, level2;
1204 WORD v, nq, OffNum = AM.OffsetVector + WILDOFFSET, i, ii = 0, jj;
1205 WORD fromindex, *intens, notflag1 = 0, notflag2 = 0;
1206 CBUF *C;
1207 C = cbuf+AM.rbufnum;
1208 v = pattern[3]; /* The vector to be found */
1209 m = t = term;
1210 m += *m;
1211 m -= ABS(m[-1]);
1212 t++;
1213 if ( t < m ) do {
1214 tstop = t + t[1];
1215 fromindex = 2;
1216/*
1217 #[ VECTOR :
1218*/
1219 if ( *t == VECTOR ) {
1220 r = t;
1221 r += 2;
1222InVect:
1223 while ( r < tstop ) {
1224 oldv = *r;
1225 if ( v >= OffNum ) {
1226 vwhere = AN.FullProto + 3 + SUBEXPSIZE;
1227 if ( vwhere[1] == FROMSET || vwhere[1] == SETTONUM ) {
1228 WORD *afirst, *alast, j;
1229 j = vwhere[3];
1230 if ( j > WILDOFFSET ) { j -= 2*WILDOFFSET; notflag1 = 1; }
1231 else { notflag1 = 0; }
1232 afirst = SetElements + Sets[j].first;
1233 alast = SetElements + Sets[j].last;
1234 ii = 1;
1235 if ( notflag1 == 0 ) {
1236 do {
1237 if ( *afirst == *r ) {
1238 if ( vwhere[1] == SETTONUM ) {
1239 AN.FullProto[8+SUBEXPSIZE] = SYMTONUM;
1240 AN.FullProto[11+SUBEXPSIZE] = ii;
1241 }
1242 else if ( vwhere[4] >= 0 ) {
1243 oldv = *(afirst - Sets[j].first
1244 + Sets[vwhere[4]].first);
1245 }
1246 goto DoVect;
1247 }
1248 ii++;
1249 } while ( ++afirst < alast );
1250 }
1251 else {
1252 do {
1253 if ( *afirst == *r ) break;
1254 } while ( ++afirst < alast );
1255 if ( afirst >= alast ) goto DoVect;
1256 }
1257 }
1258 else goto DoVect;
1259 }
1260 else if ( v == *r ) {
1261DoVect: m = AT.WorkPointer;
1262 tstop = t;
1263 t = term;
1264 mstop = t + *t;
1265 do { *m++ = *t++; } while ( t < tstop );
1266 vwhere = m;
1267 t = AN.FullProto;
1268 nq = t[1];
1269 t[3] = 1;
1270 NCOPY(m,t,nq);
1271 t = tstop;
1272 if ( fromindex == 1 ) m[-1] = FUNNYVEC;
1273 else m[-1] = r[1]; /* The index is always here! */
1274 if ( v >= OffNum ) vwhere[3+SUBEXPSIZE] = oldv;
1275 if ( vwhere[1] > 12+SUBEXPSIZE ) {
1276 vwhere[11+SUBEXPSIZE] = ii;
1277 vwhere[8+SUBEXPSIZE] = SYMTONUM;
1278 }
1279 if ( t[1] > fromindex+2 ) {
1280 *m++ = *t++;
1281 *m++ = *t++ - fromindex;
1282 while ( t < r ) *m++ = *t++;
1283 t += fromindex;
1284 }
1285 else t += t[1];
1286 do { *m++ = *t++; } while ( t < mstop );
1287 *AT.WorkPointer = nq = WORDDIF(m,AT.WorkPointer);
1288 m = AT.WorkPointer;
1289 t = term;
1290 NCOPY(t,m,nq);
1291 AT.WorkPointer = t;
1292 return(1);
1293 }
1294 r += fromindex;
1295 }
1296 }
1297/*
1298 #] VECTOR :
1299 #[ DOTPRODUCT :
1300*/
1301 else if ( *t == DOTPRODUCT ) {
1302 r = t;
1303 r += 2;
1304 do {
1305 if ( ( i = r[2] ) < 0 ) goto NextDot;
1306 if ( *r == r[1] ) { /* p.p */
1307 oldv = *r;
1308 if ( v == *r ) { /* v.v */
1309TwoVec: m = AT.WorkPointer;
1310 tstop = t;
1311 t = term;
1312 mstop = t + *t;
1313 do { *m++ = *t++; } while ( t < tstop );
1314 do {
1315 vwhere = m;
1316 t = AN.FullProto;
1317 nq = t[1];
1318 t[3] = 2;
1319 NCOPY(m,t,nq);
1320 m[-1] = ++AR.CurDum;
1321 if ( v >= OffNum ) vwhere[3+SUBEXPSIZE] = oldv;
1322 } while ( --i > 0 );
1323CopRest: t = tstop;
1324 if ( t[1] > 5 ) {
1325 *m++ = *t++;
1326 *m++ = *t++ - 3;
1327 while ( t < r ) *m++ = *t++;
1328 t += 3;
1329 }
1330 else t += t[1];
1331 do { *m++ = *t++; } while ( t < mstop );
1332 *AT.WorkPointer = nq = WORDDIF(m,AT.WorkPointer);
1333 m = AT.WorkPointer;
1334 t = term;
1335 NCOPY(t,m,nq);
1336 AT.WorkPointer = t;
1337 return(1);
1338 }
1339 else if ( v >= OffNum ) { /* v?.v? */
1340 vwhere = AN.FullProto + 3+SUBEXPSIZE;
1341 if ( vwhere[1] == FROMSET || vwhere[1] == SETTONUM ) {
1342 WORD *afirst, *alast, j;
1343 j = vwhere[3];
1344 if ( j > WILDOFFSET ) { j -= 2*WILDOFFSET; notflag1 = 1; }
1345 else { notflag1 = 0; }
1346 afirst = SetElements + Sets[j].first;
1347 alast = SetElements + Sets[j].last;
1348 ii = 1;
1349 if ( notflag1 == 0 ) {
1350 do {
1351 if ( *afirst == *r ) {
1352 if ( vwhere[1] == SETTONUM ) {
1353 AN.FullProto[8+SUBEXPSIZE] = SYMTONUM;
1354 AN.FullProto[11+SUBEXPSIZE] = ii;
1355 }
1356 else if ( vwhere[4] >= 0 ) {
1357 oldv = *(afirst - Sets[j].first
1358 + Sets[vwhere[4]].first);
1359 }
1360 goto TwoVec;
1361 }
1362 ii++;
1363 } while ( ++afirst < alast );
1364 }
1365 else {
1366 do {
1367 if ( *afirst == *r ) break;
1368 } while ( ++afirst < alast );
1369 if ( afirst >= alast ) goto TwoVec;
1370 }
1371 }
1372 else goto TwoVec;
1373 }
1374 }
1375 else {
1376 if ( v == r[1] ) { r[1] = *r; *r = v; }
1377 oldv = *r;
1378 oldvv = r[1];
1379 if ( v == *r ) {
1380 if ( !par ) { while ( ++level <= AR.Cnumlhs
1381 && C->lhs[level][0] == TYPEIDOLD ) {
1382 m = C->lhs[level];
1383 m += IDHEAD;
1384 if ( m[-IDHEAD+2] == SUBVECTOR ) {
1385 if ( ( vv = m[m[1]+3] ) == r[1] ) {
1386OnePV: TwoProto = AN.FullProto;
1387TwoPV: m = AT.WorkPointer;
1388 tstop = t;
1389 t = term;
1390 mstop = t + *t;
1391 do { *m++ = *t++; } while ( t < tstop );
1392 do {
1393 t = AN.FullProto;
1394 vwhere = m + 3 +SUBEXPSIZE;
1395 nq = t[1];
1396 t[3] = 1;
1397 NCOPY(m,t,nq);
1398 m[-1] = ++AR.CurDum;
1399 if ( v >= OffNum ) *vwhere = oldv;
1400 if ( vwhere[-2-SUBEXPSIZE] > 12+SUBEXPSIZE ) {
1401 vwhere[8] = ii;
1402 vwhere[5] = SYMTONUM;
1403 }
1404 t = TwoProto;
1405 vwhere = m + 3+SUBEXPSIZE;
1406 mm = m;
1407 nq = t[1];
1408 t[3] = 1;
1409 NCOPY(m,t,nq);
1410/*
1411 The next two lines repair a bug. without them it takes twice
1412 the rhs of the first vector.
1413*/
1414 mm[2] = C->lhs[level][IDHEAD+2];
1415 mm[4] = C->lhs[level][IDHEAD+4];
1416 m[-1] = AR.CurDum;
1417 if ( vv >= OffNum ) *vwhere = oldvv;
1418 } while ( --i > 0 );
1419 goto CopRest;
1420 }
1421 else if ( vv > OffNum ) {
1422 vwhere = AN.FullProto + 3+SUBEXPSIZE;
1423 if ( vwhere[1] == FROMSET || vwhere[1] == SETTONUM ) {
1424 WORD *afirst, *alast, j;
1425 j = vwhere[3];
1426 if ( j > WILDOFFSET ) { j -= 2*WILDOFFSET; notflag1 = 1; }
1427 else { notflag1 = 0; }
1428 afirst = SetElements + Sets[j].first;
1429 alast = SetElements + Sets[j].last;
1430 if ( notflag1 == 0 ) {
1431 ii = 1;
1432 do {
1433 if ( *afirst == r[1] ) {
1434 if ( vwhere[1] == SETTONUM ) {
1435 AN.FullProto[8+SUBEXPSIZE] = SYMTONUM;
1436 AN.FullProto[11+SUBEXPSIZE] = ii;
1437 }
1438 else if ( vwhere[4] >= 0 ) {
1439 oldvv = *(afirst - Sets[j].first
1440 + Sets[vwhere[4]].first);
1441 }
1442 goto OnePV;
1443 }
1444 ii++;
1445 } while ( ++afirst < alast );
1446 }
1447 else {
1448 do {
1449 if ( *afirst == *r ) break;
1450 } while ( ++afirst < alast );
1451 if ( afirst >= alast ) goto OnePV;
1452 }
1453 }
1454 else goto OnePV;
1455 }
1456 }
1457 }}
1458/*
1459 v.q with v matching and no match for the q, also
1460 not in following idold statements.
1461 Notice that a following q.p? cannot match.
1462*/
1463 rnum = r[1];
1464OneOnly: m = AT.WorkPointer;
1465 tstop = t;
1466 t = term;
1467 mstop = t + *t;
1468 do { *m++ = *t++; } while ( t < tstop );
1469 vwhere = m;
1470 t = AN.FullProto;
1471 nq = t[1];
1472 t[3] = i;
1473 NCOPY(m,t,nq);
1474 m[-4] = INDTOIND;
1475 m[-1] = rnum;
1476 if ( v >= OffNum ) vwhere[3+SUBEXPSIZE] = oldv;
1477 goto CopRest;
1478 }
1479 else if ( v >= OffNum ) {
1480 vwhere = AN.FullProto + 3+SUBEXPSIZE;
1481 if ( vwhere[1] == FROMSET || vwhere[1] == SETTONUM ) {
1482 WORD *afirst, *alast, *bfirst, *blast, j;
1483 j = vwhere[3];
1484 if ( j > WILDOFFSET ) { j -= 2*WILDOFFSET; notflag1 = 1; }
1485 else { notflag1 = 0; }
1486 afirst = SetElements + Sets[j].first;
1487 alast = SetElements + Sets[j].last;
1488 ii = 1;
1489 if ( notflag1 == 0 ) {
1490 do {
1491 if ( *afirst == *r ) {
1492 if ( vwhere[1] == SETTONUM ) {
1493 AN.FullProto[8+SUBEXPSIZE] = SYMTONUM;
1494 AN.FullProto[11+SUBEXPSIZE] = ii;
1495 }
1496 else if ( vwhere[4] >= 0 ) {
1497 oldv = *(afirst - Sets[j].first
1498 + Sets[vwhere[4]].first);
1499 }
1500Hitlevel1: level2 = level;
1501 do {
1502 if ( !par ) m = C->lhs[level2];
1503 else m = par;
1504 m += IDHEAD;
1505 if ( m[-IDHEAD+2] == SUBVECTOR ) {
1506 if ( ( vv = m[m[1]+3] ) == r[1] )
1507 goto OnePV;
1508 else if ( vv >= OffNum ) {
1509 if ( m[SUBEXPSIZE+4] != FROMSET &&
1510 m[SUBEXPSIZE+4] != SETTONUM ) goto OnePV;
1511 j = m[SUBEXPSIZE+6];
1512 if ( j > WILDOFFSET ) { j -= 2*WILDOFFSET; notflag2 = 1; }
1513 else { notflag2 = 0; }
1514 bfirst = SetElements + Sets[j].first;
1515 blast = SetElements + Sets[j].last;
1516 jj = 1;
1517 if ( notflag2 == 0 ) {
1518 do {
1519 if ( *bfirst == r[1] ) {
1520 if ( m[SUBEXPSIZE+4] == SETTONUM ) {
1521 m[SUBEXPSIZE+8] = SYMTONUM;
1522 m[SUBEXPSIZE+11] = jj;
1523 }
1524 else if ( m[SUBEXPSIZE+7] >= 0 ) {
1525 oldvv = *(bfirst - Sets[j].first
1526 + Sets[m[SUBEXPSIZE+7]].first);
1527 }
1528 goto OnePV;
1529 }
1530 jj++;
1531 } while ( ++bfirst < blast );
1532 }
1533 else {
1534 do {
1535 if ( *bfirst == r[1] ) break;
1536 } while ( ++bfirst < blast );
1537 if ( bfirst >= blast ) goto OnePV;
1538 }
1539 }
1540 }
1541 } while ( ++level2 < AR.Cnumlhs &&
1542 C->lhs[level2][0] == TYPEIDOLD );
1543 rnum = r[1];
1544 goto OneOnly;
1545 }
1546 else if ( *afirst == r[1] ) {
1547 if ( vwhere[1] == SETTONUM ) {
1548 AN.FullProto[8+SUBEXPSIZE] = SYMTONUM;
1549 AN.FullProto[11+SUBEXPSIZE] = ii;
1550 }
1551 else if ( vwhere[4] >= 0 ) {
1552 oldv = *(afirst - Sets[j].first
1553 + Sets[vwhere[4]].first);
1554 }
1555Hitlevel2: level2 = level;
1556 while ( ++level2 < AR.Cnumlhs &&
1557 C->lhs[level2][0] == TYPEIDOLD ) {
1558 if ( !par ) m = C->lhs[level2];
1559 else m = par;
1560 m += IDHEAD;
1561 if ( m[-IDHEAD+2] == SUBVECTOR ) {
1562 if ( ( vv = m[6] ) == *r )
1563 goto OnePV;
1564 else if ( vv >= OffNum ) {
1565 if ( m[SUBEXPSIZE+4] != FROMSET && m[SUBEXPSIZE+4]
1566 != SETTONUM ) {
1567 j = *r;
1568 *r = r[1];
1569 r[1] = j;
1570 goto OnePV;
1571 }
1572 j = m[SUBEXPSIZE+6];
1573 bfirst = SetElements + Sets[j].first;
1574 blast = SetElements + Sets[j].last;
1575 jj = 1;
1576 do {
1577 if ( *bfirst == *r ) {
1578 if ( m[SUBEXPSIZE+4] == SETTONUM ) {
1579 m[SUBEXPSIZE+8] = SYMTONUM;
1580 m[SUBEXPSIZE+11] = jj;
1581 }
1582 else if ( m[SUBEXPSIZE+7] >= 0 ) {
1583 oldvv = *(bfirst - Sets[j].first
1584 + Sets[m[SUBEXPSIZE+7]].first);
1585 }
1586 j = *r;
1587 *r = r[1];
1588 r[1] = j;
1589 j = oldv; oldv = oldvv; oldvv = j;
1590 goto OnePV;
1591 }
1592 jj++;
1593 } while ( ++bfirst < blast );
1594 }
1595 }
1596 }
1597 jj = *r; *r = r[1]; r[1] = jj;
1598 jj = oldv; oldv = oldvv; oldvv = j;
1599 rnum = r[1];
1600 goto OneOnly;
1601 }
1602 ii++;
1603 } while ( ++afirst < alast );
1604 }
1605 else {
1606 do {
1607 if ( *afirst == *r ) break;
1608 } while ( ++afirst < alast );
1609 if ( afirst >= alast ) goto Hitlevel1;
1610 do {
1611 if ( *afirst == r[1] ) break;
1612 } while ( ++afirst < alast );
1613 if ( afirst >= alast ) goto Hitlevel2;
1614 }
1615 }
1616 else { /* Matches twice */
1617 vv = v;
1618 TwoProto = AN.FullProto;
1619 goto TwoPV;
1620 }
1621 }
1622 }
1623NextDot: r += 3;
1624 } while ( r < tstop );
1625 }
1626/*
1627 #] DOTPRODUCT :
1628 #[ LEVICIVITA :
1629*/
1630 else if ( *t == LEVICIVITA ) {
1631 intens = 0;
1632 r = t;
1633 r += FUNHEAD;
1634OneVect:;
1635 while ( r < tstop ) {
1636 oldv = *r;
1637 if ( v >= OffNum && *r < -10 ) {
1638 vwhere = AN.FullProto + 3+SUBEXPSIZE;
1639 if ( vwhere[1] == FROMSET || vwhere[1] == SETTONUM ) {
1640 WORD *afirst, *alast, j;
1641 j = vwhere[3];
1642 if ( j > WILDOFFSET ) { j -= 2*WILDOFFSET; notflag1 = 1; }
1643 else { notflag1 = 0; }
1644 afirst = SetElements + Sets[j].first;
1645 alast = SetElements + Sets[j].last;
1646 ii = 1;
1647 if ( notflag1 == 0 ) {
1648 do {
1649 if ( *afirst == *r ) {
1650 if ( vwhere[1] == SETTONUM ) {
1651 AN.FullProto[8+SUBEXPSIZE] = SYMTONUM;
1652 AN.FullProto[11+SUBEXPSIZE] = ii;
1653 }
1654 else if ( vwhere[4] >= 0 ) {
1655 oldv = *(afirst - Sets[j].first
1656 + Sets[vwhere[4]].first);
1657 }
1658 goto DoVect;
1659 }
1660 ii++;
1661 } while ( ++afirst < alast );
1662 }
1663 else {
1664 do {
1665 if ( *afirst == *r ) break;
1666 } while ( ++afirst < alast );
1667 if ( afirst >= alast ) goto DoVect;
1668 }
1669 }
1670 else goto LeVect;
1671 }
1672 else if ( v == *r ) {
1673LeVect: m = AT.WorkPointer;
1674 mstop = term + *term;
1675 t = term;
1676 *r = ++AR.CurDum;
1677 if ( intens ) *intens = DIRTYSYMFLAG;
1678 do { *m++ = *t++; } while ( t < tstop );
1679 t = AN.FullProto;
1680 nq = t[1];
1681 t[3] = 1;
1682 if ( v >= OffNum ) *vwhere = oldv;
1683 NCOPY(m,t,nq);
1684 m[-1] = AR.CurDum;
1685 t = tstop;
1686 do { *m++ = *t++; } while ( t < mstop );
1687 *AT.WorkPointer = nq = WORDDIF(m,AT.WorkPointer);
1688 m = AT.WorkPointer;
1689 t = term;
1690 NCOPY(t,m,nq);
1691 AT.WorkPointer = t;
1692 return(1);
1693 }
1694 r++;
1695 }
1696 }
1697/*
1698 #] LEVICIVITA :
1699 #[ GAMMA :
1700*/
1701 else if ( *t == GAMMA ) {
1702 intens = 0;
1703 r = t;
1704 r += FUNHEAD+1;
1705 if ( r < tstop ) goto OneVect;
1706 }
1707/*
1708 #] GAMMA :
1709 #[ INDEX :
1710*/
1711 else if ( *t == INDEX ) { /* The 'forgotten' part */
1712 r = t;
1713 r += 2;
1714 fromindex = 1;
1715 goto InVect;
1716 }
1717/*
1718 #] INDEX :
1719 #[ FUNCTION :
1720*/
1721 else if ( *t >= FUNCTION ) {
1722 if ( *t >= FUNCTION
1723 && functions[*t-FUNCTION].spec >= TENSORFUNCTION
1724 && t[1] > FUNHEAD ) {
1725/*
1726 Tensors are linear in their vectors!
1727*/
1728 r = t;
1729 r += FUNHEAD;
1730 intens = t+2;
1731 goto OneVect;
1732 }
1733 }
1734/*
1735 #] FUNCTION :
1736*/
1737 t += t[1];
1738 } while ( t < m );
1739 return(0);
1740}
1741
1742/*
1743 #] FindAll :
1744 #[ TestSelect :
1745
1746 Returns 1 if any of the objects in any of the sets in setp
1747 occur anywhere in the term
1748*/
1749
1750int TestSelect(WORD *term, WORD *setp)
1751{
1752 WORD *tstop, *t, *s, *el, *elstop, *termstop, *tt, n, ns;
1753 GETSTOP(term,tstop);
1754 term += 1;
1755 while ( term < tstop ) {
1756 switch ( *term ) {
1757 case SYMBOL:
1758 n = term[1] - 2;
1759 t = term + 2;
1760 while ( n > 0 ) {
1761 ns = setp[1] - 2;
1762 s = setp + 2;
1763 while ( --ns >= 0 ) {
1764 if ( Sets[*s].type != CSYMBOL ) { s++; continue; }
1765 el = SetElements + Sets[*s].first;
1766 elstop = SetElements + Sets[*s].last;
1767 while ( el < elstop ) {
1768 if ( *el++ == *t ) return(1);
1769 }
1770 s++;
1771 }
1772 n -= 2;
1773 t += 2;
1774 }
1775 break;
1776 case VECTOR:
1777 n = term[1] - 2;
1778 t = term + 2;
1779 while ( n > 0 ) {
1780 ns = setp[1] - 2;
1781 s = setp + 2;
1782 while ( --ns >= 0 ) {
1783 if ( Sets[*s].type != CVECTOR ) { s++; continue; }
1784 el = SetElements + Sets[*s].first;
1785 elstop = SetElements + Sets[*s].last;
1786 while ( el < elstop ) {
1787 if ( *el++ == *t ) return(1);
1788 }
1789 s++;
1790 }
1791 t++;
1792 ns = setp[1] - 2;
1793 s = setp + 2;
1794 while ( --ns >= 0 ) {
1795 if ( Sets[*s].type != CINDEX
1796 && Sets[*s].type != CNUMBER ) { s++; continue; }
1797 el = SetElements + Sets[*s].first;
1798 elstop = SetElements + Sets[*s].last;
1799 while ( el < elstop ) {
1800 if ( *el++ == *t ) return(1);
1801 }
1802 s++;
1803 }
1804 n -= 2;
1805 t++;
1806 }
1807 break;
1808 case INDEX:
1809 n = term[1] - 2;
1810 t = term + 2;
1811 goto dotensor;
1812 case DOTPRODUCT:
1813 n = term[1] - 2;
1814 t = term + 2;
1815 while ( n > 0 ) {
1816 ns = setp[1] - 2;
1817 s = setp + 2;
1818 while ( --ns >= 0 ) {
1819 if ( Sets[*s].type != CVECTOR ) { s++; continue; }
1820 el = SetElements + Sets[*s].first;
1821 elstop = SetElements + Sets[*s].last;
1822 while ( el < elstop ) {
1823 if ( *el++ == *t ) return(1);
1824 }
1825 s++;
1826 }
1827 t++;
1828 ns = setp[1] - 2;
1829 s = setp + 2;
1830 while ( --ns >= 0 ) {
1831 if ( Sets[*s].type != CVECTOR ) { s++; continue; }
1832 el = SetElements + Sets[*s].first;
1833 elstop = SetElements + Sets[*s].last;
1834 while ( el < elstop ) {
1835 if ( *el++ == *t ) return(1);
1836 }
1837 s++;
1838 }
1839 n -= 3;
1840 t += 2;
1841 }
1842 break;
1843 case DELTA:
1844 n = term[1] - 2;
1845 t = term + 2;
1846 goto dotensor;
1847 default:
1848 if ( *term < FUNCTION ) break;
1849 ns = setp[1] - 2;
1850 s = setp + 2;
1851 while ( --ns >= 0 ) {
1852 if ( Sets[*s].type != CFUNCTION ) { s++; continue; }
1853 el = SetElements + Sets[*s].first;
1854 elstop = SetElements + Sets[*s].last;
1855 while ( el < elstop ) {
1856 if ( *el++ == *term ) return(1);
1857 }
1858 s++;
1859 }
1860 if ( functions[*term-FUNCTION].spec > 0 ) {
1861 n = term[1] - FUNHEAD;
1862 t = term + FUNHEAD;
1863dotensor:
1864 while ( n > 0 ) {
1865 ns = setp[1] - 2;
1866 s = setp + 2;
1867 while ( --ns >= 0 ) {
1868 if ( *t < MINSPEC ) {
1869 if ( Sets[*s].type != CVECTOR ) { s++; continue; }
1870 }
1871 else if ( *t >= 0 ) {
1872 if ( Sets[*s].type != CINDEX
1873 && Sets[*s].type != CNUMBER ) { s++; continue; }
1874 }
1875 else { s++; continue; }
1876 el = SetElements + Sets[*s].first;
1877 elstop = SetElements + Sets[*s].last;
1878 while ( el < elstop ) {
1879 if ( *el++ == *t ) return(1);
1880 }
1881 s++;
1882 }
1883 t++;
1884 n--;
1885 }
1886 }
1887 else {
1888 termstop = term + term[1];
1889 tt = term + FUNHEAD;
1890 while ( tt < termstop ) {
1891 if ( *tt < 0 ) {
1892 if ( *tt == -SYMBOL ) {
1893 ns = setp[1] - 2;
1894 s = setp + 2;
1895 while ( --ns >= 0 ) {
1896 if ( Sets[*s].type != CSYMBOL ) { s++; continue; }
1897 el = SetElements + Sets[*s].first;
1898 elstop = SetElements + Sets[*s].last;
1899 while ( el < elstop ) {
1900 if ( *el++ == tt[1] ) return(1);
1901 }
1902 s++;
1903 }
1904 tt += 2;
1905 }
1906 else if ( *tt == -VECTOR || *tt == -MINVECTOR ) {
1907 ns = setp[1] - 2;
1908 s = setp + 2;
1909 while ( --ns >= 0 ) {
1910 if ( Sets[*s].type != CVECTOR ) { s++; continue; }
1911 el = SetElements + Sets[*s].first;
1912 elstop = SetElements + Sets[*s].last;
1913 while ( el < elstop ) {
1914 if ( *el++ == tt[1] ) return(1);
1915 }
1916 s++;
1917 }
1918 tt += 2;
1919 }
1920 else if ( *tt == -INDEX ) {
1921 ns = setp[1] - 2;
1922 s = setp + 2;
1923 while ( --ns >= 0 ) {
1924 if ( Sets[*s].type != CINDEX
1925 && Sets[*s].type != CNUMBER ) { s++; continue; }
1926 el = SetElements + Sets[*s].first;
1927 elstop = SetElements + Sets[*s].last;
1928 while ( el < elstop ) {
1929 if ( *el++ == tt[1] ) return(1);
1930 }
1931 s++;
1932 }
1933 tt += 2;
1934 }
1935 else if ( *tt <= -FUNCTION ) {
1936 ns = setp[1] - 2;
1937 s = setp + 2;
1938 while ( --ns >= 0 ) {
1939 if ( Sets[*s].type != CFUNCTION ) { s++; continue; }
1940 el = SetElements + Sets[*s].first;
1941 elstop = SetElements + Sets[*s].last;
1942 while ( el < elstop ) {
1943 if ( *el++ == -(*tt) ) return(1);
1944 }
1945 s++;
1946 }
1947 tt++;
1948 }
1949 else tt += 2;
1950 }
1951 else {
1952 t = tt + ARGHEAD;
1953 tt += *tt;
1954 while ( t < tt ) {
1955 if ( TestSelect(t,setp) ) return(1);
1956 t += *t;
1957 }
1958 }
1959 }
1960 }
1961 break;
1962 }
1963 term += term[1];
1964 }
1965 return(0);
1966}
1967
1968/*
1969 #] TestSelect :
1970 #[ SubsInAll : void SubsInAll()
1971
1972 This routine takes a match in id,all and stores it away in
1973 the AT.allbufnum 'compiler' buffer, after taking out the pattern.
1974 The main problem here is that id,all usually has (lots of) wildcards
1975 and their assignments are on stack and the difficult ones are in
1976 AT.ebufnum. Popping the stack while looking for more matches would
1977 loose those. Hence we have to copy them into yet another compiler
1978 buffer: AT.aebufnum. Because this may involve many matches and
1979 because the original term has only a limited number of arguments,
1980 it will pay to look for already existing ones in this buffer.
1981 (to be done later).
1982*/
1983
1984void SubsInAll(PHEAD0)
1985{
1986 GETBIDENTITY
1987 WORD *TemTerm;
1988 WORD *t, *m, *term;
1989 WORD *tstop, *mstop, *xstop;
1990 WORD nt, *fill, nq, mt;
1991 WORD *tcoef, i = 0;
1992 WORD PutExpr = 0, sign = 0;
1993/*
1994 We start with building the term in the WorkSpace.
1995 Afterwards we will transfer it to AT.allbufnum.
1996 We have to make sure there is room in the WorkSpace.
1997*/
1998 AT.idallflag = 2;
1999 TemTerm = AT.WorkPointer;
2000 if ( ( (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer*2) ) > AT.WorkTop ) {
2001 MLOCK(ErrorMessageLock);
2002 MesWork();
2003 MUNLOCK(ErrorMessageLock);
2004 Terminate(-1);
2005 }
2006 m = AN.patternbuffer + IDHEAD; m += m[1];
2007 mstop = m + *m;
2008 m++;
2009 term = AN.termbuffer;
2010 tstop = term + *term; tcoef = tstop-1; tstop -= ABS(tstop[-1]);
2011 t = term;
2012 t++;
2013 fill = TemTerm;
2014 fill++;
2015 while ( m < mstop ) {
2016 while ( t < tstop ) {
2017 nt = WORDDIF(t,term);
2018 for ( mt = 0; mt < AN.RepFunNum; mt += 2 ) {
2019 if ( nt == AN.RepFunList[mt] ) break;
2020 }
2021 if ( mt >= AN.RepFunNum ) {
2022 nq = t[1];
2023 NCOPY(fill,t,nq);
2024 }
2025 else {
2026 WORD *oldt = 0;
2027 if ( *m == GAMMA && m[1] != FUNHEAD+1 ) {
2028 oldt = t;
2029 if ( ( i = AN.RepFunList[mt+1] ) > 0 ) {
2030 *fill++ = GAMMA;
2031 *fill++ = i + FUNHEAD+1;
2032 FILLFUN(fill)
2033 nq = i + 1;
2034 t += FUNHEAD;
2035 NCOPY(fill,t,nq);
2036 }
2037 t = oldt;
2038 }
2039 else if ( ( *t == LEVICIVITA ) || ( *t >= FUNCTION
2040 && (functions[*t-FUNCTION].symmetric & ~REVERSEORDER) == ANTISYMMETRIC )
2041 ) sign += AN.RepFunList[mt+1];
2042 else if ( *m >= FUNCTION+WILDOFFSET
2043 && (functions[*m-FUNCTION-WILDOFFSET].symmetric & ~REVERSEORDER) == ANTISYMMETRIC
2044 ) sign += AN.RepFunList[mt+1];
2045 if ( !PutExpr ) {
2046 WORD *pstart = fill, *p, *w, *ww;
2047 xstop = t + t[1];
2048 t = AN.FullProto;
2049 nq = t[1];
2050 t[3] = 1;
2051 NCOPY(fill,t,nq);
2052 t = xstop;
2053 PutExpr = 1;
2054/*
2055 Here we need provisions for keeping wildcard matches
2056 that reside in AT.ebufnum. We will move them to
2057 AT.aebufnum.
2058 Problem: the SUBEXPRESSION assumes automatically
2059 that the compiler buffer is AT.ebufnum. We have to
2060 correct that in TransferBuffer.
2061*/
2062 p = pstart + SUBEXPSIZE;
2063 while ( p < fill ) {
2064 switch ( *p ) {
2065 case SYMTOSUB:
2066 case VECTOSUB:
2067 case INDTOSUB:
2068 case ARGTOARG:
2069 case ARLTOARL:
2070 w = cbuf[AT.ebufnum].rhs[p[3]];
2071 ww = cbuf[AT.ebufnum].rhs[p[3]+1];
2072/*
2073 Here we could search for whether this
2074 object sits in the buffer already.
2075 To be done later.
2076 By the way: ww-w fits inside a WORD.
2077*/
2078 AddRHS(AT.aebufnum,1);
2079 AddNtoC(AT.aebufnum,ww-w,w,11);
2080 p[3] = cbuf[AT.aebufnum].numrhs;
2081 cbuf[AT.aebufnum].rhs[p[3]+1] = cbuf[AT.aebufnum].Pointer;
2082 p += p[1];
2083 break;
2084 case FROMSET:
2085 case SETTONUM:
2086 case LOADDOLLAR:
2087 p += p[1];
2088 break;
2089 default:
2090 p += p[1];
2091 break;
2092 }
2093
2094 }
2095 }
2096 else t += t[1];
2097 if ( *m == GAMMA && m[1] != FUNHEAD+1 ) {
2098 i = oldt[1] - m[1] - i;
2099 if ( i > 0 ) {
2100 *fill++ = GAMMA;
2101 *fill++ = i + FUNHEAD+1;
2102 FILLFUN(fill)
2103 *fill++ = oldt[FUNHEAD];
2104 t = t - i;
2105 NCOPY(fill,t,i);
2106 }
2107 }
2108 break;
2109 }
2110 }
2111 m += m[1];
2112 }
2113 while ( t < tstop ) *fill++ = *t++;
2114 if ( !PutExpr ) {
2115 t = AN.FullProto;
2116 nq = t[1];
2117 t[3] = 1;
2118 NCOPY(fill,t,nq);
2119 }
2120 t = tcoef;
2121 nq = ABS(*t);
2122 t = tstop;
2123 NCOPY(fill,t,nq);
2124 if ( sign ) {
2125 if ( ( sign & 1 ) != 0 ) fill[-1] = -fill[-1];
2126 }
2127 *TemTerm = fill-TemTerm;
2128/*
2129 And now we copy this to AT.allbufnum
2130*/
2131 AddNtoC(AT.allbufnum,TemTerm[0],TemTerm,12);
2132 cbuf[AT.allbufnum].Pointer[0] = 0;
2133 AN.RepFunNum = 0;
2134}
2135
2136/*
2137 #] SubsInAll :
2138 #[ TransferBuffer :
2139
2140 Adds the whole content of a (compiler)buffer to another buffer.
2141 In spectator we have an expression in the RHS that needs the
2142 wildcard resolutions adapted by an offset.
2143*/
2144
2145void TransferBuffer(int from,int to,int spectator)
2146{
2147 CBUF *C = cbuf + spectator;
2148 CBUF *Cf = cbuf + from;
2149 CBUF *Ct = cbuf + to;
2150 int offset = Ct->numrhs;
2151 LONG i;
2152 WORD *t, *tt, *ttt, *tstop, size;
2153 for ( i = 1; i <= Cf->numrhs; i++ ) {
2154 size = Cf->rhs[i+1]-Cf->rhs[i];
2155 AddRHS(to,1);
2156 AddNtoC(to,size,Cf->rhs[i],13);
2157 }
2158 Ct->rhs[Ct->numrhs+1] = Ct->Pointer;
2159 Cf->numrhs = 0;
2160/*
2161 Now we have to update the 'pointers' in the spectator.
2162*/
2163 t = C->rhs[C->numrhs];
2164 while ( *t ) {
2165 tt = t+1; t += *t;
2166 tstop = t-ABS(t[-1]);
2167 while ( tt < tstop ) {
2168 if ( *tt == SUBEXPRESSION ) {
2169 ttt = tt+SUBEXPSIZE; tt += tt[1];
2170 while ( ttt < tt ) {
2171 switch ( *ttt ) {
2172 case SYMTOSUB:
2173 case VECTOSUB:
2174 case INDTOSUB:
2175 case ARGTOARG:
2176 case ARLTOARL:
2177 ttt[3] += offset;
2178 break;
2179 default:
2180 break;
2181 }
2182 ttt += 4;
2183 }
2184 }
2185 else tt += tt[1];
2186 }
2187 }
2188}
2189
2190/*
2191 #] TransferBuffer :
2192 #[ TakeIDfunction :
2193*/
2194
2195#define PutInBuffers(pow) \
2196 AddRHS(AT.ebufnum,1); \
2197 *out++ = SUBEXPRESSION; \
2198 *out++ = SUBEXPSIZE; \
2199 *out++ = C->numrhs; \
2200 *out++ = pow; \
2201 *out++ = AT.ebufnum; \
2202 FILLSUB(out) \
2203 r = AT.pWorkSpace[rhs+i]; \
2204 if ( *r > 0 ) { \
2205 oldinr = r[*r]; r[*r] = 0; \
2206 AddNtoC(AT.ebufnum,(*r+1-ARGHEAD),(r+ARGHEAD),14); \
2207 r[*r] = oldinr; \
2208 } \
2209 else { \
2210 ToGeneral(r,buffer,1); \
2211 buffer[buffer[0]] = 0; \
2212 AddNtoC(AT.ebufnum,buffer[0]+1,buffer,15); \
2213 }
2214
2215int TakeIDfunction(PHEAD WORD *term)
2216{
2217 WORD *tstop, *t, *r, *m, *f, *nextf, *funstop, *left, *l, *newterm;
2218 WORD *out, oldinr, pow;
2219 WORD buffer[20];
2220 int i, ii, j, numsub, numfound = 0, first;
2221 LONG lhs,rhs;
2222 CBUF *C;
2223 GETSTOP(term,tstop);
2224 for ( t = term+1; t < tstop; t += t[1] ) { if ( *t == IDFUNCTION ) break; }
2225 if ( t >= tstop ) return(0);
2226/*
2227 Step 1: test validity
2228*/
2229 funstop = t + t[1]; f = t + FUNHEAD;
2230 left = term + *term;
2231 l = left+1; numsub = 0;
2232 while ( f < funstop ) {
2233 nextf = f; NEXTARG(nextf)
2234 if ( nextf >= funstop ) { return(0); } /* odd number of arguments */
2235 if ( *f == -SYMBOL ) { *l++ = SYMBOL; *l++ = 4; *l++ = f[1]; *l++ = 1; }
2236 else if ( *f < -FUNCTION ) { *l++ = *f; *l++ = FUNHEAD; FILLFUN(l) }
2237 else if ( *f > 0 ) {
2238 if ( *f != f[ARGHEAD]+ARGHEAD ) goto noaction;
2239 if ( nextf[-1] != 3 || nextf[-2] != 1 || nextf[-3] != 1 ) goto noaction;
2240 if ( f[ARGHEAD] <= 4 ) goto noaction;
2241 if ( f[ARGHEAD] != f[ARGHEAD+2]+4 ) goto noaction;
2242 if ( f[ARGHEAD] == 8 && f[ARGHEAD+1] == SYMBOL ) {
2243 for ( i = 0; i < 4; i++ ) *l++ = f[ARGHEAD+1+i];
2244 }
2245 else if ( f[ARGHEAD] == 9 && f[ARGHEAD+1] == DOTPRODUCT ) {
2246 for ( i = 0; i < 5; i++ ) *l++ = f[ARGHEAD+1+i];
2247 }
2248 else if ( f[ARGHEAD+1] >= FUNCTION ) {
2249 for ( i = 0; i < f[ARGHEAD+1]-4; i++ ) *l++ = f[ARGHEAD+1+i];
2250 }
2251 else goto noaction;
2252 }
2253 else goto noaction;
2254 numsub++;
2255 f = nextf;
2256 NEXTARG(f)
2257 }
2258 C = cbuf+AT.ebufnum;
2259 AT.WorkPointer = l;
2260 *left = l-left;
2261/*
2262 Put the pointers to the lhs and the rhs in the pointer workspace
2263*/
2264 WantAddPointers(2*numsub);
2265 lhs = AT.pWorkPointer;
2266 rhs = lhs+numsub;
2267 AT.pWorkPointer = rhs+numsub;
2268 f = t + FUNHEAD; l = left+1;
2269 for ( i = 0; i < numsub; i++ ) {
2270 AT.pWorkSpace[lhs+i] = l; l += l[1];
2271 NEXTARG(f);
2272 AT.pWorkSpace[rhs+i] = f;
2273 NEXTARG(f);
2274 }
2275/*
2276 Take out the patterns and replace them by SUBEXPRESSIONs pointing at
2277 the e buffer. We put the resulting term above the left sides.
2278 Note that we take out only the first id_ if there is more than one!
2279*/
2280 first = 1;
2281 t = term+1; newterm = AT.WorkPointer; out = newterm+1;
2282 while ( t < tstop ) {
2283 if ( *t == IDFUNCTION && first ) { first = 0; t += t[1]; continue; }
2284 if ( *t >= FUNCTION ) {
2285 for ( i = 0; i < numsub; i++ ) {
2286 m = AT.pWorkSpace[lhs+i];
2287 if ( *m != *t ) continue;
2288 for ( j = 1; j < t[1]; j++ ) {
2289 if ( m[j] != t[j] ) break;
2290 }
2291 if ( j != t[1] ) continue;
2292 numfound++;
2293/*
2294 We have a match! Set up a SUBEXPRESSION subterm and put the
2295 corresponding rhs in the eBuffer.
2296*/
2297 PutInBuffers(1)
2298 t += t[1];
2299 }
2300 if ( i == numsub ) { /* no match. Just copy to output. */
2301 j = t[1]; NCOPY(out,t,j)
2302 }
2303 }
2304 else if ( *t == SYMBOL ) {
2305 for ( i = 0; i < numsub; i++ ) {
2306 m = AT.pWorkSpace[lhs+i];
2307 if ( *m != SYMBOL ) continue;
2308 for ( ii = 2; ii < t[1]; ii += 2 ) {
2309 if ( m[2] != t[ii] ) continue;
2310 pow = t[ii+1]/m[3];
2311 if ( pow <= 0 ) continue;
2312 t[ii+1] = t[ii+1]%m[3];
2313 numfound++;
2314/*
2315 Create the proper rhs in the eBuffer and set up a
2316 SUBEXPRESSION subterm.
2317*/
2318 PutInBuffers(pow)
2319 }
2320 }
2321/*
2322 Now we copy whatever remains of the SYMBOL subterm to the output
2323*/
2324 m = out; *out++ = t[0]; *out++ = t[1];
2325 for ( ii = 2; ii < t[1]; ii += 2 ) {
2326 if ( t[ii+1] ) { *out++ = t[ii]; *out++ = t[ii+1]; }
2327 }
2328 m[1] = out-m;
2329 if ( m[1] == 2 ) out = m;
2330 t += t[1];
2331 }
2332 else if ( *t == DOTPRODUCT ) {
2333 for ( i = 0; i < numsub; i++ ) {
2334 m = AT.pWorkSpace[lhs+i];
2335 if ( *m != DOTPRODUCT ) continue;
2336 for ( ii = 2; ii < t[1]; ii += 3 ) {
2337 if ( m[2] != t[ii] || m[3] != t[ii+1] ) continue;
2338 pow = t[ii+2]/m[4];
2339 if ( pow <= 0 ) continue;
2340 t[ii+2] = t[ii+2]%m[4];
2341 numfound++;
2342/*
2343 Create the proper rhs in the eBuffer and set up a
2344 SUBEXPRESSION subterm.
2345*/
2346 PutInBuffers(pow)
2347 }
2348 }
2349/*
2350 Now we copy whatever remains of the DOTPRODUCT subterm to the output
2351*/
2352 m = out; *out++ = t[0]; *out++ = t[1];
2353 for ( ii = 2; ii < t[1]; ii += 3 ) {
2354 if ( t[ii+2] ) { *out++ = t[ii]; *out++ = t[ii+1]; *out++ = t[ii+2]; }
2355 }
2356 m[1] = out-m;
2357 if ( m[1] == 2 ) out = m;
2358 t += t[1];
2359 }
2360 else {
2361 j = t[1]; NCOPY(out,t,j)
2362 }
2363 }
2364/*
2365 Copy the coefficient and set the size.
2366*/
2367 t = tstop; r = term+*term; while ( t < r ) *out++ = *t++;
2368 *newterm = out-newterm;
2369/*
2370 Finally we move the new term over the original term.
2371*/
2372 i = *newterm;
2373 t = term; r = newterm; NCOPY(t,r,i)
2374/*
2375 At this point we can return and if the calling Generator jumps back to
2376 its start, TestSub can take care of the expansions of SUBEXPRESSIONs.
2377*/
2378 AT.pWorkPointer = lhs;
2379 AT.WorkPointer = t;
2380 return(numfound);
2381noaction:
2382 return(0);
2383}
2384
2385/*
2386 #] TakeIDfunction :
2387 #] Patterns :
2388*/
2389
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:3275
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