===================================================================
RCS file: /home/cvs/OpenXM/src/kan96xx/Kan/order.c,v
retrieving revision 1.1
retrieving revision 1.16
diff -u -p -r1.1 -r1.16
--- OpenXM/src/kan96xx/Kan/order.c	1999/10/08 02:12:01	1.1
+++ OpenXM/src/kan96xx/Kan/order.c	2018/09/07 00:15:44	1.16
@@ -1,4 +1,6 @@
+/* $OpenXM: OpenXM/src/kan96xx/Kan/order.c,v 1.15 2005/07/03 11:08:54 ohara Exp $ */
 #include <stdio.h>
+#include <stdlib.h>
 #include "datatype.h"
 #include "stackm.h"
 #include "extern.h"
@@ -20,15 +22,15 @@ static void warningOrder(char *s);
 static void errorOrder(char *s);
 
 void setOrderByMatrix(order,n,c,l,omsize)
-int order[];
-int n,c,l,omsize;
+     int order[];
+     int n,c,l,omsize;
 {
   int i,j;
   int *Order;
   extern struct ring *CurrentRingp;
 
   switch_mmLarger("default");
-    /* q-case */
+  /* q-case */
   if ( l-c > 0) {
     switch_mmLarger("qmatrix");
   }
@@ -45,8 +47,8 @@ int n,c,l,omsize;
 }
   
 void showRing(level,ringp) 
-int level;
-struct ring *ringp;
+     int level;
+     struct ring *ringp;
 {
   int i,j;
   FILE *fp;
@@ -57,6 +59,10 @@ struct ring *ringp;
   int P;
   char *mtype;
   extern char *F_isSameComponent;
+  POLY f;
+  POLY fx;
+  POLY fd;
+  POLY rf;
   fp = stdout;
 
   N=ringp->n; M = ringp->m; L = ringp->l; C = ringp->c;
@@ -79,8 +85,10 @@ struct ring *ringp;
     fprintf(fp,"\n");
     fprintf(fp,"where ");
     for (i=M; i<N; i++) {
-      fprintf(fp," %s %s - %s %s = 1, ",TransD[i],TransX[i],
-	                                TransX[i],TransD[i]);
+      fx = cxx(1,i,1,ringp); fd = cdd(1,i,1,ringp);
+	  rf = ppSub(ppMult(fd,fx),ppMult(fx,fd));
+      fprintf(fp," %s %s - %s %s = %s, ",TransD[i],TransX[i],
+              TransX[i],TransD[i],POLYToString(rf,'*',0));
     }
     fprintf(fp,"\n\n");
   }
@@ -91,9 +99,11 @@ struct ring *ringp;
     fprintf(fp,"\n");
     fprintf(fp,"where ");
     for (i=L; i<M; i++) {
-      fprintf(fp," %s %s - %s %s = %s, ",TransD[i],TransX[i],
-	                                 TransX[i],TransD[i],
-	                                 TransD[i]);
+      fprintf(fp," %s %s - %s %s = ",TransD[i],TransX[i],
+              TransX[i],TransD[i]);
+      f=ppSub(ppMult(cdd(1,i,1,ringp),cxx(1,i,1,ringp)),
+              ppMult(cxx(1,i,1,ringp),cdd(1,i,1,ringp)));
+      fprintf(fp," %s, ",POLYToString(f,'*',0));
     }
     fprintf(fp,"\n\n");
   }
@@ -105,8 +115,8 @@ struct ring *ringp;
     fprintf(fp,"where ");
     for (i=C; i<L; i++) {
       fprintf(fp," %s %s = %s %s %s, ",TransD[i],TransX[i],
-	                               TransX[0],
-	                               TransX[i],TransD[i]);
+              TransX[0],
+              TransX[i],TransD[i]);
     }
     fprintf(fp,"\n\n");
   }
@@ -164,15 +174,37 @@ struct ring *ringp;
   }else {
     mtype = "unknown";
   }
-  fprintf(fp,"Multiplication function --%s(%xH).\n",
-	  mtype,(unsigned int) ringp->multiplication);
+  fprintf(fp,"Multiplication function --%s(%p).\n",
+          mtype, ringp->multiplication);
   if (ringp->schreyer) {
     fprintf(fp,"schreyer=1, gbListTower=");
     printObjectList((struct object *)(ringp->gbListTower));
     fprintf(fp,"\n");
   }
-
+  if (ringp->degreeShiftSize) {
+    fprintf(fp,"degreeShift vector (N=%d,Size=%d)= \n[\n",ringp->degreeShiftN,ringp->degreeShiftSize);
+    {
+      int i,j;
+      for (i=0; i<ringp->degreeShiftN; i++) {
+        fprintf(fp," [");
+        for (j=0; j< ringp->degreeShiftSize; j++) {
+          fprintf(fp," %d ",ringp->degreeShift[i*(ringp->degreeShiftSize)+j]);
+        }
+        fprintf(fp,"]\n");
+      }
+    }
+    fprintf(fp,"]\n");
+  }
+  fprintf(fp,"---  weight vectors ---\n");
   if (level) printOrder(ringp);
+
+  if (ringp->partialEcart) {
+    fprintf(fp,"---  partialEcartGlobalVarX ---\n");
+    for (i=0; i<ringp->partialEcart; i++) {
+      fprintf(fp," %4s ",TransX[ringp->partialEcartGlobalVarX[i]]);
+    }
+    fprintf(fp,"\n");
+  }
   
   if (ringp->next != (struct ring *)NULL) {
     fprintf(fp,"\n\n-------- The next ring is .... --------------\n");
@@ -202,7 +234,7 @@ if (isD(i))  D_{itod(i)}
 */
 
 void printOrder(ringp)
-struct ring *ringp;
+     struct ring *ringp;
 {
   int i,j;
   FILE *fp;
@@ -244,9 +276,9 @@ struct ring *ringp;
   fprintf(fp,"\n");
 
   /* print D: differential     DE: differential, should be eliminated
-           E: difference
-	   Q: q-difference
-	   C: commutative
+     E: difference
+     Q: q-difference
+     C: commutative
   */
   if (strcmp(F_isSameComponent,"x")== 0 || strcmp(F_isSameComponent,"xd")==0) {
     for (i=0; i<N; i++) {
@@ -295,7 +327,8 @@ struct ring *ringp;
 
 struct object oGetOrderMatrix(struct ring *ringp)
 {
-  struct object rob,ob2;
+  struct object rob = OINIT;
+  struct object ob2 = OINIT;
   int n,i,j,m;
   int *om;
   n = ringp->n;
@@ -315,7 +348,7 @@ struct object oGetOrderMatrix(struct ring *ringp)
 
 
 int mmLarger_matrix(ff,gg)
-POLY ff; POLY gg;
+     POLY ff; POLY gg;
 {
   int exp[2*N0]; /* exponents */
   int i,k;
@@ -327,6 +360,9 @@ POLY ff; POLY gg;
   int in2;
   int *from, *to;
   int omsize;
+  int dssize;
+  int dsn;
+  int *degreeShiftVector;
   
   if (ff == POLYNULL ) {
     if (gg == POLYNULL) return( 2 );
@@ -344,6 +380,10 @@ POLY ff; POLY gg;
   from = rp->from;
   to = rp->to;
   omsize = rp->orderMatrixSize;
+  if (dssize = rp->degreeShiftSize) {
+	degreeShiftVector = rp->degreeShift;  /* Note. 2003.06.26 */
+	dsn = rp->degreeShiftN;
+  }
  
   flag = 1;
   for (i=N-1,k=0; i>=0; i--,k++) {
@@ -360,6 +400,15 @@ POLY ff; POLY gg;
     sum = 0; in2 = i*2*N;
     /* for (k=0; k<2*N; k++) sum += exp[k]*Order[in2+k]; */
     for (k=from[i]; k<to[i]; k++) sum += exp[k]*Order[in2+k];
+    if (dssize && ( i < dsn)) { /* Note, 2003.06.26 */
+      if ((f->e[N-1].x < dssize) && (f->e[N-1].x >= 0) &&
+          (g->e[N-1].x < dssize) && (g->e[N-1].x >= 0)) {
+        sum += degreeShiftVector[i*dssize+ (f->e[N-1].x)]
+              -degreeShiftVector[i*dssize+ (g->e[N-1].x)];
+      }else{
+        /*warningOrder("Size mismatch in the degree shift vector. It is ignored.");*/
+      }
+    }
     if (sum > 0) return(1);
     if (sum < 0) return(0);
   }
@@ -368,7 +417,7 @@ POLY ff; POLY gg;
 
 /* This should be used in case of q */
 int mmLarger_qmatrix(ff,gg)
-POLY ff; POLY gg;
+     POLY ff; POLY gg;
 {
   int exp[2*N0]; /* exponents */
   int i,k;
@@ -417,8 +466,8 @@ POLY ff; POLY gg;
 
 /* x(N-1)>x(N-2)>....>D(N-1)>....>D(0) */
 mmLarger_pureLexicographic(f,g)
-POLY f;
-POLY g;
+     POLY f;
+     POLY g;
 {
   int i,r;
   int n;
@@ -457,7 +506,7 @@ POLY g;
 
 
 void setFromTo(ringp)
-struct ring *ringp;
+     struct ring *ringp;
 {
   int n;
   int i,j,oasize;
@@ -473,14 +522,14 @@ struct ring *ringp;
     ringp->from[i] = 0; ringp->to[i] = n;
     for (j=0; j<n; j++) {
       if (ringp->order[i*n+j] != 0) {
-	ringp->from[i] = j;
-	break;
+        ringp->from[i] = j;
+        break;
       }
     }
     for (j=n-1; j>=0; j--) {
       if (ringp->order[i*n+j] != 0) {
-	ringp->to[i] = j+1;
-	break;
+        ringp->to[i] = j+1;
+        break;
       }
     }
   }
@@ -489,7 +538,7 @@ struct ring *ringp;
 /* It ignores h and should be used with mmLarger_tower */
 /* cf. mmLarger_matrix.  h always must be checked at last. */
 static int mmLarger_matrix_schreyer(ff,gg)
-POLY ff; POLY gg;
+     POLY ff; POLY gg;
 {
   int exp[2*N0]; /* exponents */
   int i,k;
@@ -557,16 +606,16 @@ int mmLarger_tower(POLY f,POLY g) {
   }
   if (!(f->m->ringp->schreyer) || !(g->m->ringp->schreyer))
     return(mmLarger_matrix(f,g));
-    /* modifiable: mmLarger_qmatrix */
+  /* modifiable: mmLarger_qmatrix */
   gbList = (struct object *)(g->m->ringp->gbListTower);
   if (gbList == NULL) return(mmLarger_matrix(f,g));
-                      /* modifiable: mmLarger_qmatrix */
+  /* modifiable: mmLarger_qmatrix */
   if (gbList->tag != Slist) {
     warningOrder("mmLarger_tower(): gbList must be in Slist.\n");
     return(1);
   }
   if (klength(gbList) ==0) return(mmLarger_matrix(f,g));
-                      /* modifiable: mmLarger_qmatrix */
+  /* modifiable: mmLarger_qmatrix */
 
   r = mmLarger_tower3(f,g,gbList);
   /* printf("mmLarger_tower3(%s,%s) -->  %d\n",POLYToString(head(f),'*',1),POLYToString(head(g),'*',1),r); */
@@ -584,7 +633,7 @@ int mmLarger_tower3(POLY f,POLY g,struct object *gbLis
   int n,fv,gv,t,r,nn;
   POLY fm;
   POLY gm;
-  struct object gb;
+  struct object gb = OINIT;
 
   if (f == POLYNULL) {
     if (g == POLYNULL)  return(2);
@@ -597,7 +646,7 @@ int mmLarger_tower3(POLY f,POLY g,struct object *gbLis
   n = f->m->ringp->n;
   nn = f->m->ringp->nn;
   /* critical and modifiable */  /* m e_u > m e_v <==> m g_u > m g_v */
-                                 /*                  or equal and u < v */  
+  /*                  or equal and u < v */  
   fv = f->m->e[nn].x ; /* extract component (vector) number of f! */
   gv = g->m->e[nn].x ;
   if (fv == gv) { /* They have the same component number. */
@@ -605,13 +654,13 @@ int mmLarger_tower3(POLY f,POLY g,struct object *gbLis
   }
 
   if (gbList == NULL) return(mmLarger_matrix_schreyer(f,g));
-                      /* modifiable: mmLarger_qmatrix */
+  /* modifiable: mmLarger_qmatrix */
   if (gbList->tag != Slist) {
     warningOrder("mmLarger_tower(): gbList must be in Slist.\n");
     return(1);
   }
   if (klength(gbList) ==0) return(mmLarger_matrix(f,g));
-                      /* modifiable: mmLarger_qmatrix */
+  /* modifiable: mmLarger_qmatrix */
   gb = car(gbList);  /* each entry must be monomials */
   if (gb.tag != Sarray) {
     warningOrder("mmLarger_tower3(): car(gbList) must be an array.\n");
@@ -625,7 +674,8 @@ int mmLarger_tower3(POLY f,POLY g,struct object *gbLis
   if (fv >= t || gv >= t) {
     warningOrder("mmLarger_tower3(): incompatible input and gbList.\n");
     printf("Length of gb is %d, f is %s, g is %s\n",t,KPOLYToString(f),
-	   KPOLYToString(g));
+           KPOLYToString(g));
+    KSexecuteString(" show_ring ");
     return(1);
   }
   /* mpMult_poly is too expensive to call. @@@*/
@@ -637,15 +687,237 @@ int mmLarger_tower3(POLY f,POLY g,struct object *gbLis
   else if (fv > gv) return(0); /* modifiable */
   else if (fv < gv) return(1); /* modifiable */
 }
-  
+
+static struct object auxPruneZeroRow(struct object ob) {
+  int i,m,size;
+  struct object obt = OINIT;
+  struct object rob = OINIT;
+  m = getoaSize(ob);
+  size=0;
+  for (i=0; i<m; i++) {
+	obt = getoa(ob,i);
+	if (getoaSize(obt) != 0) size++;
+  }
+  if (size == m) return ob;
+  rob = newObjectArray(size);
+  for (i=0, size=0; i<m; i++) {
+	obt = getoa(ob,i);
+	if (getoaSize(obt) != 0) {
+	  putoa(rob,size,obt); size++;
+	}
+  }
+  return rob;
+}  
+static struct object oRingToOXringStructure_long(struct ring *ringp)
+{
+  struct object rob = OINIT;
+  struct object ob2 = OINIT;
+  struct object obMat = OINIT;
+  struct object obV = OINIT;
+  struct object obShift = OINIT;
+  struct object obt = OINIT;
+  char **TransX; char **TransD;
+  int n,i,j,m,p,nonzero;
+  int *om;
+  n = ringp->n;
+  m = ringp->orderMatrixSize;
+  om = ringp->order;
+  TransX = ringp->x; TransD = ringp->D;
+  if (m<=0) m = 1;
+  /*test: (1). getRing /rr set rr (oxRingStructure) dc  */
+  obMat = newObjectArray(m);
+  for (i=0; i<m; i++) {
+    nonzero = 0;
+    for (j=0; j<2*n; j++) {
+      if (om[2*n*i+j] != 0) nonzero++;
+    }
+    ob2 = newObjectArray(nonzero*2);
+    nonzero=0;
+    for (j=0; j<2*n; j++) {
+      /* fprintf(stderr,"%d, ",nonzero); */
+      if (om[2*n*i+j] != 0) {
+        if (j < n) {
+          putoa(ob2,nonzero,KpoString(TransX[n-1-j])); nonzero++;
+        }else{
+          putoa(ob2,nonzero,KpoString(TransD[n-1-(j-n)])); nonzero++;
+        }
+        putoa(ob2,nonzero,KpoUniversalNumber(newUniversalNumber(om[2*n*i+j]))); nonzero++;
+      }
+    }
+    /* printObject(ob2,0,stderr); fprintf(stderr,".\n"); */
+    putoa(obMat,i,ob2);
+  }
+  obMat = auxPruneZeroRow(obMat);
+  /* printObject(obMat,0,stderr); */
+
+  obV = newObjectArray(2*n);
+  for (i=0; i<n; i++) putoa(obV,i,KpoString(TransX[n-1-i]));
+  for (i=0; i<n; i++) putoa(obV,i+n,KpoString(TransD[n-1-i]));
+  /* printObject(obV,0,stderr); */
+
+  if (ringp->degreeShiftSize) {
+    /*test:
+    [(x) ring_of_differential_operators [[(x)]] weight_vector 0
+      [(weightedHomogenization) 1 (degreeShift) [[1 2 1]]] ] define_ring ;
+     (1). getRing /rr set rr (oxRingStructure) dc message
+    */
+    obShift = newObjectArray(ringp->degreeShiftN);
+    for (i=0; i<ringp->degreeShiftN; i++) {
+      obt = newObjectArray(ringp->degreeShiftSize);
+      for (j=0; j< ringp->degreeShiftSize; j++) {
+        putoa(obt,j,KpoUniversalNumber(newUniversalNumber(ringp->degreeShift[i*(ringp->degreeShiftSize)+j])));
+      }
+      putoa(obShift,i,obt);
+    }
+    /* printObject(obShift,0,stderr); */
+  }
+
+  p = 0;
+  if (ringp->degreeShiftSize) {
+    rob = newObjectArray(3);
+    obt = newObjectArray(2);
+    putoa(obt,0,KpoString("degreeShift"));
+    putoa(obt,1,obShift);
+    putoa(rob,p, obt); p++;
+  }else {
+    rob = newObjectArray(2);
+  }
+
+  obt = newObjectArray(2);
+  putoa(obt,0,KpoString("v"));
+  putoa(obt,1,obV);
+  putoa(rob,p, obt); p++;
+
+  obt = newObjectArray(2);
+  putoa(obt,0,KpoString("order"));
+  putoa(obt,1,obMat);
+  putoa(rob,p, obt); p++;
+
+  return(rob);
+}
+static int auxEffectiveVar(int idx,int n) {
+  int x;
+  if (idx < n) x=1; else x=0;
+  if (x) {
+	if ((idx >= 1) && (idx < n-1)) return 1;
+	else return 0;
+  }else{
+	if ( 1 <= idx-n )  return 1;
+	else return 0;
+  }
+}
+/*test: 
+   [(x,y) ring_of_differential_operators [[(Dx) 1 (Dy)  1]]
+    weight_vector 0] define_ring
+    (x). getRing (oxRingStructure) dc ::
+ */
+static struct object oRingToOXringStructure_short(struct ring *ringp)
+{
+  struct object rob = OINIT;
+  struct object ob2 = OINIT;
+  struct object obMat = OINIT;
+  struct object obV = OINIT;
+  struct object obShift = OINIT;
+  struct object obt = OINIT;
+  char **TransX; char **TransD;
+  int n,i,j,m,p,nonzero;
+  int *om;
+  n = ringp->n;
+  m = ringp->orderMatrixSize;
+  om = ringp->order;
+  TransX = ringp->x; TransD = ringp->D;
+  if (m<=0) m = 1;
+  /*test: (1). getRing /rr set rr (oxRingStructure) dc  */
+  obMat = newObjectArray(m);
+  for (i=0; i<m; i++) {
+    nonzero = 0;
+    for (j=0; j<2*n; j++) {
+      if ((om[2*n*i+j] != 0) && auxEffectiveVar(j,n)) nonzero++;
+    }
+    ob2 = newObjectArray(nonzero*2);
+    nonzero=0;
+    for (j=0; j<2*n; j++) {
+      /* fprintf(stderr,"%d, ",nonzero); */
+      if ((om[2*n*i+j] != 0) && auxEffectiveVar(j,n)) {
+        if (j < n) {
+          putoa(ob2,nonzero,KpoString(TransX[n-1-j])); nonzero++;
+        }else{
+          putoa(ob2,nonzero,KpoString(TransD[n-1-(j-n)])); nonzero++;
+        }
+        putoa(ob2,nonzero,KpoUniversalNumber(newUniversalNumber(om[2*n*i+j]))); nonzero++;
+      }
+    }
+    /* printObject(ob2,0,stderr); fprintf(stderr,".\n"); */
+    putoa(obMat,i,ob2);
+  }
+  obMat = auxPruneZeroRow(obMat);
+  /* printObject(obMat,0,stderr); */
+
+  obV = newObjectArray(2*n-3);
+  for (i=0; i<n-2; i++) putoa(obV,i,KpoString(TransX[n-1-i-1]));
+  for (i=0; i<n-1; i++) putoa(obV,i+n-2,KpoString(TransD[n-1-i-1]));
+  /* printObject(obV,0,stderr); */
+
+  if (ringp->degreeShiftSize) {
+    /*test:
+    [(x) ring_of_differential_operators [[(x)]] weight_vector 0
+      [(weightedHomogenization) 1 (degreeShift) [[1 2 1]]] ] define_ring ;
+     (1). getRing /rr set rr (oxRingStructure) dc message
+    */
+    obShift = newObjectArray(ringp->degreeShiftN);
+    for (i=0; i<ringp->degreeShiftN; i++) {
+      obt = newObjectArray(ringp->degreeShiftSize);
+      for (j=0; j< ringp->degreeShiftSize; j++) {
+        putoa(obt,j,KpoUniversalNumber(newUniversalNumber(ringp->degreeShift[i*(ringp->degreeShiftSize)+j])));
+      }
+      putoa(obShift,i,obt);
+    }
+    /* printObject(obShift,0,stderr); */
+  }
+
+  p = 0;
+  if (ringp->degreeShiftSize) {
+    rob = newObjectArray(3);
+    obt = newObjectArray(2);
+    putoa(obt,0,KpoString("degreeShift"));
+    putoa(obt,1,obShift);
+    putoa(rob,p, obt); p++;
+  }else {
+    rob = newObjectArray(2);
+  }
+
+  obt = newObjectArray(2);
+  putoa(obt,0,KpoString("v"));
+  putoa(obt,1,obV);
+  putoa(rob,p, obt); p++;
+
+  obt = newObjectArray(2);
+  putoa(obt,0,KpoString("order"));
+  putoa(obt,1,obMat);
+  putoa(rob,p, obt); p++;
+
+  return(rob);
+}
+struct object oRingToOXringStructure(struct ring *ringp)
+{
+  struct object rob = OINIT;
+  struct object tob = OINIT;
+  rob = newObjectArray(2);
+  tob = oRingToOXringStructure_short(ringp);
+  putoa(rob,0,tob);
+  tob = oRingToOXringStructure_long(ringp);
+  putoa(rob,1,tob);
+  return(rob);
+}
+
 static void warningOrder(s)
-char *s;
+     char *s;
 {
   fprintf(stderr,"Warning in order.c: %s\n",s);
 }
 
 static void errorOrder(s)
-char *s;
+     char *s;
 {
   fprintf(stderr,"order.c: %s\n",s);
   exit(14);