FORM  4.1
pattern.c
Go to the documentation of this file.
1 
12 /* #[ License : */
13 /*
14  * Copyright (C) 1984-2013 J.A.M. Vermaseren
15  * When using this file you are requested to refer to the publication
16  * J.A.M.Vermaseren "New features of FORM" math-ph/0010025
17  * This is considered a matter of courtesy as the development was paid
18  * for by FOM the Dutch physics granting agency and we would like to
19  * be able to track its scientific use to convince FOM of its value
20  * for the community.
21  *
22  * This file is part of FORM.
23  *
24  * FORM is free software: you can redistribute it and/or modify it under the
25  * terms of the GNU General Public License as published by the Free Software
26  * Foundation, either version 3 of the License, or (at your option) any later
27  * version.
28  *
29  * FORM is distributed in the hope that it will be useful, but WITHOUT ANY
30  * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
31  * FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
32  * details.
33  *
34  * You should have received a copy of the GNU General Public License along
35  * with FORM. If not, see <http://www.gnu.org/licenses/>.
36  */
37 /* #] License : */
38 /*
39 !!! Notice the change in OnePV in FindAll (7-may-2008 JV).
40 
41  #[ Includes : pattern.c
42 */
43 
44 #include "form3.h"
45 
46 /*
47  #] Includes :
48  #[ Patterns :
49  #[ Rules :
50 
51  There are several rules governing the allowable replacements.
52  1: Multi with anything but symbols or dotproducts reverts
53  to many.
54  2: Each symbol can have only one (wildcard) power, so
55  x^2*x^n? is illegal.
56  3: when a single vector is used it replaces all occurences
57  of the vector. Therefore q*q(mu) or q*q(mu) cannot occur.
58  Also q*q cannot be done.
59  4: Loose vector elements are replaced with p(mu), dotproducts
60  with p?.q.
61  5: p?.q? is allowed.
62  6: x^n? can revert to n = 0 if there is no power of x.
63  7: x?^n? must match some x. There could be an ambiguity otherwise.
64 
65  #] Rules :
66  #[ TestMatch : WORD TestMatch(term,level)
67 */
68 
97 WORD TestMatch(PHEAD WORD *term, WORD *level)
98 {
99  GETBIDENTITY
100  WORD *ll, *m, *w, *llf, *OldWork, *StartWork, *ww, *mm;
101  WORD power = 0, match = 0, /* *rep, */ i, msign = 0;
102  int numdollars = 0, protosize;
103  CBUF *C = cbuf+AM.rbufnum;
104  do {
105 /*
106  #[ Preliminaries :
107 */
108  ll = C->lhs[*level];
109  if ( *ll == TYPEEXPRESSION ) {
110 /*
111  Expressions are not subject to anything.
112 */
113  return(0);
114  }
115  else if ( *ll == TYPEREPEAT ) {
116  *++AN.RepPoint = 0;
117  return(0); /* Will force the next level */
118  }
119  else if ( *ll == TYPEENDREPEAT ) {
120  if ( *AN.RepPoint ) {
121  AN.RepPoint[-1] = 1; /* Mark the higher level as dirty */
122  *AN.RepPoint = 0;
123  *level = ll[2]; /* Level to jump back to */
124  }
125  else {
126  AN.RepPoint--;
127  if ( AN.RepPoint < AT.RepCount ) {
128  MLOCK(ErrorMessageLock);
129  MesPrint("Internal problems with REPEAT count");
130  MUNLOCK(ErrorMessageLock);
131  Terminate(-1);
132  }
133  }
134  return(0); /* Force the next level */
135  }
136  else if ( *ll == TYPEOPERATION ) {
137 /*
138  Operations have always their own level.
139 */
140  if ( (*(FG.OperaFind[ll[2]]))(BHEAD term,ll) ) return(-1);
141  else return(0);
142  }
143 /*
144  #] Preliminaries :
145 */
146  OldWork = AT.WorkPointer;
147  if ( AT.WorkPointer < term + *term ) AT.WorkPointer = term + *term;
148  ww = AT.WorkPointer;
149 #ifdef WITHPTHREADS
150 /*
151  Here we need to make a copy of the subexpression object because we
152  will be writing the values of the wildcards in it.
153  Originally we copied it into the private version of the compiler buffer
154  that is used for scratch space (ebufnum). This caused errors in the
155  routines like ScanFunctions when the ebufnum Buffer was expanded
156  and inpat was still pointing at the old Buffer. This expansion
157  could be done in AddWild and hence cannot be fixed at > 100 places.
158  The solution is to use AN.patternbuffer (JV 16-mar-2009).
159 */
160  {
161  WORD *ta = ll, *ma;
162  int ja = ta[1];
163 /*
164  New code (16-mar-2009) JV
165 */
166  if ( ( ja + 2 ) > AN.patternbuffersize ) {
167  if ( AN.patternbuffer ) M_free(AN.patternbuffer,"AN.patternbuffer");
168  AN.patternbuffersize = 2 * ja + 2;
169  AN.patternbuffer = (WORD *)Malloc1(AN.patternbuffersize * sizeof(WORD),
170  "AN.patternbuffer");
171  }
172  ma = AN.patternbuffer;
173  m = ma + IDHEAD;
174  NCOPY(ma,ta,ja);
175  *ma = 0;
176 /*
177  Old code
178 
179  WORD *ma = AddRHS(AT.ebufnum,1);
180  CBUF *CC = cbuf+AT.ebufnum;
181  if ( ( ma+ja+2 ) > CC->Top ) {
182  ma = DoubleCbuffer(AT.ebufnum,ma);
183  }
184  m = ma + IDHEAD;
185  NCOPY(ma,ta,ja);
186  *ma++ = 0;
187  CC->rhs[CC->numrhs+1] = ma;
188  CC->Pointer = ma;
189 */
190  }
191 #else
192  m = ll + IDHEAD;
193 #endif
194  AN.FullProto = m;
195  AN.WildValue = w = m + SUBEXPSIZE;
196  protosize = IDHEAD + m[1];
197  m += m[1];
198  AN.WildStop = m;
199  StartWork = ww;
200 /*
201  #[ Expand dollars :
202 */
203  if ( ( ll[4] & 1 ) != 0 ) { /* We have at least one dollar in the pattern */
204  WORD oldRepPoint = *AN.RepPoint, olddefer = AR.DeferFlag;
205  AR.Eside = LHSIDEX;
206 /*
207  Copy into WorkSpace. This means that AN.patternbuffer will be free.
208 */
209  ww = AT.WorkPointer; i = m[0]; mm = m;
210  NCOPY(ww,mm,i);
211  *StartWork += 3;
212  *ww++ = 1; *ww++ = 1; *ww++ = 3;
213  AT.WorkPointer = ww;
214  AR.DeferFlag = 0;
215  NewSort(BHEAD0);
216  if ( Generator(BHEAD StartWork,AR.Cnumlhs) ) {
217  LowerSortLevel();
218  AT.WorkPointer = OldWork;
219  AR.DeferFlag = olddefer;
220  return(-1);
221  }
222  AT.WorkPointer = ww;
223  if ( EndSort(BHEAD ww,0) < 0 ) {}
224  AR.DeferFlag = olddefer;
225  if ( *ww == 0 || *(ww+*ww) != 0 ) {
226  if ( AP.lhdollarerror == 0 ) {
227 /*
228  If race condition we just get more error messages
229 */
230  MLOCK(ErrorMessageLock);
231  MesPrint("&LHS must be one term");
232  MUNLOCK(ErrorMessageLock);
233  AP.lhdollarerror = 1;
234  }
235  AT.WorkPointer = OldWork;
236  return(-1);
237  }
238  m = ww; ww = m + *m;
239  if ( m[*m-1] < 0 ) { msign = 1; m[*m-1] = -m[*m-1]; }
240  if ( *ww || m[*m-1] != 3 || m[*m-2] != 1 || m[*m-3] != 1 ) {
241  MLOCK(ErrorMessageLock);
242  MesPrint("Dollar variable develops into an illegal pattern in id-statement");
243  MUNLOCK(ErrorMessageLock);
244  return(-1);
245  }
246  *m -= m[*m-1];
247  if ( ( *m + 1 + protosize ) > AN.patternbuffersize ) {
248  if ( AN.patternbuffer ) M_free(AN.patternbuffer,"AN.patternbuffer");
249  AN.patternbuffersize = 2 * (*m) + 2 + protosize;
250  AN.patternbuffer = (WORD *)Malloc1(AN.patternbuffersize * sizeof(WORD),
251  "AN.patternbuffer");
252  mm = ll; ww = AN.patternbuffer; i = protosize;
253  NCOPY(ww,mm,i);
254  AN.FullProto = AN.patternbuffer + IDHEAD;
255  AN.WildValue = w = AN.FullProto + SUBEXPSIZE;
256  AN.WildStop = AN.patternbuffer + protosize;
257  }
258  mm = AN.patternbuffer + protosize;
259  i = *m;
260  NCOPY(mm,m,i);
261  m = AN.patternbuffer + protosize;
262  AR.Eside = RHSIDE;
263  *mm = 0;
264 
265  AT.WorkPointer = ww = StartWork;
266  *AN.RepPoint = oldRepPoint;
267  }
268 /*
269  #] Expand dollars :
270 
271  AT.WorkPointer = ww = term + *term;
272 */
273  ClearWild(BHEAD0);
274  while ( w < AN.WildStop ) {
275  if ( *w == LOADDOLLAR ) numdollars++;
276  w += w[1];
277  }
278  AN.RepFunNum = 0;
279  /* rep = */ AN.RepFunList = AT.WorkPointer;
280  AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer/2);
281  if ( AT.WorkPointer >= AT.WorkTop ) {
282  MLOCK(ErrorMessageLock);
283  MesWork();
284  MUNLOCK(ErrorMessageLock);
285  return(-1);
286  }
287  AN.DisOrderFlag = ll[2] & SUBDISORDER;
288  AN.nogroundlevel = 0;
289  switch ( ll[2] & SUBMASK ) {
290  case SUBONLY :
291  /* Must be an exact match */
292  AN.UseFindOnly = 1; AN.ForFindOnly = 0;
293  if ( FindRest(BHEAD term,m) && ( AN.UsedOtherFind ||
294  FindOnly(BHEAD term,m) ) ) {
295  power = 1;
296  if ( msign ) term[term[0]-1] = -term[term[0]-1];
297  }
298  else power = 0;
299  break;
300  case SUBMANY :
301  AN.UseFindOnly = -1;
302  if ( ( power = FindRest(BHEAD term,m) ) > 0 ) {
303  if ( ( power = FindOnce(BHEAD term,m) ) > 0 ) {
304  AN.UseFindOnly = 0;
305  do {
306  if ( msign ) term[term[0]-1] = -term[term[0]-1];
307  Substitute(BHEAD term,m,1);
308  if ( numdollars ) {
309  WildDollars(BHEAD0);
310  numdollars = 0;
311  }
312  if ( ww < term+term[0] ) ww = term+term[0];
313  ClearWild(BHEAD0);
314  AT.WorkPointer = ww;
315 /* if ( rep < ww ) {*/
316  AN.RepFunNum = 0;
317  /* rep = */ AN.RepFunList = ww;
318  AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer/2);
319  if ( AT.WorkPointer >= AT.WorkTop ) {
320  MLOCK(ErrorMessageLock);
321  MesWork();
322  MUNLOCK(ErrorMessageLock);
323  return(-1);
324  }
325 /*
326  }
327  else {
328  AN.RepFunList = rep;
329  AN.RepFunNum = 0;
330  }
331 */
332  AN.nogroundlevel = 0;
333  } while ( FindRest(BHEAD term,m) && ( AN.UsedOtherFind ||
334  FindOnce(BHEAD term,m) ) );
335  match = 1;
336  }
337  else if ( power < 0 ) {
338  do {
339  if ( msign ) term[term[0]-1] = -term[term[0]-1];
340  Substitute(BHEAD term,m,1);
341  if ( numdollars ) {
342  WildDollars(BHEAD0);
343  numdollars = 0;
344  }
345  if ( ww < term+term[0] ) ww = term+term[0];
346  ClearWild(BHEAD0);
347  AT.WorkPointer = ww;
348 /* if ( rep < ww ) { */
349  AN.RepFunNum = 0;
350  /* rep = */ AN.RepFunList = ww;
351  AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer/2);
352  if ( AT.WorkPointer >= AT.WorkTop ) {
353  MLOCK(ErrorMessageLock);
354  MesWork();
355  MUNLOCK(ErrorMessageLock);
356  return(-1);
357  }
358 /*
359  }
360  else {
361  AN.RepFunList = rep;
362  AN.RepFunNum = 0;
363  }
364 */
365  } while ( FindRest(BHEAD term,m) );
366  match = 1;
367  }
368  }
369  else if ( power < 0 ) {
370  if ( FindOnce(BHEAD term,m) ) {
371  do {
372  if ( msign ) term[term[0]-1] = -term[term[0]-1];
373  Substitute(BHEAD term,m,1);
374  if ( numdollars ) {
375  WildDollars(BHEAD0);
376  numdollars = 0;
377  }
378  if ( ww < term+term[0] ) ww = term+term[0];
379  ClearWild(BHEAD0);
380  AT.WorkPointer = ww;
381 /* if ( rep < ww ) { */
382  AN.RepFunNum = 0;
383  /* rep = */ AN.RepFunList = ww;
384  AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer/2);
385  if ( AT.WorkPointer >= AT.WorkTop ) {
386  MLOCK(ErrorMessageLock);
387  MesWork();
388  MUNLOCK(ErrorMessageLock);
389  return(-1);
390  }
391 /*
392  }
393  else {
394  AN.RepFunList = rep;
395  AN.RepFunNum = 0;
396  }
397 */
398  } while ( FindOnce(BHEAD term,m) );
399  match = 1;
400  }
401  }
402 #if IDHEAD > 3
403  if ( match ) {
404  if ( ( ll[2] & SUBAFTER ) != 0 ) *level = AC.Labels[ll[3]];
405  }
406  else {
407  if ( ( ll[2] & SUBAFTERNOT ) != 0 ) *level = AC.Labels[ll[3]];
408  }
409 #endif
410 /* AT.WorkPointer = AN.RepFunList;
411  return(match); */
412  goto nextlevel;
413  case SUBONCE :
414  AN.UseFindOnly = 0;
415  if ( FindRest(BHEAD term,m) && ( AN.UsedOtherFind || FindOnce(BHEAD term,m) ) ) {
416  power = 1;
417  if ( msign ) term[term[0]-1] = -term[term[0]-1];
418  }
419  else power = 0;
420  break;
421  case SUBMULTI :
422  power = FindMulti(BHEAD term,m);
423  if ( ( power & 1 ) != 0 && msign ) term[term[0]-1] = -term[term[0]-1];
424  break;
425  case SUBALL :
426  while ( ( power = FindAll(BHEAD term,m,*level,(WORD *)0) ) != 0 ) {
427  if ( ( power & 1 ) != 0 && msign ) term[term[0]-1] = -term[term[0]-1];
428  match = 1;
429  }
430  break;
431  case SUBSELECT :
432  llf = ll + IDHEAD; llf += llf[1]; llf += *llf;
433  AN.UseFindOnly = 1; AN.ForFindOnly = llf;
434  if ( FindRest(BHEAD term,m) && ( AN.UsedOtherFind || FindOnly(BHEAD term,m) ) ) {
435  if ( msign ) term[term[0]-1] = -term[term[0]-1];
436 /*
437  The following code needs to be hacked a bit to allow for
438  all types of sets and for occurrence anywhere in the term
439  The code at the end of FindOnly is a bit mysterious.
440 */
441  if ( llf[1] > 2 ) {
442  WORD *t1, *t2;
443  if ( *term > AN.sizeselecttermundo ) {
444  if ( AN.selecttermundo ) M_free(AN.selecttermundo,"AN.selecttermundo");
445  AN.sizeselecttermundo = *term +10;
446  AN.selecttermundo = (WORD *)Malloc1(
447  AN.sizeselecttermundo*sizeof(WORD),"AN.selecttermundo");
448  }
449  t1 = term; t2 = AN.selecttermundo; i = *term;
450  NCOPY(t2,t1,i);
451  }
452  power = 1;
453  Substitute(BHEAD term,m,power);
454  if ( llf[1] > 2 ) {
455  if ( TestSelect(term,llf) ) {
456  WORD *t1, *t2;
457  power = 0;
458  t1 = term; t2 = AN.selecttermundo; i = *t2;
459  NCOPY(t1,t2,i);
460 #if IDHEAD > 3
461  if ( ( ll[2] & SUBAFTERNOT ) != 0 ) {
462  *level = AC.Labels[ll[3]];
463  }
464 #endif
465  goto nextlevel;
466  }
467  }
468  if ( numdollars ) {
469  WildDollars(BHEAD0);
470  numdollars = 0;
471  }
472  match = 1;
473 #if IDHEAD > 3
474  if ( ( ll[2] & SUBAFTER ) != 0 ) {
475  *level = AC.Labels[ll[3]];
476  }
477 #endif
478  }
479  else {
480 #if IDHEAD > 3
481  if ( ( ll[2] & SUBAFTERNOT ) != 0 ) {
482  *level = AC.Labels[ll[3]];
483  }
484 #endif
485  power = 0;
486  }
487  goto nextlevel;
488  default :
489  break;
490  }
491  if ( power ) {
492  Substitute(BHEAD term,m,power);
493  if ( numdollars ) {
494  WildDollars(BHEAD0);
495  numdollars = 0;
496  }
497  match = 1;
498 #if IDHEAD > 3
499  if ( ( ll[2] & SUBAFTER ) != 0 ) {
500  *level = AC.Labels[ll[3]];
501  }
502 #endif
503  }
504  else {
505  AT.WorkPointer = AN.RepFunList;
506 #if IDHEAD > 3
507  if ( ( ll[2] & SUBAFTERNOT ) != 0 ) {
508  *level = AC.Labels[ll[3]];
509  }
510 #endif
511  }
512 nextlevel:;
513  } while ( (*level)++ < AR.Cnumlhs && C->lhs[*level][0] == TYPEIDOLD );
514  (*level)--;
515  AT.WorkPointer = AN.RepFunList;
516  return(match);
517 }
518 
519 /*
520  #] TestMatch :
521  #[ Substitute : VOID Substitute(term,pattern,power)
522 */
523 
524 VOID Substitute(PHEAD WORD *term, WORD *pattern, WORD power)
525 {
526  GETBIDENTITY
527  WORD *TemTerm;
528  WORD *t, *m;
529  WORD *tstop, *mstop;
530  WORD *xstop, *ystop;
531  WORD nt, *fill, nq, mt;
532  WORD *q, *subterm, *tcoef, oldval1 = 0, newval3, i = 0;
533  WORD PutExpr = 0, sign = 0;
534  TemTerm = AT.WorkPointer;
535  if ( ( (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer*2) ) > AT.WorkTop ) {
536  MLOCK(ErrorMessageLock);
537  MesWork();
538  MUNLOCK(ErrorMessageLock);
539  Terminate(-1);
540  }
541  m = pattern;
542  mstop = m + *m;
543  m++;
544  t = term;
545  t += *term - 1;
546  tcoef = t;
547  tstop = t - ABS(*t) + 1;
548  t = term;
549  t++;
550  fill = TemTerm;
551  fill++;
552  if ( m < mstop ) { do {
553 /*
554  #[ SYMBOLS :
555 */
556  if ( *m == SYMBOL ) {
557  ystop = m + m[1];
558  m += 2;
559  while ( *t != SYMBOL && t < tstop ) {
560  nq = t[1];
561  NCOPY(fill,t,nq);
562  }
563  if ( t >= tstop ) goto SubCoef;
564  *fill++ = SYMBOL;
565  fill++;
566  subterm = fill;
567  xstop = t + t[1];
568  t += 2;
569  do {
570  if ( *m == *t && t < xstop ) {
571  nt = t[1];
572  mt = m[1];
573  if ( mt >= 2*MAXPOWER ) {
574  if ( CheckWild(BHEAD mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
575  nt -= AN.oldvalue;
576  goto SubsL1;
577  }
578  }
579  else if ( mt <= -2*MAXPOWER ) {
580  if ( CheckWild(BHEAD -mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
581  nt += AN.oldvalue;
582  goto SubsL1;
583  }
584  }
585  else {
586  nt -= mt * power;
587 SubsL1: if ( nt ) {
588  *fill++ = *t;
589  *fill++ = nt;
590  }
591  }
592  m += 2; t+= 2;
593  }
594  else if ( *m >= 2*MAXPOWER ) {
595  while ( t < xstop ) { *fill++ = *t++; *fill++ = *t++; }
596  nq = WORDDIF(fill,subterm);
597  fill = subterm;
598  while ( nq > 0 ) {
599  if ( !CheckWild(BHEAD *m-2*MAXPOWER,SYMTOSYM,*fill,&newval3) ) {
600  mt = m[1];
601  if ( mt >= 2*MAXPOWER ) {
602  if ( CheckWild(BHEAD mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
603  if ( fill[1] -= AN.oldvalue ) goto SubsL2;
604  }
605  }
606  else if ( mt <= -2*MAXPOWER ) {
607  if ( CheckWild(BHEAD -mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
608  if ( fill[1] += AN.oldvalue ) goto SubsL2;
609  }
610  }
611  else {
612  if ( fill[1] -= mt * power ) {
613 SubsL2: fill += nq;
614  nq = 0;
615  }
616  }
617  break;
618  }
619  nq -= 2;
620  fill += 2;
621  }
622  if ( nq ) {
623  nq -= 2;
624  q = fill + 2;
625  while ( --nq >= 0 ) *fill++ = *q++;
626  }
627  m += 2;
628  }
629  else if ( *m < *t || t >= xstop ) { m += 2; }
630  else { *fill++ = *t++; *fill++ = *t++; }
631  } while ( m < ystop );
632  while ( t < xstop ) *fill++ = *t++;
633  nq = WORDDIF(fill,subterm);
634  if ( nq > 0 ) {
635  nq += 2;
636  subterm[-1] = nq;
637  }
638  else { fill = subterm; fill -= 2; }
639  }
640 /*
641  #] SYMBOLS :
642  #[ DOTPRODUCTS :
643 */
644  else if ( *m == DOTPRODUCT ) {
645  ystop = m + m[1];
646  m += 2;
647  while ( *t > DOTPRODUCT && t < tstop ) {
648  nq = t[1];
649  NCOPY(fill,t,nq);
650  }
651  if ( t >= tstop ) goto SubCoef;
652  if ( *t != DOTPRODUCT ) {
653  m = ystop;
654  goto EndLoop;
655  }
656  *fill++ = DOTPRODUCT;
657  fill++;
658  subterm = fill;
659  xstop = t + t[1];
660  t += 2;
661  do {
662  if ( *m == *t && m[1] == t[1] && t < xstop ) {
663  nt = t[2];
664  mt = m[2];
665  if ( mt >= 2*MAXPOWER ) {
666  if ( CheckWild(BHEAD mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
667  nt -= AN.oldvalue;
668  goto SubsL3;
669  }
670  }
671  else if ( mt <= -2*MAXPOWER ) {
672  if ( CheckWild(BHEAD -mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
673  nt += AN.oldvalue;
674  goto SubsL3;
675  }
676  }
677  else {
678  nt -= mt * power;
679 SubsL3: if ( nt ) {
680  *fill++ = *t++;
681  *fill++ = *t;
682  *fill++ = nt;
683  t += 2;
684  }
685  else t += 3;
686  }
687  m += 3;
688  }
689  else if ( *m >= (AM.OffsetVector+WILDOFFSET) ) {
690  while ( t < xstop ) {
691  *fill++ = *t++; *fill++ = *t++; *fill++ = *t++;
692  }
693  oldval1 = 1;
694  goto SubsL4;
695  }
696  else if ( m[1] >= (AM.OffsetVector+WILDOFFSET) ) {
697  while ( *m >= *t && t < xstop ) {
698  *fill++ = *t++; *fill++ = *t++; *fill++ = *t++;
699  }
700  oldval1 = 0;
701 SubsL4: nq = WORDDIF(fill,subterm);
702  fill = subterm;
703  while ( nq > 0 ) {
704  if ( ( oldval1 && ( (
705  !CheckWild(BHEAD *m-WILDOFFSET,VECTOVEC,*fill,&newval3)
706  && !CheckWild(BHEAD m[1]-WILDOFFSET,VECTOVEC,fill[1],&newval3)
707  ) || (
708  !CheckWild(BHEAD m[1]-WILDOFFSET,VECTOVEC,*fill,&newval3)
709  && !CheckWild(BHEAD *m-WILDOFFSET,VECTOVEC,fill[1],&newval3)
710  ) ) ) || ( !oldval1 && ( (
711  *m == *fill
712  && !CheckWild(BHEAD m[1]-WILDOFFSET,VECTOVEC,fill[1],&newval3)
713  ) || (
714  !CheckWild(BHEAD m[1]-WILDOFFSET,VECTOVEC,*fill,&newval3)
715  && *m == fill[1] ) ) ) ) {
716  mt = m[2];
717  if ( mt >= 2*MAXPOWER ) {
718  if ( CheckWild(BHEAD mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
719  if ( fill[2] -= AN.oldvalue )
720  goto SubsL5;
721  }
722  }
723  else if ( mt <= -2*MAXPOWER ) {
724  if ( CheckWild(BHEAD -mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
725  if ( fill[2] += AN.oldvalue )
726  goto SubsL5;
727  }
728  }
729  else {
730  if ( fill[2] -= mt * power ) {
731 SubsL5: fill += nq;
732  nq = 0;
733  }
734  }
735  m += 3;
736  break;
737  }
738  fill += 3; nq -= 3;
739  }
740  if ( nq ) {
741  nq -= 3;
742  q = fill + 3;
743  while ( --nq >= 0 ) *fill++ = *q++;
744  }
745  }
746  else if ( t >= xstop || *m < *t || ( *m == *t && m[1] < t[1] ) )
747  { m += 3; }
748  else {
749  *fill++ = *t++; *fill++ = *t++; *fill++ = *t++;
750  }
751  } while ( m < ystop );
752  while ( t < xstop ) *fill++ = *t++;
753  nq = WORDDIF(fill,subterm);
754  if ( nq > 0 ) {
755  nq += 2;
756  subterm[-1] = nq;
757  }
758  else { fill = subterm; fill -= 2; }
759  }
760 /*
761  #] DOTPRODUCTS :
762  #[ FUNCTIONS :
763 */
764  else if ( *m >= FUNCTION ) {
765  while ( *t >= FUNCTION || *t == SUBEXPRESSION ) {
766  nt = WORDDIF(t,term);
767  for ( mt = 0; mt < AN.RepFunNum; mt += 2 ) {
768  if ( nt == AN.RepFunList[mt] ) break;
769  }
770  if ( mt >= AN.RepFunNum ) {
771  nq = t[1];
772  NCOPY(fill,t,nq);
773  }
774  else {
775  WORD *oldt = 0;
776  if ( *m == GAMMA && m[1] != FUNHEAD+1 ) {
777  oldt = t;
778  if ( ( i = AN.RepFunList[mt+1] ) > 0 ) {
779  *fill++ = GAMMA;
780  *fill++ = i + FUNHEAD+1;
781  FILLFUN(fill)
782  nq = i + 1;
783  t += FUNHEAD;
784  NCOPY(fill,t,nq);
785  }
786  t = oldt;
787  }
788  else if ( ( *t == LEVICIVITA ) || ( *t >= FUNCTION
789  && (functions[*t-FUNCTION].symmetric & ~REVERSEORDER) == ANTISYMMETRIC )
790  ) sign += AN.RepFunList[mt+1];
791  else if ( *m >= FUNCTION+WILDOFFSET
792  && (functions[*m-FUNCTION-WILDOFFSET].symmetric & ~REVERSEORDER) == ANTISYMMETRIC
793  ) sign += AN.RepFunList[mt+1];
794  if ( !PutExpr ) {
795  xstop = t + t[1];
796  t = AN.FullProto;
797  nq = t[1];
798  t[3] = power;
799  NCOPY(fill,t,nq);
800  t = xstop;
801  PutExpr = 1;
802  }
803  else t += t[1];
804  if ( *m == GAMMA && m[1] != FUNHEAD+1 ) {
805  i = oldt[1] - m[1] - i;
806  if ( i > 0 ) {
807  *fill++ = GAMMA;
808  *fill++ = i + FUNHEAD+1;
809  FILLFUN(fill)
810  *fill++ = oldt[FUNHEAD];
811  t = t - i;
812  NCOPY(fill,t,i);
813  }
814  }
815  break;
816  }
817  }
818  m += m[1];
819  }
820 /*
821  #] FUNCTIONS :
822  #[ VECTORS :
823 */
824  else if ( *m == VECTOR ) {
825  while ( *t > VECTOR ) {
826  nq = t[1];
827  NCOPY(fill,t,nq);
828  }
829  xstop = t + t[1];
830  ystop = m + m[1];
831  t += 2;
832  m += 2;
833  *fill++ = VECTOR;
834  fill++;
835  subterm = fill;
836  do {
837  if ( *m == *t && m[1] == t[1] ) {
838  m += 2; t += 2;
839  }
840  else if ( *m >= (AM.OffsetVector+WILDOFFSET) ) {
841  while ( t < xstop ) *fill++ = *t++;
842  nq = WORDDIF(fill,subterm);
843  fill = subterm;
844  if ( m[1] < (AM.OffsetIndex+WILDOFFSET) ) {
845  do {
846  if ( m[1] == fill[1] &&
847  !CheckWild(BHEAD *m-WILDOFFSET,VECTOVEC,*fill,&newval3) )
848  break;
849  fill += 2;
850  nq -= 2;
851  } while ( nq > 0 );
852  }
853  else { /* Double wildcard */
854  do {
855  if ( !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,fill[1],&newval3)
856  && !CheckWild(BHEAD *m-WILDOFFSET,VECTOVEC,*fill,&newval3) )
857  break;
858  if ( *fill == oldval1 && fill[1] == AN.oldvalue ) break;
859  fill += 2;
860  nq -= 2;
861  } while ( nq > 0 );
862  }
863  nq -= 2;
864  q = fill + 2;
865  if ( nq > 0 ) { NCOPY(fill,q,nq); }
866  m += 2;
867  }
868  else if ( *m <= *t &&
869  m[1] >= (AM.OffsetIndex + WILDOFFSET) ) {
870  while ( *m == *t && t < xstop )
871  { *fill++ = *t++; *fill++ = *t++; }
872  nq = WORDDIF(fill,subterm);
873  fill = subterm;
874  do {
875  if ( *m == *fill &&
876  !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,fill[1],&newval3) )
877  break;
878  nq -= 2;
879  fill += 2;
880  } while ( nq > 0 );
881  nq -= 2;
882  q = fill + 2;
883  if ( nq > 0 ) { NCOPY(fill,q,nq); }
884  m += 2;
885  }
886  else { *fill++ = *t++; *fill++ = *t++; }
887  } while ( m < ystop );
888  while ( t < xstop ) *fill++ = *t++;
889  nq = WORDDIF(fill,subterm);
890  if ( nq > 0 ) {
891  nq += 2;
892  subterm[-1] = nq;
893  }
894  else { fill = subterm; fill -= 2; }
895  }
896 /*
897  #] VECTORS :
898  #[ INDICES :
899 
900  Currently without wildcards
901 */
902  else if ( *m == INDEX ) {
903  while ( *t > INDEX ) {
904  nq = t[1];
905  NCOPY(fill,t,nq);
906  }
907  xstop = t + t[1];
908  ystop = m + m[1];
909  t += 2;
910  m += 2;
911  *fill++ = INDEX;
912  fill++;
913  subterm = fill;
914  do {
915  if ( *m == *t ) {
916  m += 1; t += 1;
917  }
918  else if ( *m >= (AM.OffsetIndex+WILDOFFSET) ) {
919  while ( t < xstop ) *fill++ = *t++;
920  nq = WORDDIF(fill, subterm);
921  fill = subterm;
922  do {
923  if ( !CheckWild(BHEAD *m-WILDOFFSET,INDTOIND,*fill,&newval3) ) {
924  break;
925  }
926  fill += 1;
927  nq -= 1;
928  } while ( nq > 0 );
929  nq -= 1;
930  if ( nq > 0 ) {
931  q = fill + 1;
932  NCOPY(fill,q,nq);
933  }
934  m += 1;
935  }
936  else {
937  *fill++ = *t++;
938  }
939  } while ( m < ystop );
940  while ( t < xstop ) *fill++ = *t++;
941  nq = WORDDIF(fill,subterm);
942  if ( nq > 0 ) {
943  nq += 2;
944  subterm[-1] = nq;
945  }
946  else { fill = subterm; fill -= 2; }
947  }
948 /*
949  #] INDICES :
950  #[ DELTAS :
951 */
952  else if ( *m == DELTA ) {
953  while ( *t > DELTA ) {
954  nq = t[1];
955  NCOPY(fill,t,nq);
956  }
957  xstop = t + t[1];
958  ystop = m + m[1];
959  t += 2;
960  m += 2;
961  *fill++ = DELTA;
962  fill++;
963  subterm = fill;
964  do {
965  if ( *t == *m && t[1] == m[1] ) { m += 2; t += 2; }
966  else if ( *m >= (AM.OffsetIndex+WILDOFFSET) ) { /* Two dummies */
967  while ( t < xstop ) *fill++ = *t++;
968 /* fill = subterm; */
969  oldval1 = 1;
970  goto SubsL6;
971  }
972  else if ( m[1] >= (AM.OffsetIndex+WILDOFFSET) ) {
973  while ( (*m == *t || *m == t[1] ) && ( t < xstop ) ) {
974  *fill++ = *t++; *fill++ = *t++;
975  }
976  oldval1 = 0;
977 SubsL6: nq = WORDDIF(fill,subterm);
978  fill = subterm;
979  do {
980  if ( ( oldval1 && ( (
981  !CheckWild(BHEAD *m-WILDOFFSET,INDTOIND,*fill,&newval3)
982  && !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,fill[1],&newval3)
983  ) || (
984  !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,*fill,&newval3)
985  && !CheckWild(BHEAD *m-WILDOFFSET,INDTOIND,fill[1],&newval3)
986  ) ) ) || ( !oldval1 && ( (
987  *m == *fill
988  && !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,fill[1],&newval3)
989  ) || (
990  *m == fill[1]
991  && !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,*fill,&newval3)
992  ) ) ) ) break;
993  fill += 2;
994  nq -= 2;
995  } while ( nq > 0 );
996  nq -= 2;
997  if ( nq > 0 ) {
998  q = fill + 2;
999  NCOPY(fill,q,nq);
1000  }
1001  m += 2;
1002  }
1003  else {
1004  *fill++ = *t++; *fill++ = *t++;
1005  }
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  #] DELTAS :
1017 */
1018 EndLoop:;
1019  } while ( m < mstop ); }
1020  while ( t < tstop ) *fill++ = *t++;
1021 SubCoef:
1022  if ( !PutExpr ) {
1023  t = AN.FullProto;
1024  nq = t[1];
1025  t[3] = power;
1026  NCOPY(fill,t,nq);
1027  }
1028  t = tcoef;
1029  nq = ABS(*t);
1030  t = tstop;
1031  NCOPY(fill,t,nq);
1032  nq = WORDDIF(fill,TemTerm);
1033  fill = term;
1034  t = TemTerm;
1035  *fill++ = nq--;
1036  t++;
1037  NCOPY(fill,t,nq);
1038  if ( sign ) {
1039  if ( ( sign & 1 ) != 0 ) fill[-1] = -fill[-1];
1040  }
1041  if ( AT.WorkPointer < fill ) AT.WorkPointer = fill;
1042  AN.RepFunNum = 0;
1043 }
1044 
1045 /*
1046  #] Substitute :
1047  #[ FindSpecial : WORD FindSpecial(term)
1048 
1049  Routine to detect symplifications regarding the special functions
1050  exponent, denominator.
1051 
1052 
1053 WORD FindSpecial(WORD *term)
1054 {
1055  WORD *t;
1056  WORD *tstop;
1057  t = term; t += *t - 1; tstop = t - ABS(*t) + 1; t = term;
1058  t++;
1059  if ( t < tstop ) { do {
1060  if ( *t == EXPONENT ) {
1061  Exponents can become simpler when:
1062  a: the exponent of an expression becomes an integer.
1063  b: The expression becomes zero.
1064  }
1065  else if ( *t == DENOMINATOR ) {
1066  Denominators can become simpler when:
1067  a: The denominator is a single term without functions.
1068  b: An overall coefficient can be removed.
1069  c: An overall object can be removed.
1070  The task is here to bring the denominator in an unique form.
1071  }
1072  t += *t;
1073  } while ( t < tstop ); }
1074  return(0);
1075 }
1076 
1077  #] FindSpecial :
1078  #[ FindAll : WORD FindAll(term,pattern,level,par)
1079 */
1080 
1081 WORD FindAll(PHEAD WORD *term, WORD *pattern, WORD level, WORD *par)
1082 {
1083  GETBIDENTITY
1084  WORD *t, *m, *r, *mm, rnum;
1085  WORD *tstop, *mstop, *TwoProto, *vwhere = 0, oldv, oldvv, vv, level2;
1086  WORD v, nq, OffNum = AM.OffsetVector + WILDOFFSET, i, ii = 0, jj;
1087  WORD fromindex, *intens, notflag1 = 0, notflag2 = 0;
1088  CBUF *C;
1089  C = cbuf+AM.rbufnum;
1090  v = pattern[3]; /* The vector to be found */
1091  m = t = term;
1092  m += *m;
1093  m -= ABS(m[-1]);
1094  t++;
1095  if ( t < m ) do {
1096  tstop = t + t[1];
1097  fromindex = 2;
1098 /*
1099  #[ VECTOR :
1100 */
1101  if ( *t == VECTOR ) {
1102  r = t;
1103  r += 2;
1104 InVect:
1105  while ( r < tstop ) {
1106  oldv = *r;
1107  if ( v >= OffNum ) {
1108  vwhere = AN.FullProto + 3 + SUBEXPSIZE;
1109  if ( vwhere[1] == FROMSET || vwhere[1] == SETTONUM ) {
1110  WORD *afirst, *alast, j;
1111  j = vwhere[3];
1112  if ( j > WILDOFFSET ) { j -= 2*WILDOFFSET; notflag1 = 1; }
1113  else { notflag1 = 0; }
1114  afirst = SetElements + Sets[j].first;
1115  alast = SetElements + Sets[j].last;
1116  ii = 1;
1117  if ( notflag1 == 0 ) {
1118  do {
1119  if ( *afirst == *r ) {
1120  if ( vwhere[1] == SETTONUM ) {
1121  AN.FullProto[8+SUBEXPSIZE] = SYMTONUM;
1122  AN.FullProto[11+SUBEXPSIZE] = ii;
1123  }
1124  else if ( vwhere[4] >= 0 ) {
1125  oldv = *(afirst - Sets[j].first
1126  + Sets[vwhere[4]].first);
1127  }
1128  goto DoVect;
1129  }
1130  ii++;
1131  } while ( ++afirst < alast );
1132  }
1133  else {
1134  do {
1135  if ( *afirst == *r ) break;
1136  } while ( ++afirst < alast );
1137  if ( afirst >= alast ) goto DoVect;
1138  }
1139  }
1140  else goto DoVect;
1141  }
1142  else if ( v == *r ) {
1143 DoVect: m = AT.WorkPointer;
1144  tstop = t;
1145  t = term;
1146  mstop = t + *t;
1147  do { *m++ = *t++; } while ( t < tstop );
1148  vwhere = m;
1149  t = AN.FullProto;
1150  nq = t[1];
1151  t[3] = 1;
1152  NCOPY(m,t,nq);
1153  t = tstop;
1154  if ( fromindex == 1 ) m[-1] = FUNNYVEC;
1155  else m[-1] = r[1]; /* The index is always here! */
1156  if ( v >= OffNum ) vwhere[3+SUBEXPSIZE] = oldv;
1157  if ( vwhere[1] > 12+SUBEXPSIZE ) {
1158  vwhere[11+SUBEXPSIZE] = ii;
1159  vwhere[8+SUBEXPSIZE] = SYMTONUM;
1160  }
1161  if ( t[1] > fromindex+2 ) {
1162  *m++ = *t++;
1163  *m++ = *t++ - fromindex;
1164  while ( t < r ) *m++ = *t++;
1165  t += fromindex;
1166  }
1167  else t += t[1];
1168  do { *m++ = *t++; } while ( t < mstop );
1169  *AT.WorkPointer = nq = WORDDIF(m,AT.WorkPointer);
1170  m = AT.WorkPointer;
1171  t = term;
1172  NCOPY(t,m,nq);
1173  AT.WorkPointer = t;
1174  return(1);
1175  }
1176  r += fromindex;
1177  }
1178  }
1179 /*
1180  #] VECTOR :
1181  #[ DOTPRODUCT :
1182 */
1183  else if ( *t == DOTPRODUCT ) {
1184  r = t;
1185  r += 2;
1186  do {
1187  if ( ( i = r[2] ) < 0 ) goto NextDot;
1188  if ( *r == r[1] ) { /* p.p */
1189  oldv = *r;
1190  if ( v == *r ) { /* v.v */
1191 TwoVec: m = AT.WorkPointer;
1192  tstop = t;
1193  t = term;
1194  mstop = t + *t;
1195  do { *m++ = *t++; } while ( t < tstop );
1196  do {
1197  vwhere = m;
1198  t = AN.FullProto;
1199  nq = t[1];
1200  t[3] = 2;
1201  NCOPY(m,t,nq);
1202  m[-1] = ++AR.CurDum;
1203  if ( v >= OffNum ) vwhere[3+SUBEXPSIZE] = oldv;
1204  } while ( --i > 0 );
1205 CopRest: t = tstop;
1206  if ( t[1] > 5 ) {
1207  *m++ = *t++;
1208  *m++ = *t++ - 3;
1209  while ( t < r ) *m++ = *t++;
1210  t += 3;
1211  }
1212  else t += t[1];
1213  do { *m++ = *t++; } while ( t < mstop );
1214  *AT.WorkPointer = nq = WORDDIF(m,AT.WorkPointer);
1215  m = AT.WorkPointer;
1216  t = term;
1217  NCOPY(t,m,nq);
1218  AT.WorkPointer = t;
1219  return(1);
1220  }
1221  else if ( v >= OffNum ) { /* v?.v? */
1222  vwhere = AN.FullProto + 3+SUBEXPSIZE;
1223  if ( vwhere[1] == FROMSET || vwhere[1] == SETTONUM ) {
1224  WORD *afirst, *alast, j;
1225  j = vwhere[3];
1226  if ( j > WILDOFFSET ) { j -= 2*WILDOFFSET; notflag1 = 1; }
1227  else { notflag1 = 0; }
1228  afirst = SetElements + Sets[j].first;
1229  alast = SetElements + Sets[j].last;
1230  ii = 1;
1231  if ( notflag1 == 0 ) {
1232  do {
1233  if ( *afirst == *r ) {
1234  if ( vwhere[1] == SETTONUM ) {
1235  AN.FullProto[8+SUBEXPSIZE] = SYMTONUM;
1236  AN.FullProto[11+SUBEXPSIZE] = ii;
1237  }
1238  else if ( vwhere[4] >= 0 ) {
1239  oldv = *(afirst - Sets[j].first
1240  + Sets[vwhere[4]].first);
1241  }
1242  goto TwoVec;
1243  }
1244  ii++;
1245  } while ( ++afirst < alast );
1246  }
1247  else {
1248  do {
1249  if ( *afirst == *r ) break;
1250  } while ( ++afirst < alast );
1251  if ( afirst >= alast ) goto TwoVec;
1252  }
1253  }
1254  else goto TwoVec;
1255  }
1256  }
1257  else {
1258  if ( v == r[1] ) { r[1] = *r; *r = v; }
1259  oldv = *r;
1260  oldvv = r[1];
1261  if ( v == *r ) {
1262  if ( !par ) { while ( ++level <= AR.Cnumlhs
1263  && C->lhs[level][0] == TYPEIDOLD ) {
1264  m = C->lhs[level];
1265  m += IDHEAD;
1266  if ( m[-IDHEAD+2] == SUBALL ) {
1267  if ( ( vv = m[m[1]+3] ) == r[1] ) {
1268 OnePV: TwoProto = AN.FullProto;
1269 TwoPV: m = AT.WorkPointer;
1270  tstop = t;
1271  t = term;
1272  mstop = t + *t;
1273  do { *m++ = *t++; } while ( t < tstop );
1274  do {
1275  t = AN.FullProto;
1276  vwhere = m + 3 +SUBEXPSIZE;
1277  nq = t[1];
1278  t[3] = 1;
1279  NCOPY(m,t,nq);
1280  m[-1] = ++AR.CurDum;
1281  if ( v >= OffNum ) *vwhere = oldv;
1282  if ( vwhere[-2-SUBEXPSIZE] > 12+SUBEXPSIZE ) {
1283  vwhere[8] = ii;
1284  vwhere[5] = SYMTONUM;
1285  }
1286  t = TwoProto;
1287  vwhere = m + 3+SUBEXPSIZE;
1288  mm = m;
1289  nq = t[1];
1290  t[3] = 1;
1291  NCOPY(m,t,nq);
1292 /*
1293  The next two lines repair a bug. without them it takes twice
1294  the rhs of the first vector.
1295 */
1296  mm[2] = C->lhs[level][IDHEAD+2];
1297  mm[4] = C->lhs[level][IDHEAD+4];
1298  m[-1] = AR.CurDum;
1299  if ( vv >= OffNum ) *vwhere = oldvv;
1300  } while ( --i > 0 );
1301  goto CopRest;
1302  }
1303  else if ( vv > OffNum ) {
1304  vwhere = AN.FullProto + 3+SUBEXPSIZE;
1305  if ( vwhere[1] == FROMSET || vwhere[1] == SETTONUM ) {
1306  WORD *afirst, *alast, j;
1307  j = vwhere[3];
1308  if ( j > WILDOFFSET ) { j -= 2*WILDOFFSET; notflag1 = 1; }
1309  else { notflag1 = 0; }
1310  afirst = SetElements + Sets[j].first;
1311  alast = SetElements + Sets[j].last;
1312  if ( notflag1 == 0 ) {
1313  ii = 1;
1314  do {
1315  if ( *afirst == r[1] ) {
1316  if ( vwhere[1] == SETTONUM ) {
1317  AN.FullProto[8+SUBEXPSIZE] = SYMTONUM;
1318  AN.FullProto[11+SUBEXPSIZE] = ii;
1319  }
1320  else if ( vwhere[4] >= 0 ) {
1321  oldvv = *(afirst - Sets[j].first
1322  + Sets[vwhere[4]].first);
1323  }
1324  goto OnePV;
1325  }
1326  ii++;
1327  } while ( ++afirst < alast );
1328  }
1329  else {
1330  do {
1331  if ( *afirst == *r ) break;
1332  } while ( ++afirst < alast );
1333  if ( afirst >= alast ) goto OnePV;
1334  }
1335  }
1336  else goto OnePV;
1337  }
1338  }
1339  }}
1340 /*
1341  v.q with v matching and no match for the q, also
1342  not in following idold statements.
1343  Notice that a following q.p? cannot match.
1344 */
1345  rnum = r[1];
1346 OneOnly: m = AT.WorkPointer;
1347  tstop = t;
1348  t = term;
1349  mstop = t + *t;
1350  do { *m++ = *t++; } while ( t < tstop );
1351  vwhere = m;
1352  t = AN.FullProto;
1353  nq = t[1];
1354  t[3] = i;
1355  NCOPY(m,t,nq);
1356  m[-4] = INDTOIND;
1357  m[-1] = rnum;
1358  if ( v >= OffNum ) vwhere[3+SUBEXPSIZE] = oldv;
1359  goto CopRest;
1360  }
1361  else if ( v >= OffNum ) {
1362  vwhere = AN.FullProto + 3+SUBEXPSIZE;
1363  if ( vwhere[1] == FROMSET || vwhere[1] == SETTONUM ) {
1364  WORD *afirst, *alast, *bfirst, *blast, j;
1365  j = vwhere[3];
1366  if ( j > WILDOFFSET ) { j -= 2*WILDOFFSET; notflag1 = 1; }
1367  else { notflag1 = 0; }
1368  afirst = SetElements + Sets[j].first;
1369  alast = SetElements + Sets[j].last;
1370  ii = 1;
1371  if ( notflag1 == 0 ) {
1372  do {
1373  if ( *afirst == *r ) {
1374  if ( vwhere[1] == SETTONUM ) {
1375  AN.FullProto[8+SUBEXPSIZE] = SYMTONUM;
1376  AN.FullProto[11+SUBEXPSIZE] = ii;
1377  }
1378  else if ( vwhere[4] >= 0 ) {
1379  oldv = *(afirst - Sets[j].first
1380  + Sets[vwhere[4]].first);
1381  }
1382 Hitlevel1: level2 = level;
1383  do {
1384  if ( !par ) m = C->lhs[level2];
1385  else m = par;
1386  m += IDHEAD;
1387  if ( m[-IDHEAD+2] == SUBALL ) {
1388  if ( ( vv = m[m[1]+3] ) == r[1] )
1389  goto OnePV;
1390  else if ( vv >= OffNum ) {
1391  if ( m[SUBEXPSIZE+4] != FROMSET &&
1392  m[SUBEXPSIZE+4] != SETTONUM ) goto OnePV;
1393  j = m[SUBEXPSIZE+6];
1394  if ( j > WILDOFFSET ) { j -= 2*WILDOFFSET; notflag2 = 1; }
1395  else { notflag2 = 0; }
1396  bfirst = SetElements + Sets[j].first;
1397  blast = SetElements + Sets[j].last;
1398  jj = 1;
1399  if ( notflag2 == 0 ) {
1400  do {
1401  if ( *bfirst == r[1] ) {
1402  if ( m[SUBEXPSIZE+4] == SETTONUM ) {
1403  m[SUBEXPSIZE+8] = SYMTONUM;
1404  m[SUBEXPSIZE+11] = jj;
1405  }
1406  else if ( m[SUBEXPSIZE+7] >= 0 ) {
1407  oldvv = *(bfirst - Sets[j].first
1408  + Sets[m[SUBEXPSIZE+7]].first);
1409  }
1410  goto OnePV;
1411  }
1412  jj++;
1413  } while ( ++bfirst < blast );
1414  }
1415  else {
1416  do {
1417  if ( *bfirst == r[1] ) break;
1418  } while ( ++bfirst < blast );
1419  if ( bfirst >= blast ) goto OnePV;
1420  }
1421  }
1422  }
1423  } while ( ++level2 < AR.Cnumlhs &&
1424  C->lhs[level2][0] == TYPEIDOLD );
1425  rnum = r[1];
1426  goto OneOnly;
1427  }
1428  else if ( *afirst == r[1] ) {
1429  if ( vwhere[1] == SETTONUM ) {
1430  AN.FullProto[8+SUBEXPSIZE] = SYMTONUM;
1431  AN.FullProto[11+SUBEXPSIZE] = ii;
1432  }
1433  else if ( vwhere[4] >= 0 ) {
1434  oldv = *(afirst - Sets[j].first
1435  + Sets[vwhere[4]].first);
1436  }
1437 Hitlevel2: level2 = level;
1438  while ( ++level2 < AR.Cnumlhs &&
1439  C->lhs[level2][0] == TYPEIDOLD ) {
1440  if ( !par ) m = C->lhs[level2];
1441  else m = par;
1442  m += IDHEAD;
1443  if ( m[-IDHEAD+2] == SUBALL ) {
1444  if ( ( vv = m[6] ) == *r )
1445  goto OnePV;
1446  else if ( vv >= OffNum ) {
1447  if ( m[SUBEXPSIZE+4] != FROMSET && m[SUBEXPSIZE+4]
1448  != SETTONUM ) {
1449  j = *r;
1450  *r = r[1];
1451  r[1] = j;
1452  goto OnePV;
1453  }
1454  j = m[SUBEXPSIZE+6];
1455  bfirst = SetElements + Sets[j].first;
1456  blast = SetElements + Sets[j].last;
1457  jj = 1;
1458  do {
1459  if ( *bfirst == *r ) {
1460  if ( m[SUBEXPSIZE+4] == SETTONUM ) {
1461  m[SUBEXPSIZE+8] = SYMTONUM;
1462  m[SUBEXPSIZE+11] = jj;
1463  }
1464  else if ( m[SUBEXPSIZE+7] >= 0 ) {
1465  oldvv = *(bfirst - Sets[j].first
1466  + Sets[m[SUBEXPSIZE+7]].first);
1467  }
1468  j = *r;
1469  *r = r[1];
1470  r[1] = j;
1471  j = oldv; oldv = oldvv; oldvv = j;
1472  goto OnePV;
1473  }
1474  jj++;
1475  } while ( ++bfirst < blast );
1476  }
1477  }
1478  }
1479  jj = *r; *r = r[1]; r[1] = jj;
1480  jj = oldv; oldv = oldvv; oldvv = j;
1481  rnum = r[1];
1482  goto OneOnly;
1483  }
1484  ii++;
1485  } while ( ++afirst < alast );
1486  }
1487  else {
1488  do {
1489  if ( *afirst == *r ) break;
1490  } while ( ++afirst < alast );
1491  if ( afirst >= alast ) goto Hitlevel1;
1492  do {
1493  if ( *afirst == r[1] ) break;
1494  } while ( ++afirst < alast );
1495  if ( afirst >= alast ) goto Hitlevel2;
1496  }
1497  }
1498  else { /* Matches twice */
1499  vv = v;
1500  TwoProto = AN.FullProto;
1501  goto TwoPV;
1502  }
1503  }
1504  }
1505 NextDot: r += 3;
1506  } while ( r < tstop );
1507  }
1508 /*
1509  #] DOTPRODUCT :
1510  #[ LEVICIVITA :
1511 */
1512  else if ( *t == LEVICIVITA ) {
1513  intens = 0;
1514  r = t;
1515  r += FUNHEAD;
1516 OneVect:;
1517  while ( r < tstop ) {
1518  oldv = *r;
1519  if ( v >= OffNum && *r < -10 ) {
1520  vwhere = AN.FullProto + 3+SUBEXPSIZE;
1521  if ( vwhere[1] == FROMSET || vwhere[1] == SETTONUM ) {
1522  WORD *afirst, *alast, j;
1523  j = vwhere[3];
1524  if ( j > WILDOFFSET ) { j -= 2*WILDOFFSET; notflag1 = 1; }
1525  else { notflag1 = 0; }
1526  afirst = SetElements + Sets[j].first;
1527  alast = SetElements + Sets[j].last;
1528  ii = 1;
1529  if ( notflag1 == 0 ) {
1530  do {
1531  if ( *afirst == *r ) {
1532  if ( vwhere[1] == SETTONUM ) {
1533  AN.FullProto[8+SUBEXPSIZE] = SYMTONUM;
1534  AN.FullProto[11+SUBEXPSIZE] = ii;
1535  }
1536  else if ( vwhere[4] >= 0 ) {
1537  oldv = *(afirst - Sets[j].first
1538  + Sets[vwhere[4]].first);
1539  }
1540  goto DoVect;
1541  }
1542  ii++;
1543  } while ( ++afirst < alast );
1544  }
1545  else {
1546  do {
1547  if ( *afirst == *r ) break;
1548  } while ( ++afirst < alast );
1549  if ( afirst >= alast ) goto DoVect;
1550  }
1551  }
1552  else goto LeVect;
1553  }
1554  else if ( v == *r ) {
1555 LeVect: m = AT.WorkPointer;
1556  mstop = term + *term;
1557  t = term;
1558  *r = ++AR.CurDum;
1559  if ( intens ) *intens = DIRTYSYMFLAG;
1560  do { *m++ = *t++; } while ( t < tstop );
1561  t = AN.FullProto;
1562  nq = t[1];
1563  t[3] = 1;
1564  if ( v >= OffNum ) *vwhere = oldv;
1565  NCOPY(m,t,nq);
1566  m[-1] = AR.CurDum;
1567  t = tstop;
1568  do { *m++ = *t++; } while ( t < mstop );
1569  *AT.WorkPointer = nq = WORDDIF(m,AT.WorkPointer);
1570  m = AT.WorkPointer;
1571  t = term;
1572  NCOPY(t,m,nq);
1573  AT.WorkPointer = t;
1574  return(1);
1575  }
1576  r++;
1577  }
1578  }
1579 /*
1580  #] LEVICIVITA :
1581  #[ GAMMA :
1582 */
1583  else if ( *t == GAMMA ) {
1584  intens = 0;
1585  r = t;
1586  r += FUNHEAD+1;
1587  if ( r < tstop ) goto OneVect;
1588  }
1589 /*
1590  #] GAMMA :
1591  #[ INDEX :
1592 */
1593  else if ( *t == INDEX ) { /* The 'forgotten' part */
1594  r = t;
1595  r += 2;
1596  fromindex = 1;
1597  goto InVect;
1598  }
1599 /*
1600  #] INDEX :
1601  #[ FUNCTION :
1602 */
1603  else if ( *t >= FUNCTION ) {
1604  if ( *t >= FUNCTION
1605  && functions[*t-FUNCTION].spec >= TENSORFUNCTION
1606  && t[1] > FUNHEAD ) {
1607 /*
1608  Tensors are linear in their vectors!
1609 */
1610  r = t;
1611  r += FUNHEAD;
1612  intens = t+2;
1613  goto OneVect;
1614  }
1615  }
1616 /*
1617  #] FUNCTION :
1618 */
1619  t += t[1];
1620  } while ( t < m );
1621  return(0);
1622 }
1623 
1624 /*
1625  #] FindAll :
1626  #[ TestSelect :
1627 
1628  Returns 1 if any of the objects in any of the sets in setp
1629  occur anywhere in the term
1630 */
1631 
1632 int TestSelect(WORD *term, WORD *setp)
1633 {
1634  WORD *tstop, *t, *s, *el, *elstop, *termstop, *tt, n, ns;
1635  GETSTOP(term,tstop);
1636  term += 1;
1637  while ( term < tstop ) {
1638  switch ( *term ) {
1639  case SYMBOL:
1640  n = term[1] - 2;
1641  t = term + 2;
1642  while ( n > 0 ) {
1643  ns = setp[1] - 2;
1644  s = setp + 2;
1645  while ( --ns >= 0 ) {
1646  if ( Sets[*s].type != CSYMBOL ) { s++; continue; }
1647  el = SetElements + Sets[*s].first;
1648  elstop = SetElements + Sets[*s].last;
1649  while ( el < elstop ) {
1650  if ( *el++ == *t ) return(1);
1651  }
1652  s++;
1653  }
1654  n -= 2;
1655  t += 2;
1656  }
1657  break;
1658  case VECTOR:
1659  n = term[1] - 2;
1660  t = term + 2;
1661  while ( n > 0 ) {
1662  ns = setp[1] - 2;
1663  s = setp + 2;
1664  while ( --ns >= 0 ) {
1665  if ( Sets[*s].type != CVECTOR ) { s++; continue; }
1666  el = SetElements + Sets[*s].first;
1667  elstop = SetElements + Sets[*s].last;
1668  while ( el < elstop ) {
1669  if ( *el++ == *t ) return(1);
1670  }
1671  s++;
1672  }
1673  t++;
1674  ns = setp[1] - 2;
1675  s = setp + 2;
1676  while ( --ns >= 0 ) {
1677  if ( Sets[*s].type != CINDEX
1678  && Sets[*s].type != CNUMBER ) { s++; continue; }
1679  el = SetElements + Sets[*s].first;
1680  elstop = SetElements + Sets[*s].last;
1681  while ( el < elstop ) {
1682  if ( *el++ == *t ) return(1);
1683  }
1684  s++;
1685  }
1686  n -= 2;
1687  t++;
1688  }
1689  break;
1690  case INDEX:
1691  n = term[1] - 2;
1692  t = term + 2;
1693  goto dotensor;
1694  case DOTPRODUCT:
1695  n = term[1] - 2;
1696  t = term + 2;
1697  while ( n > 0 ) {
1698  ns = setp[1] - 2;
1699  s = setp + 2;
1700  while ( --ns >= 0 ) {
1701  if ( Sets[*s].type != CVECTOR ) { s++; continue; }
1702  el = SetElements + Sets[*s].first;
1703  elstop = SetElements + Sets[*s].last;
1704  while ( el < elstop ) {
1705  if ( *el++ == *t ) return(1);
1706  }
1707  s++;
1708  }
1709  t++;
1710  ns = setp[1] - 2;
1711  s = setp + 2;
1712  while ( --ns >= 0 ) {
1713  if ( Sets[*s].type != CVECTOR ) { s++; continue; }
1714  el = SetElements + Sets[*s].first;
1715  elstop = SetElements + Sets[*s].last;
1716  while ( el < elstop ) {
1717  if ( *el++ == *t ) return(1);
1718  }
1719  s++;
1720  }
1721  n -= 3;
1722  t += 2;
1723  }
1724  break;
1725  case DELTA:
1726  n = term[1] - 2;
1727  t = term + 2;
1728  goto dotensor;
1729  default:
1730  if ( *term < FUNCTION ) break;
1731  ns = setp[1] - 2;
1732  s = setp + 2;
1733  while ( --ns >= 0 ) {
1734  if ( Sets[*s].type != CFUNCTION ) { s++; continue; }
1735  el = SetElements + Sets[*s].first;
1736  elstop = SetElements + Sets[*s].last;
1737  while ( el < elstop ) {
1738  if ( *el++ == *term ) return(1);
1739  }
1740  s++;
1741  }
1742  if ( functions[*term-FUNCTION].spec ) {
1743  n = term[1] - FUNHEAD;
1744  t = term + FUNHEAD;
1745 dotensor:
1746  while ( n > 0 ) {
1747  ns = setp[1] - 2;
1748  s = setp + 2;
1749  while ( --ns >= 0 ) {
1750  if ( *t < MINSPEC ) {
1751  if ( Sets[*s].type != CVECTOR ) { s++; continue; }
1752  }
1753  else if ( *t >= 0 ) {
1754  if ( Sets[*s].type != CINDEX
1755  && Sets[*s].type != CNUMBER ) { s++; continue; }
1756  }
1757  else { s++; continue; }
1758  el = SetElements + Sets[*s].first;
1759  elstop = SetElements + Sets[*s].last;
1760  while ( el < elstop ) {
1761  if ( *el++ == *t ) return(1);
1762  }
1763  s++;
1764  }
1765  t++;
1766  n--;
1767  }
1768  }
1769  else {
1770  termstop = term + term[1];
1771  tt = term + FUNHEAD;
1772  while ( tt < termstop ) {
1773  if ( *tt < 0 ) {
1774  if ( *tt == -SYMBOL ) {
1775  ns = setp[1] - 2;
1776  s = setp + 2;
1777  while ( --ns >= 0 ) {
1778  if ( Sets[*s].type != CSYMBOL ) { s++; continue; }
1779  el = SetElements + Sets[*s].first;
1780  elstop = SetElements + Sets[*s].last;
1781  while ( el < elstop ) {
1782  if ( *el++ == tt[1] ) return(1);
1783  }
1784  s++;
1785  }
1786  tt += 2;
1787  }
1788  else if ( *tt == -VECTOR || *tt == -MINVECTOR ) {
1789  ns = setp[1] - 2;
1790  s = setp + 2;
1791  while ( --ns >= 0 ) {
1792  if ( Sets[*s].type != CVECTOR ) { s++; continue; }
1793  el = SetElements + Sets[*s].first;
1794  elstop = SetElements + Sets[*s].last;
1795  while ( el < elstop ) {
1796  if ( *el++ == tt[1] ) return(1);
1797  }
1798  s++;
1799  }
1800  tt += 2;
1801  }
1802  else if ( *tt == -INDEX ) {
1803  ns = setp[1] - 2;
1804  s = setp + 2;
1805  while ( --ns >= 0 ) {
1806  if ( Sets[*s].type != CINDEX
1807  && Sets[*s].type != CNUMBER ) { s++; continue; }
1808  el = SetElements + Sets[*s].first;
1809  elstop = SetElements + Sets[*s].last;
1810  while ( el < elstop ) {
1811  if ( *el++ == tt[1] ) return(1);
1812  }
1813  s++;
1814  }
1815  tt += 2;
1816  }
1817  else if ( *tt <= -FUNCTION ) {
1818  ns = setp[1] - 2;
1819  s = setp + 2;
1820  while ( --ns >= 0 ) {
1821  if ( Sets[*s].type != CFUNCTION ) { s++; continue; }
1822  el = SetElements + Sets[*s].first;
1823  elstop = SetElements + Sets[*s].last;
1824  while ( el < elstop ) {
1825  if ( *el++ == -(*tt) ) return(1);
1826  }
1827  s++;
1828  }
1829  tt++;
1830  }
1831  else tt += 2;
1832  }
1833  else {
1834  t = tt + ARGHEAD;
1835  tt += *tt;
1836  while ( t < tt ) {
1837  if ( TestSelect(t,setp) ) return(1);
1838  t += *t;
1839  }
1840  }
1841  }
1842  }
1843  break;
1844  }
1845  term += term[1];
1846  }
1847  return(0);
1848 }
1849 
1850 /*
1851  #] TestSelect :
1852  #] Patterns :
1853 */
1854 
#define PHEAD
Definition: ftypes.h:56
WORD ** lhs
Definition: structs.h:912
Definition: structs.h:908
VOID LowerSortLevel()
Definition: sort.c:4435
WORD NewSort(PHEAD0)
Definition: sort.c:553
WORD Generator(PHEAD WORD *, WORD)
Definition: proces.c:2865
WORD TestMatch(PHEAD WORD *term, WORD *level)
Definition: pattern.c:97
LONG EndSort(PHEAD WORD *, int)
Definition: sort.c:632