[BACK]Return to ecart.sm1 CVS log [TXT][DIR] Up to [local] / OpenXM / src / kan96xx / Doc

Diff for /OpenXM/src/kan96xx/Doc/ecart.sm1 between version 1.12 and 1.13

version 1.12, 2003/08/26 05:06:00 version 1.13, 2003/08/26 12:46:03
Line 1 
Line 1 
 % $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.11 2003/08/24 05:19:44 takayama Exp $  % $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.12 2003/08/26 05:06:00 takayama Exp $
 %[(parse) (hol.sm1) pushfile] extension  %[(parse) (hol.sm1) pushfile] extension
 %[(parse) (appell.sm1) pushfile] extension  %[(parse) (appell.sm1) pushfile] extension
   
Line 220 
Line 220 
   [(CurrentRingp) (KanGBmessage)] pushEnv    [(CurrentRingp) (KanGBmessage)] pushEnv
   [    [
     /aa arg1 def      /aa arg1 def
     aa isArray { } { ( << array >> gb) error } ifelse      aa isArray { } { ( << array >> ecarth.gb) error } ifelse
     /setarg 0 def      /setarg 0 def
     /wv 0 def      /wv 0 def
     /degreeShift 0 def      /degreeShift 0 def
Line 302 
Line 302 
        } ifelse         } ifelse
        /setarg 1 def         /setarg 1 def
     } { } ifelse      } { } ifelse
       typev [ArrayP StringP ArrayP ArrayP StringP] eq
       {  /f aa 0 get def
          /v aa 1 get  def
          /wv aa 2 get def
          /degreeShift aa 3 get def
          aa 4 get (no) eq {
            /hdShift -1 def
          } {
            (Unknown keyword for the 5th argument) error
          } ifelse
          /setarg 1 def
       } { } ifelse
   
     /env1 getOptions def      /env1 getOptions def
   
Line 381 
Line 393 
     ecart.begin      ecart.begin
   
     ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse      ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
     ecart.autoHomogenize {  
       (ecarth.gb: Input polynomial or vectors are automatically h-H-homogenized.)  
       message  
     } { } ifelse  
   
   
     hdShift tag 1 eq {      hdShift tag 1 eq {
      ecart.autoHomogenize not hdShift -1 eq or {       ecart.autoHomogenize not hdShift -1 eq or {
 % No automatic h-s-homogenization.  % No automatic h-s-homogenization.
        f { {. } map} map /f set         f { {. } map} map /f set
      } {       } {
 % Automatic h-s-homogenization without degreeShift  % Automatic h-s-homogenization without degreeShift
       (ecarth.gb: Input polynomial or vectors are automatically h-H-homogenized without degree shift.)
         message
        f { {. ecart.dehomogenize} map} map /f set         f { {. ecart.dehomogenize} map} map /f set
        f ecart.homogenize01 /f set         f ecart.homogenize01 /f set
      } ifelse       } ifelse
    } {     } {
 % Automatic h-s-homogenization with degreeShift  % Automatic h-s-homogenization with degreeShift
       (ecarth.gb: Input polynomial or vectors are automatically h-H-homogenized with degree shift.)
         message
        f { {. ecart.dehomogenize} map} map /f set         f { {. ecart.dehomogenize} map} map /f set
        f {/fi set [(degreeShift) hdShift fi] homogenize} map /f set         f {/fi set [(degreeShift) hdShift fi] homogenize} map /f set
    }ifelse     }ifelse
Line 541 
Line 554 
   [(CurrentRingp) (KanGBmessage)] pushEnv    [(CurrentRingp) (KanGBmessage)] pushEnv
   [    [
     /aa arg1 def      /aa arg1 def
     aa isArray { } { ( << array >> gb) error } ifelse      aa isArray { } { ( << array >> ecartn.gb) error } ifelse
     /setarg 0 def      /setarg 0 def
     /wv 0 def      /wv 0 def
     /degreeShift 0 def      /degreeShift 0 def
Line 734 
Line 747 
   [(CurrentRingp) (KanGBmessage)] pushEnv    [(CurrentRingp) (KanGBmessage)] pushEnv
   [    [
     /aa arg1 def      /aa arg1 def
     aa isArray { } { ( << array >> gb) error } ifelse      aa isArray { } { ( << array >> ecartd.gb) error } ifelse
     /setarg 0 def      /setarg 0 def
     /wv 0 def      /wv 0 def
     /degreeShift 0 def      /degreeShift 0 def
Line 815 
Line 828 
        } ifelse         } ifelse
        /setarg 1 def         /setarg 1 def
     } { } ifelse      } { } ifelse
       typev [ArrayP StringP ArrayP ArrayP StringP] eq
       {  /f aa 0 get def
          /v aa 1 get def
          /wv aa 2 get def
          /degreeShift aa 3 get def
          aa 4 get (no) eq {
            /hdShift -1 def
          } {
            (Unknown keyword for the 5th argument) error
          } ifelse
          /setarg 1 def
       } { } ifelse
   
     /env1 getOptions def      /env1 getOptions def
   
Line 891 
Line 916 
        f { {. } map} map /f set         f { {. } map} map /f set
      } {       } {
 % Automatic h-homogenization without degreeShift  % Automatic h-homogenization without degreeShift
          (ecartd.gb : Input polynomial or vectors are automatically homogenized without degreeShift) message
        f { {. ecart.dehomogenize} map} map /f set         f { {. ecart.dehomogenize} map} map /f set
        f ecart.homogenize01 /f set         f ecart.homogenize01 /f set
        f { { [[(H). (1).]] replace } map } map /f set         f { { [[(H). (1).]] replace } map } map /f set
      } ifelse       } ifelse
    } {     } {
 % Automatic h-homogenization with degreeShift  % Automatic h-homogenization with degreeShift
          (ecartd.gb : Input polynomial or vectors are automatically homogenized with degreeShift) message
        f { {. ecart.dehomogenize} map} map /f set         f { {. ecart.dehomogenize} map} map /f set
        f {/fi set [(degreeShift) hdShift fi] homogenize} map /f set         f {/fi set [(degreeShift) hdShift fi] homogenize} map /f set
        f { { [[(H). (1).]] replace } map } map /f set         f { { [[(H). (1).]] replace } map } map /f set
Line 1004 
Line 1031 
   (if ecart.checkOrder complains about the order given.)    (if ecart.checkOrder complains about the order given.)
  ]   ]
 ] putUsages  ] putUsages
   
   /ecart.mimimalBase.test {
    [
       [    (0) , (-2*Dx) , (2*t) , (y) , (x^2) ]
       [    (3*t ) , ( -3*Dy ) , ( 0 ) , ( -x ) , ( -y) ]
       [    (3*y ) , ( 6*Dt ) , ( 2*x ) , ( 0 ) , ( 1) ]
       [    (-3*x^2 ) , ( 0 ) , ( -2*y ) , ( 1 ) , ( 0 )]
       [    (Dx ) , ( 0 ) , ( -Dy ) , ( Dt ) , ( 0) ]
       [  (0 ) , ( 0 ) , ( 6*t*Dt+2*x*Dx+3*y*Dy+8*h ) , ( 0 ) , ( 3*x^2*Dt+Dx) ]
       [  (6*t*Dx ) , ( 0 ) , ( -6*t*Dy ) , ( -2*x*Dx-3*y*Dy-5*h ) , ( -2*y*Dx-3*x^2*Dy) ]
       [  (6*t*Dt+3*y*Dy+9*h ) , ( 0 ) , ( 2*x*Dy ) , ( -2*x*Dt ) , ( -2*y*Dt+Dy) ]
     ]
     /ff set
   
     /nmshift [ [1 0 1 1 1] [1 0 1 0 0] ] def
     /shift [ [1 0 1 0 0] ] def
     /weight [ [(t) -1 (Dt) 1] [(t) -1 (x) -1 (y) -1 (Dt) 1 (Dx) 1 (Dy) 1]] def
   
     [ff (t,x,y) weight shift nmshift] ecart.minimalBase
   
   
   }  def
   /test {ecart.mimimalBase.test} def
   
   %(x,y) ==> [(Dx) 1 (Dy) 1 (h) 1]
   /ecart.minimalBase.D1 {
     /arg1 set
     [/in-ecart.minimalBase.D1  /tt /v]  pushVariables
     [
       /v arg1 def
       [ v to_records pop] /v set
       v { /tt set [@@@.Dsymbol tt] cat 1 } map /v set
       v [(h) 1] join /arg1 set
     ] pop
     popVariables
     arg1
   } def
   
   % [0 1 2] 1 ecart.removeElem [0 2]
   /ecart.removeElem {
     /arg2 set
     /arg1 set
     [/in-ecart.removeElem /v /q /i /ans /j] pushVariables
     [
       /v arg1 def
       /q arg2 def
       /ans v length 1 sub newVector def
       /j 0 def
       0 1 v length 1 sub {
         /i set
         i q eq not {
           ans j  v i get put
           /j j 1 add def
         } {  } ifelse
       } for
     ] pop
     popVariables
     arg1
   } def
   
   [(ecart.minimalBase)
   [([ff v weight_vector degreeShift [D_shift_n uv_shift_m]]  ecart.minimalBase mbase)
   ]] putUsages
   /ecart.minimalBase {
     /arg1 set
     [/in-ecart.minimalBase /ai1 /ai  /aa /typev /setarg /f /v
      /gg /wv /vec /ans /rr /mm
      /degreeShift  /env2 /opt /ss0
      /hdShift
       /degreeShiftD /degreeShiftUV
       /degreeShiftDnew /degreeShiftUVnew
       /tt
       /ai1_gr  /ai_gr
       /s /r /p /q /i /j /k
        /ai1_new /ai_new /ai_new2
      ] pushVariables
     [
       /aa arg1 def
       aa isArray { } { ( << array >> ecart.minimalBase) error } ifelse
       /setarg 0 def
       /wv 0 def
       /degreeShift 0 def
       /hdShift 0 def
       aa { tag } map /typev set
       typev [ArrayP StringP ArrayP ArrayP ArrayP] eq
       {  /f aa 0 get def
          /v aa 1 get def
          /wv aa 2 get def
          /degreeShift aa 3 get def
          /hdShift aa 4 get def
          /setarg 1 def
       } { } ifelse
       typev [ArrayP ArrayP ArrayP ArrayP ArrayP] eq
       {  /f aa 0 get def
          /v aa 1 get from_records def
          /wv aa 2 get def
          /degreeShift aa 3 get def
          /hdShift aa 4 get def
          /setarg 1 def
       } { } ifelse
       setarg { } { (ecart.minimalBase : Argument mismatch) error } ifelse
   
       [(KanGBmessage) ecart.gb.verbose ] system_variable
   
       f 0 get tag ArrayP eq {  }
       {  f { /tt set [ tt ] } map /f set } ifelse
       [f v wv degreeShift (no)] ecart.syz /ss0 set
   
       ss0 getRing ring_def
       /degreeShiftD  hdShift 0 get def
       /degreeShiftUV hdShift 1 get def
   %      -- ai --> D^r -- ai1 --> D^rr
       /ai1  f  { { . } map } map def
       /ai  ss0 0 get def
   
      {
       /degreeShiftUVnew
          ai1 { [ << wv 0 get weightv >> degreeShiftUV ] ord_ws_all  } map
       def
       (degreeShiftUVnew=) messagen degreeShiftUVnew message
   
       /degreeShiftDnew
          ai1 { [ << v ecart.minimalBase.D1 weightv >> degreeShiftD ]  ord_ws_all}
               map
       def
       (degreeShiftDnew=) messagen degreeShiftDnew message
   
       ai {[wv 0 get weightv  degreeShiftUVnew] init} map /ai_gr set
   
   %C  Note 2003.8.26
   
       /s ai length def
       /r ai 0 get length def
   
       /itIsMinimal 1 def
       0 1 s 1 sub {
         /i set
         0 1 r 1 sub {
           /j set
   
           [(isConstantAll) ai_gr i get j get] gbext
           ai_gr i get j get (0). eq not and
           {
              /itIsMinimal 0 def
              /p i def /q j def
           } {  } ifelse
         } for
       } for
   
   
       itIsMinimal { exit } { } ifelse
   
   %    construct new ai and ai1 (A_i and A_{i-1})
        /ai1_new  r 1 sub newVector def
        /j 0 def
        0 1 r 1 sub {
          /i set
          i q eq not {
             ai1_new j ai1 i get put
             /j  j 1 add def
          } { } ifelse
        } for
   
        /ai_new [s  r] newMatrix def
        0 1 s 1 sub {
          /j set
          0 1 r 1 sub {
            /k set
            ai_new [j k]
               << ai p get q get >> << ai j get k get >> mul
               << ai j get q get >> << ai p get k get >> mul
               sub
            put
          } for
        } for
   
   % remove 0 column
        /ai_new2 [s 1 sub r 1 sub] newMatrix def
        /j 0 def
        0 1 s 1 sub {
          /i set
          i p eq not {
             ai_new2 j << ai_new i get q ecart.removeElem >> put
             /j  j 1 add def
          } { } ifelse
        } for
   
   %   ( ) error
        /ai1 ai1_new def
        /ai ai_new2 def
   
      } loop
      /arg1 ai1 def
     ] pop
     popVariables
     arg1
   } def
   
   
 ( ) message-quiet  ( ) message-quiet
   
Legend:
Removed from v.1.12  
changed lines
  Added in v.1.13
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>