Added the permutations function perm_

doc/manual/optim.tex

@@ -322,7 +322,7 @@ \subsection{Optimization options of the Format statement}
 separated either by commas or blank spaces. When
 \verb|Format Optimize| is used, first the default settings are taken
 and then the options that are specified overwrite them. It is allowed
-to have the O1, O2, O3 optimization specifications followed by
+to have the O1, O2, O3, O4 optimization specifications followed by
 options. In that case the program first sets the values of those
 specifications and then modifies according to what it encounters in
 the rest of the statement.

sources/declare.h

@@ -451,6 +451,7 @@ extern WORD   DoDelta3(PHEAD WORD *,WORD);
 extern WORD   DoTableExpansion(WORD *,WORD);
 extern WORD   DoDistrib(PHEAD WORD *,WORD);
 extern WORD   DoShuffle(PHEAD WORD *,WORD,WORD,WORD);
+extern WORD   DoPermutations(PHEAD WORD *,WORD);
 extern int    Shuffle(PHEAD WORD *, WORD *, WORD *);
 extern int    FinishShuffle(PHEAD WORD *);
 extern WORD   DoStuffle(PHEAD WORD *,WORD,WORD,WORD);
@@ -548,6 +549,7 @@ extern WORD   OpenTemp(VOID);
 extern VOID   Pack(UWORD *,WORD *,UWORD *,WORD );
 extern LONG   PasteFile(PHEAD WORD,WORD *,POSITION *,WORD **,RENUMBER,WORD *,WORD);
 extern WORD   Permute(PERM *,WORD);
+extern WORD   PermuteP(PERMP *,WORD);
 extern WORD   PolyFunMul(PHEAD WORD *);
 extern WORD   PopVariables(VOID);
 extern WORD   PrepPoly(PHEAD WORD *);

sources/ftypes.h

@@ -455,8 +455,9 @@ typedef int (*TFUN1)();
 #define INVERSEFUNCTION 100
 #define IDFUNCTION 101
 #define PUTFIRST 102
+#define PERMUTATIONS 103
 
-#define MAXBUILTINFUNCTION 102
+#define MAXBUILTINFUNCTION 103
 #define FIRSTUSERFUNCTION 150
 
 /*

sources/inivar.h

@@ -228,6 +228,7 @@ static struct fixedfun {
 	,{"inverse_"    ,0 ,0             ,0               ,0} /* INVERSEFUNCTION */
 	,{"id_"         ,1 ,0             ,0               ,0} /* IDFUNCTION */
 	,{"putfirst_"   ,1 ,0             ,0               ,0} /* PUTFIRST */
+	,{"perm_"       ,1 ,0             ,0               ,0} /* PERMUTATIONS */
 };
 
 FIXEDSET fixedsets[] = {

sources/proces.c

@@ -1378,7 +1378,15 @@ Important: we may not have enough spots here
 					AR.TePos = -1;
 					return(1);
 				}
-              }
+			  }
+			  else if ( *t == PERMUTATIONS && ( ( t[1] >= FUNHEAD+1
+				&& t[FUNHEAD] <= -FUNCTION ) || ( t[1] >= FUNHEAD+3
+				&& t[FUNHEAD] == -SNUMBER && t[FUNHEAD+2] <= -FUNCTION ) ) ) {
+				AN.TeInFun = -12;
+				AN.TeSuOut = 0;
+				AR.TePos = -1;
+				return(1);
+			  }
 			}
 		}
 		t += t[1];
@@ -3670,6 +3678,9 @@ AutoGen:	i = *AT.TMout;
 				case -11:
 					if ( DIVfunction(BHEAD term,level,2) < 0 ) goto GenCall;
 					break;
+				case -12:
+					if ( DoPermutations(BHEAD term,level) ) goto GenCall;
+					break;
 			}
 		}
 		else {

sources/reshuf.c

@@ -1578,6 +1578,81 @@ nextk:;
 /*
  		#] DoDelta3 : 
   	#] Distribute : 
+  	#[ DoPermutations :
+
+	Routine replaces the function perm_(f,args) by occurrences of f with
+	all permutations of the args. This should always fit!
+*/
+
+WORD DoPermutations(PHEAD WORD *term, WORD level)
+{
+	PERMP perm;
+	WORD *oldworkpointer = AT.WorkPointer, *termout = AT.WorkPointer;
+	WORD *t, *tstop, *tt, *ttstop, odd = 0;
+	WORD *args[MAXMATCH], nargs, i, first, skip, *to, *from;
+/*
+	Find function and count arguments. Check for odd/even
+*/
+	tstop = term+*term; tstop -= ABS(tstop[-1]);
+	t = term+1;
+	while ( t < tstop ) {
+		if ( *t == PERMUTATIONS ) {
+			if ( t[1] >= FUNHEAD+1 && t[FUNHEAD] <= -FUNCTION ) {
+				odd = 0; skip = 1;
+			}
+			else if ( t[1] >= FUNHEAD+3 && t[FUNHEAD] == -SNUMBER && t[FUNHEAD+2] <= -FUNCTION ) {
+				if ( t[FUNHEAD+1] % 2 == 1 ) odd = -1;
+				else odd = 0;
+				skip = 3;
+			}
+			else { t += t[1]; continue; }
+			tt = t+FUNHEAD+skip; ttstop = t + t[1];
+			nargs = 0;
+			while ( tt < ttstop ) { NEXTARG(tt); nargs++; }
+			tt = t+FUNHEAD+skip;
+			if ( nargs > MAXMATCH ) {
+				MLOCK(ErrorMessageLock);
+				MesPrint("Too many arguments in function perm_. %d! is way too big",(WORD)MAXMATCH);
+				MUNLOCK(ErrorMessageLock);
+				SETERROR(-1)
+			}
+			i = 0;
+			while ( tt < ttstop ) { args[i++] = tt; NEXTARG(tt); }
+			perm.n = nargs;
+			perm.sign = 0;
+			perm.objects = args;
+			first = 1;
+			while ( (first = PermuteP(&perm,first) ) == 0 ) {
+/*
+				Compose the output term
+*/
+				to = termout; from = term;
+				while ( from < t ) *to++ = *from++;
+				*to++ = -t[FUNHEAD+skip-1];
+				*to++ = t[1] - skip;
+				for ( i = 2; i < FUNHEAD; i++ ) *to++ = t[i];
+				for ( i = 0; i < nargs; i++ ) {
+					from = args[i];
+					COPY1ARG(to,from);
+				}
+				from = t+t[1];
+				tstop = term + *term;
+				while ( from < tstop ) *to++ = *from++;
+				if ( odd && ( ( perm.sign & 1 ) != 0 ) ) to[-1] = -to[-1];
+				*termout = to - termout;
+				AT.WorkPointer = to;
+				if ( Generator(BHEAD termout,level) ) Terminate(-1);
+				AT.WorkPointer = oldworkpointer;
+			}
+			return(0);
+		}
+		t += t[1];
+	}
+	return(0);
+}
+
+/*
+  	#] DoPermutations : 
   	#[ DoShuffle :
 
 	Merges the arguments of all occurrences of function fun into a

sources/structs.h

@@ -1012,6 +1012,18 @@ typedef struct PeRmUtE {
     PADPOINTER(0,0,MAXMATCH+2,0);
 } PERM;
 
+/**
+ *  Like struct PERM but works with pointers.
+ */
+
+typedef struct PeRmUtEp {
+    WORD **objects;
+    WORD sign;
+    WORD n;
+    WORD cycle[MAXMATCH];
+    PADPOINTER(0,0,MAXMATCH+2,0);
+} PERMP;
+
 /**
  *  The struct DISTRIBUTE is used to help the pattern
  *  matcher when matching antisymmetric tensors.

sources/symmetr.c

@@ -469,6 +469,40 @@ WORD Permute(PERM *perm, WORD first)
 
 /*
   	#] Permute : 
+  	#[ PermuteP :				WORD PermuteP(perm,first)
+
+	Like Permute, but works on an array of pointers
+*/
+
+WORD PermuteP(PERMP *perm, WORD first)
+{
+	WORD **s, *c, i, j;
+	if ( first ) {
+		perm->sign = ( perm->sign <= 1 ) ? 0: 1;
+		for ( i = 0; i < perm->n; i++ ) perm->cycle[i] = 0;
+		return(0);
+	}
+	i = perm->n;
+	while ( --i > 0 ) {
+		s = perm->objects;
+		c = s[0];
+		j = i;
+		while ( --j >= 0 ) { *s = s[1]; s++; }
+		*s = c;
+		if ( ( i & 1 ) != 0 ) perm->sign ^= 1;
+		if ( perm->cycle[i] < i ) {
+			(perm->cycle[i])++;
+			return(0);
+		}
+		else {
+			perm->cycle[i] = 0;
+		}
+	}
+	return(1);
+}
+
+/*
+  	#] PermuteP : 
   	#[ Distribute :
 */