===================================================================
RCS file: /home/cvs/OpenXM/src/k097/slib.k,v
retrieving revision 1.3
retrieving revision 1.9
diff -u -p -r1.3 -r1.9
--- OpenXM/src/k097/slib.k	2000/12/10 02:21:46	1.3
+++ OpenXM/src/k097/slib.k	2001/01/08 05:26:49	1.9
@@ -1,4 +1,4 @@
-/* $OpenXM: OpenXM/src/k097/slib.k,v 1.2 2000/01/21 03:01:26 takayama Exp $ */
+/* $OpenXM: OpenXM/src/k097/slib.k,v 1.8 2001/01/05 11:14:25 takayama Exp $ */
 /*  slib.sm1, standard library. */
 /* April 26-- , 1996 */
 /* Don't use function names that is already used as a postscipt macro names*/
@@ -8,11 +8,62 @@
 if (K00_verbose) 
  sm1(" ( slib.k (slib.ccc): 8/17,1996, 3/4 -- 3/10,1997 ) message ");
 
+
+/*
+  Each Helplist[i] has the format
+   [ category, [ key, explanations, ( args ,) (refs ,) (short descriptions)]]
+     category : null or string
+     key      : string
+     explanations : string or array of string   (Ex. and << >> are key words)
+     args     : null or list of strings
+     refs     : null or list of strings
+     short descriptions : string
+*/
 Helplist = [ ];
-def void HelpAdd(s) {
+def void HelpAdd(s,category) {
+  local n;
+  n = Length(Arglist);
+  if (n <= 1) {
+    category = null;
+  }
+  if (true) {
+    /* Assert the args */
+    /* You can use functions only defined before using HelpAdd */
+    if (!(n == 1 || n == 2)) {
+      Println(s);
+      Error("HelpAdd: wrong argument length.");
+    }
+    if (!(Tag(category) == 0 || Tag(category) == 5)) {
+      Println(category);
+      Error("HelpAdd: wrong category.");
+    }
+    if (!(Tag(s) == 6)) {
+      Println(s);
+      Error("HelpAdd: s must be an array.");
+    }
+    if (! (Tag(s[0]) == 5)) {
+      Println(s);
+      Error("HelpAdd: s[0] must be a string.");
+    }
+    if (! (Tag(s[1]) == 5 || Tag(s[1]) == 6)) {
+      Println(s);
+      Error("HelpAdd: s[1] must be a string or an array.");
+    }
+    /* End of assert */
+  }
+  s = [category,s];
   Helplist = Append(Helplist,s);
 }
 
+def Tag(f) {
+  local ans;
+  ans = sm1(f," etag (universalNumber) dc ");
+  return(ans);
+}
+def Error(s) {
+  sm1(" s error ");
+}
+
 def Print(a) {                      /* print object without new line */
   sm1(a," messagen");
 }
@@ -37,13 +88,6 @@ def Append(f,g) { return(Join(f,[g])); }
 
 def Length(f) { sm1(f," length (universalNumber) dc /FunctionValue set"); }
 
-def Indexed(name,i) {
-  sm1(name,i," s.Indexed /FunctionValue set ");
-}
-/* Indexed2("a",2,3) ---> "a[2,3]" */
-def Indexed2(name,i,j) {
-  sm1(name,i,j," s.Indexed2 /FunctionValue set ");
-}
 def Transpose(mat) {
   sm1(mat," transpose /FunctionValue set ");
 }
@@ -78,12 +122,71 @@ def LiftStd(F) { /* Print("Input is "); Println(F); */
                             [arg1 [(needBack)]] groebner 
                             /FunctionValue set "); }
 
+/*
 def Reduction(f,G) { 
   sm1(f,G," reduction /FunctionValue set ");
 }
+*/
+def Reduction(f,myset) {
+  local n, indexTable, set2, i, j, tmp, t_syz,r,rng,
+        vsize,tt;
+  vsize = null;
+  r = GetRing(Poly("1"));  /* Save the current ring */
+  rng = GetRing(f);
+  if (Tag(rng) == 0) {
+    rng = GetRing(myset);
+  }
+  if (Tag(rng) != 0) {SetRing(rng);}
 
+  if (IsArray(f)) {
+     vsize = Length(f);
+     sm1(" [f] fromVectors 0 get /f set ");
+  }
 
+  n = Length(myset);
+  if (n > 0) {
+    if (IsArray(myset[0])) {
+      if (vsize != Length(myset[0])) {
+         Error("Reduction: size mismatch.");
+      }
+      sm1(" myset fromVectors /myset set ");
+    }
+  }
 
+  indexTable = NewArray(n);
+  set2 = [ ];
+  j = 0;
+  for (i=0; i<n; i++) {
+    if (Tag(myset[i]) == 0) {
+      indexTable[i] = -1;
+    }else if (myset[i] == Poly("0")) {
+      indexTable[i] = -1; 
+    }else{
+      set2 = Append(set2,myset[i]);
+      indexTable[i] = j;
+      j++;
+    }
+  }
+  sm1(" f set2 (gradedPolySet) dc reduction /tmp set ");
+  t_syz = NewArray(n);
+  for (i=0; i<n; i++) {
+    if (indexTable[i] != -1) {
+      t_syz[i] = tmp[2, indexTable[i]];
+    }else{
+      t_syz[i] = Poly("0");
+    }
+  }
+  if (Tag(vsize) != 0) {
+    tt = tmp[0];
+    sm1(" [vsize (integer) dc tt] toVectors /tt set ");
+    tmp[0] = tt;
+  }
+  SetRing(r);
+  return([tmp[0],tmp[1],t_syz]);
+}
+
+
+
 def IntegerToSm1Integer(f) {
   sm1(f, " (integer) dc /FunctionValue set ");
 }
@@ -94,6 +197,7 @@ def RingD(vList,weightMatrix,pp) {
     sm1("[", vList, 
         "ring_of_differential_operators ( ) elimination_order 0 ] define_ring
          /tmp set ");
+    SetRingVariables();
     return(tmp);
   } else ;
   if (argsize == 2) {
@@ -117,7 +221,7 @@ def RingD(vList,weightMatrix,pp) {
   ringpp =
   sm1("[", vList, 
       "ring_of_differential_operators ", new0, " weight_vector",pp, " ] define_ring");
-  /* setRingVariables();  It doesn't work. It's a mystery. */
+  SetRingVariables();
   sm1(" @@@.indexMode.flag.save @@@.indexMode ");
   return( ringpp );
 }
@@ -144,7 +248,7 @@ def getvarn() {
   sm1( "[(N)] system_variable (universalNumber) dc /FunctionValue set ");
 }
 
-SetRingVariables_Verbose = true;
+SetRingVariables_Verbose = false;
 def SetRingVariables() {
   /* Don't use local variables in this function,
      because we set global variables in this function.
@@ -152,42 +256,32 @@ def SetRingVariables() {
   if (SetRingVariables_Verbose ) {
     Print("SetRingVariables() Setting the global variables : ");
   }
-  k00setRingVariables(0,sm1( "[(CC)] system_variable (universalNumber) dc "));
-  k00setRingVariables(sm1( "[(C)] system_variable (universalNumber) dc "),
-                      sm1( "[(LL)] system_variable (universalNumber) dc "));
-  k00setRingVariables(sm1( "[(L)] system_variable (universalNumber) dc "),
-                      sm1( "[(MM)] system_variable (universalNumber) dc "));
-  k00setRingVariables(sm1( "[(M)] system_variable (universalNumber) dc "),
-                      sm1( "[(NN)] system_variable (universalNumber) dc "));
+  if (k00setRingVariables(0,sm1( "[(N)] system_variable (universalNumber) dc "))) {
+    sm1(" define_ring_variables ");
+  }
   if (SetRingVariables_Verbose) {Ln();}
 }
 
 def k00AreThereLeftBrace(s) {
   local leftBrace, jj, slist;
   leftBrace = sm1(" $[$ (array) dc 0 get (universalNumber) dc ");
-  jj = Position(StringToIntegerArray(s),leftBrace);
+  jj = Position(StringToAsciiArray(s),leftBrace);
   if (jj != -1) return(true); else return(false);
 }
 
-def void k00setRingVariables(tmp002_p,tmp002_q) {
-  /* tmp002_ must not be used as variables names. */
-  local tmp002_i,tmp002_v,tmp002_str;
-  PSfor (tmp002_i=tmp002_p;tmp002_i<tmp002_q;tmp002_i++) {
-    tmp002_v = getxvar(tmp002_i);
-    if (k00AreThereLeftBrace(tmp002_v)) { ; } 
-    else {
-      if (SetRingVariables_Verbose) {Print(tmp002_v); Print(" ");}
-      str = AddString(["/",tmp002_v," $",tmp002_v,"$ (poly) data_conversion def "]);
-      sm1("[(parse) ",str," ] extension ");
+def k00setRingVariables(p,q) {
+  local v,i;
+  for (i = p; i< q; i++) {
+    v = getxvar(i);
+    if (k00AreThereLeftBrace(v)) { 
+       return(false);
     }
-    tmp002_v = getdvar(tmp002_i);
-    if (k00AreThereLeftBrace(tmp002_v)) { ; } 
-    else {
-      if (SetRingVariables_Verbose) {Print(tmp002_v); Print(" ");}
-      str = AddString(["/",tmp002_v," $",tmp002_v,"$ (poly) data_conversion def "]);
-      sm1("[(parse) ",str," ] extension ");
+	v = getdvar(i);
+    if (k00AreThereLeftBrace(v)) {
+       return(false);
     }
   }
+  return(true);
 }
 /* ---------------------------------- */
 
@@ -274,9 +368,6 @@ def Replace(f,rule) {
 def Map(karg,func) {
   sm1(karg," { [ 2 -1 roll ] this 2 -1 roll [(parse) ",func," ] extension pop } map /FunctionValue set");
 }
-HelpAdd(["Map",
- ["Map(karg,func) applies the function <<func>> to the <<karg>>(string func).",
-  " Ex. Map([82,83,85],\"AsciiToString\"):"]]);
 /* test Map
 def foo1(i) { return(i*2); }
 def foo() {
@@ -297,32 +388,81 @@ def Position(list,elem) {
   sm1(" /k00.label0 ");
   return(pos);
 }
-HelpAdd(["Position",
- ["Position(list,elem) returns the position p of the element <<elem>> in",
-  " the array <<list>>. If <<elem>> is not in <<list>>, it return -1",
-  " (array list).",
-  "Ex. Position([1,34,2],34): "]]);
 
-def StringToIntegerArray(s) {
+def StringToAsciiArray(s) {
   sm1(s," (array) dc { (universalNumber) dc } map /FunctionValue set ");
 }
-HelpAdd(["StringToIntegerArray",
- ["StringToIntegerArray(s) decomposes the string <<s>> into an array of",
-  "ascii codes of <<s>>  (string s).",
-  "cf. AsciiToString."]]);
-def StringToAsciiArray(s) { return(StringToIntegerArray(s)); }
-HelpAdd(["StringToAsciiArray",
- ["StringToAsciiArray(s) is StringToIntegerArray(s)."]]);
 
-
 def NewArray(n) {
  return(NewVector(n));
 }
-HelpAdd(["NewArray",
-["NewArray(n) returns an array of size n (integer n)."]]);
 
 def GetEnv(s) {
  sm1(" [(getenv) s] extension /FunctionValue set ");
 }
-HelpAdd(["GetEnv",
-["GetEnv(s) returns the value of the environmental variable s (string s)."]]);
+def Boundp(a) {
+   local b;
+   sm1("[(parse) [(/) ",a," ( load tag 0 eq 
+                          { /FunctionValue 0 def }
+                          { /FunctionValue 1 def } ifelse )] cat ] extension");
+}
+def Rest(a) {
+  sm1(a," rest /FunctionValue set ");
+}
+def GetPathName(s) {
+  local t,sss;
+  sss = s;
+  sm1(" [(stat) s] extension 0 get /t set ");
+  if (Tag(t) == 0) {
+    s=AddString([GetEnv("LOAD_K_PATH"),"/",s]);
+    sm1(" [(stat) s] extension 0 get /t set ");
+    if (Tag(t) == 0) {
+      return(null); 
+    }else{
+      return(s);
+    }
+  }else{
+    return(s);
+  }
+}
+
+def Load_sm1(fnames,flag) {
+  local ppp,n,i,cmd;
+  if (Boundp(flag)) {
+  }else{
+    n = Length(fnames);
+    for (i=0; i<n; i++) {
+       ppp = GetPathName(fnames[i]);
+       if (Tag(ppp) != 0) {
+          sm1(" [(parse) ppp pushfile ] extension ");
+          cmd = AddString(["/",flag," 1 def "]);
+          sm1(" [(parse) cmd ] extension ");
+          i=n; /* break; */
+       }
+    }
+  }
+}
+
+
+def GetRing(f) {
+  sm1(" f getRing /FunctionValue set ");
+}
+
+def SetRing(r) {
+  sm1(" r ring_def ");
+}
+
+def ReParse(a) {
+  local c;
+  if (IsArray(a)) {
+    c = Map(a,"ReParse");
+  }else{
+    sm1(a," toString . /c set");
+  }
+  return(c);
+}
+
+def void Pmat(a) {
+   sm1(" a pmat ");
+}
+