===================================================================
RCS file: /home/cvs/OpenXM/src/kan96xx/Kan/dr.sm1,v
retrieving revision 1.16
retrieving revision 1.30
diff -u -p -r1.16 -r1.30
--- OpenXM/src/kan96xx/Kan/dr.sm1	2003/07/17 12:11:09	1.16
+++ OpenXM/src/kan96xx/Kan/dr.sm1	2004/08/23 08:33:55	1.30
@@ -1,4 +1,4 @@
-% $OpenXM: OpenXM/src/kan96xx/Kan/dr.sm1,v 1.15 2003/07/17 09:10:54 takayama Exp $
+% $OpenXM: OpenXM/src/kan96xx/Kan/dr.sm1,v 1.29 2004/08/22 12:52:34 takayama Exp $
 %% dr.sm1 (Define Ring) 1994/9/25, 26
 %% This file is error clean.
 
@@ -50,7 +50,7 @@
           } for
      ] /dList set
 
-     [(H)] xList join [@@@.esymbol] join /xList set
+     [@@@.Hsymbol] xList join [@@@.esymbol] join /xList set
      [(h)] dList join [@@@.Esymbol] join /dList set
      [0 %% dummy characteristic
       << xList length >> << xList length >> << xList length >> 
@@ -167,7 +167,7 @@
      vars reverse /xList set         %[z y x]
      vars {@@@.Dsymbol 2 1 roll 2 cat_n} map
      reverse /dList set              %[Dz Dy Dx]
-     [(H)] xList join [@@@.esymbol] join /xList set
+     [@@@.Hsymbol] xList join [@@@.esymbol] join /xList set
      [(h)] dList join [@@@.Esymbol] join /dList set
      [0 1 1 1 << xList length >>
         1 1 1 << xList length 1 sub >> ] /param set
@@ -269,7 +269,7 @@
      vars reverse /xList set         %[z y x]
      vars {@@@.diffEsymbol 2 1 roll 2 cat_n} map
      reverse /dList set              %[Dz Dy Dx]
-     [(H)] xList join [@@@.esymbol] join /xList set
+     [@@@.Hsymbol] xList join [@@@.esymbol] join /xList set
      [(h)] dList join [@@@.Esymbol] join /dList set
      [0 1 1 << xList length >> << xList length >>
         1 1 << xList length 1 sub >> << xList length >> ] /param set
@@ -308,7 +308,7 @@
      vars2 reverse
      vars {@@@.Dsymbol 2 1 roll 2 cat_n} map
      reverse join /dList set              %[s2 s1 Dz Dy Dx]
-     [(H)] xList join [@@@.esymbol] join /xList set
+     [@@@.Hsymbol] xList join [@@@.esymbol] join /xList set
      [(h)] dList join [@@@.Esymbol] join /dList set
      [0 1 1 << vars2 length 1 add >>  << xList length >>
         1 1 << vars2 length 1 add >> << xList length 1 sub >> ] /param set
@@ -1766,7 +1766,11 @@
   /arg1 set
   [/f /k /i /ans] pushVariables
   [
-     /ans (1).. def
+   /ans (1).. def
+   [(QuoteMode)] system_variable {
+     /f arg1 def   /k arg2 def
+     [(ooPower) f k] extension /ans set
+   } {
      /f arg1 def   /k arg2 ..int def
      k 0 lt {
        1 1 << 0 k sub >> {
@@ -1779,7 +1783,8 @@
          /ans f ans {mul} sendmsg2 def
        } for
      } ifelse
-     /arg1 ans def
+   } ifelse
+   /arg1 ans def
   ] pop
   popVariables
   arg1
@@ -2762,6 +2767,7 @@ newline
   [/in-ngcd /nlist /g.ngcd /ans] pushVariables
   [
      /nlist arg1 def
+     nlist to_univNum /nlist set
      nlist length 2 lt
      { /ans nlist 0 get def /L.ngcd goto }
      {
@@ -3322,6 +3328,10 @@ newline
 ]] putUsages
 
 /cancelCoeff {
+  /arg1 set
+  [(reduceContent) arg1] gbext 0 get
+} def
+/cancelCoeff_org {
  /arg1 set
  [/in-cancelCoeff /ff /gg /dd /dd2] pushVariables
  [  /ff arg1 def
@@ -3749,12 +3759,17 @@ $ [ff ff] fromVectors :: $ 
  ] 
 ] putUsages
 
+/ecart.debug_reduction1 0 def
 /beginEcart {
   (red@) (ecart) switch_function
   [(Ecart) 1] system_variable
   [(CheckHomogenization) 0] system_variable
   [(ReduceLowerTerms) 0] system_variable
   [(AutoReduce) 0] system_variable
+  [(EcartAutomaticHomogenization) 0] system_variable
+  ecart.debug_reduction1 {
+    (red@) (debug) switch_function
+  } {  } ifelse
 } def
 
 [(endEcart)
@@ -3767,7 +3782,382 @@ $ [ff ff] fromVectors :: $ 
 /endEcart {
   (red@) (standard) switch_function
   [(Ecart) 0] system_variable
+  [(degreeShift) (reset)] homogenize pop
 } def
+
+/ord_ws_all {
+  /arg2 set /arg1 set
+  [(ord_ws_all) arg1 arg2] gbext
+} def
+[(ord_ws_all)
+ [  
+   (fv wv ord_ws_all degree)
+   (  ord_ws_all returns the ord with respect to the weight vector wv.)
+   $Example: [(x,y) ring_of_differential_operators 0] define_ring  $
+   $        (Dx^2+x*Dx*Dy+2). [(Dx) 1 (Dy) 1] weightv ord_ws_all ::  $
+   (  )
+   (fv [wv shiftv] ord_ws_all degree)
+   (  ord_ws_all returns the ord with respect to the weight vector wv and)
+   (  the shift vector shiftv.)
+   $Example: [(x,y) ring_of_differential_operators 0] define_ring  $
+   $        [(Dx^2+x*Dx*Dy+2). (Dx).] [[(Dx) 1 (Dy) 1] weightv [0 2]] ord_ws_all ::$
+   (  )
+   (cf: init, gbext.   Obsolete: ord_w, ord_w_all)
+ ] 
+] putUsages
+
+[(newVector)
+ [( n newVector vec)
+]] putUsages
+/newVector {
+  /arg1 set
+  [/in-newVector /n] pushVariables
+  [
+    /n arg1 def
+    [(newVector) n] extension /arg1 set
+  ] pop
+  popVariables
+  arg1
+} def
+
+[(newMatrix)
+ [( [m n] newMatrix mat)
+]] putUsages
+/newMatrix {
+  /arg1 set
+  [/in-newMatrix /n] pushVariables
+  [
+    /n arg1 def
+    [(newMatrix) n 0 get n 1 get] extension /arg1 set
+  ] pop
+  popVariables
+  arg1
+} def
+
+/addStdoutStderr {
+  [(>) (stringOut://@@@stdout) (2>) (stringOut://@@@stderr)] join
+} def
+
+[(,,,)
+[(reparse a polynomial or polynomials)]
+] putUsages
+/,,, {
+  /arg1 set
+  [/in-reparse /ff] pushVariables
+  [
+    /ff arg1 def
+    ff tag 6 eq {
+      ff { ,,, } map /arg1 set
+    } {
+      ff toString . /arg1 set
+    } ifelse
+  ] pop
+  popVariables
+  arg1
+} def
+
+/to_univNum {
+  /arg1 set
+  [/rr  ] pushVariables
+  [
+    /rr arg1 def
+    rr isArray {
+      rr { to_univNum } map /rr set
+    } {  
+    } ifelse 
+    rr isInteger {
+      rr (universalNumber) dc /rr set
+    } {
+    } ifelse
+    /arg1 rr def
+  ] pop
+  popVariables
+  arg1 
+} def
+[(to_univNum) 
+[(obj to_univNum obj2)
+ (Example. [ 2 (3).. ] to_univNum)
+ (cf. to_int)
+]] putUsages
+
+[(lcm)
+ [ ([a b c ...] lcm r)
+   (cf. polylcm, mpzext)
+ ]
+] putUsages
+/lcm {
+  /arg1 set
+  [/aa /bb /rr /pp /i] pushVariables
+  [
+    /aa arg1 def
+    /rr (1).. def
+    /pp 0 def % isPolynomial array?
+    0 1 aa length 1 sub {
+      /i set
+      aa i get  isPolynomial {
+        /pp 1 def
+        exit
+      } {  } ifelse
+    } for
+
+    0 1 aa length 1 sub {
+      /i set
+      pp {
+        [rr aa i get] polylcm /rr set
+      } {  
+        [(lcm) rr aa i get ] mpzext /rr set
+      } ifelse
+    } for
+    
+    /arg1 rr def
+  ] pop
+  popVariables
+  arg1
+} def
+[(gcd)
+ [ ([a b c ...] gcd r)
+   (cf. polygcd, mpzext)
+ ]
+] putUsages
+/gcd {
+  /arg1 set
+  [/aa /bb /rr /pp /i] pushVariables
+  [
+    /aa arg1 def
+    /rr (1).. def
+    /pp 0 def % isPolynomial array?
+    0 1 aa length 1 sub {
+      /i set
+      aa i get  isPolynomial {
+        /pp 1 def
+        /rr aa i get def
+        exit
+      } {  } ifelse
+    } for
+
+    pp {
+     0 1 aa length 1 sub {
+       /i set
+       [rr aa i get] polygcd /rr set
+     } for
+    } {
+      aa ngcd /rr set
+    } ifelse
+    
+    /arg1 rr def
+  ] pop
+  popVariables
+  arg1
+} def
+
+[(denominator)
+ [ ([a b c ...] denominator r)
+   ( a denominator r )
+   (cf. dc, numerator)
+   (Output is Z or a polynomial.)
+ ]
+] putUsages
+% test data.
+%  [(1).. (2).. div (1).. (3).. div ] denominator
+%  [(2).. (3).. (4).. ] denominator
+/denominator {
+  /arg1 set
+  [/pp /dd /ii /rr] pushVariables
+  [
+    /pp arg1 def
+    pp to_univNum /pp set
+    {
+      pp isArray {
+        pp { denominator } map /dd set        
+        /rr dd lcm def % rr = lcm(dd[0], dd[1], ... )
+        rr /dd set 
+        exit
+      } {  } ifelse
+
+      pp (denominator) dc /dd set
+      exit
+
+    } loop
+    /arg1 dd def
+  ] pop
+  popVariables
+  arg1
+} def 
+
+[(numerator)
+ [ ([a b c ...] numerator r)
+   ( a numerator r )
+   (cf. dc, denominator)
+   (Output is a list of Z or polynomials.)
+ ]
+] putUsages
+% test data.
+/numerator {
+  /arg1 set
+  [/pp /dd /ii /rr] pushVariables
+  [
+    /pp arg1 def
+    pp to_univNum /pp set
+    {
+      pp isArray {
+        pp denominator /dd set        
+        pp dd mul /rr set
+        rr cancel /rr set
+        exit
+      } {  } ifelse
+
+      pp (numerator) dc /rr set
+      exit
+
+    } loop
+    /arg1 rr def
+  ] pop
+  popVariables
+  arg1
+} def 
+
+/cancel.Q {
+  /arg1 set
+  [/aa /rr /nn /dd /gg]  pushVariables
+  [
+    /aa arg1 def
+    {
+      aa isRational {
+         [(cancel) aa] mpzext /rr set 
+         rr (denominator) dc (1).. eq {
+            /rr rr (numerator) dc def
+            exit
+         } { } ifelse
+         rr (denominator) dc (-1).. eq {
+            /rr rr (numerator) dc (-1).. mul def
+         } { } ifelse
+         exit
+      } { } ifelse
+
+      /rr aa def
+      exit 
+    } loop
+    /arg1 rr def
+  ] pop
+  popVariables
+  arg1
+} def 
+
+/cancel.one {
+  /arg1 set
+  [/aa /rr /nn /dd /gg]  pushVariables
+  [
+    /aa arg1 def
+    {
+      aa isRational {
+        aa (numerator) dc /nn set
+        aa (denominator) dc /dd set
+        nn isUniversalNumber dd isUniversalNumber and {
+          /rr aa cancel.Q def
+          exit
+        } { (cancel: not implemented) error } ifelse
+      } { } ifelse
+
+      /rr aa def
+      exit 
+    } loop
+    /arg1 rr def
+  ] pop
+  popVariables
+  arg1
+} def 
+
+[(cancel)
+ [ (obj cancel r)
+   (Cancel numerators and denominators)
+   (The implementation has not yet been completed. It works only for Q.) 
+]] putUsages
+/cancel {
+  /arg1 set
+  [/aa /rr] pushVariables
+  [ 
+    /aa arg1 def
+    aa isArray {
+      aa {cancel} map /rr set
+    } { 
+      aa cancel.one /rr set
+    } ifelse
+    /arg1 rr def
+  ] pop
+  popVariables
+  arg1
+} def
+
+/nnormalize_vec {
+  /arg1 set
+  [/pp /rr /dd ] pushVariables
+  [
+    /pp arg1 def
+    pp denominator /dd set
+    dd (0).. lt { (nnormalize_vec: internal error) error } { } ifelse
+    pp numerator dd mul cancel /pp set
+    /@@@.nnormalize_vec_c dd def
+    pp gcd /dd set
+    dd (0).. lt { (nnormalize_vec: internal error) error } { } ifelse
+    pp (1).. dd div mul cancel /rr set
+    @@@.nnormalize_vec_c dd div cancel /@@@.nnormalize_vec_c set
+    /arg1 rr def
+  ] pop
+  popVariables
+  arg1
+} def
+[(nnormalize_vec)
+[(pp nnormalize_vec npp)
+ (It normalizes a given vector of Q into a vector of Z with relatively prime)
+ (entries by multiplying a postive number.)
+]] putUsages
+
+/usages {
+  /arg1 set
+  [/name /flag /n /k /slist /m /i /sss] pushVariables
+  [
+    /name arg1 def
+    /flag true def
+
+ %BUG: should use regular expression in a future.
+ name tag 1 eq { 
+   @.usages { 0 get } map shell { (, ) nl } map /sss set
+ } { 
+
+    /sss [ ] def
+   @.usages length /n set  
+   0 1 << n 1 sub >> 
+   {   
+      /k set
+      name << @.usages k get 0 get >> eq
+      {
+        /slist @.usages k get 1 get def
+        /m slist length def
+        0 1 << m 1 sub >> {
+          /i set
+          sss slist i get append nl append /sss set
+        } for
+        /flag false def
+      }
+      { }
+      ifelse
+   } for
+      
+   %BUG:  cannot get usages of primitives.
+   flag
+   {name Usage  /sss [(Usage of ) name ( could not obtained.) nl ] def}
+   { }
+   ifelse
+ } ifelse
+   /arg1 sss cat def
+   ] pop
+   popVariables
+   arg1
+} def
+[(usages)
+ [(key usages usages-as-a-string)
+  (num usages list-of-key-words)
+]] putUsages
 
 ;