[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.14

version 1.12, 2003/08/26 05:06:00 version 1.14, 2003/08/27 03:11:13
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.13 2003/08/26 12:46:03 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.isZeroRow {
     /arg1 set
     [/in-ecart.isZeroRow /aa /i /n /yes] pushVariables
     [
        /aa arg1 def
        aa length /n set
        /yes 1 def
        0 1 n 1 sub {
          /i set
          aa i get (0). eq {
          } {
            /yes 0 def
          } ifelse
        } for
        /arg1 yes def
     ] pop
     popVariables
     arg1
   } def
   
   /ecart.removeZeroRow {
     /arg1 set
     [/in-ecart.removeZeroRow /aa /i /n /ans] pushVariables
     [
        /aa arg1 def
        aa length /n set
        /ans [ ] def
        0 1 n 1 sub {
          /i set
          aa i get ecart.isZeroRow {
          } {
            ans aa i get append /ans set
          } ifelse
        } for
        /arg1 ans def
     ] pop
     popVariables
     arg1
   } def
   
   /ecart.gen_input {
     /arg1 set
     [/in-ecart.gen_input  /aa /typev /setarg /f /v
      /gg /wv /vec /ans /rr /mm
      /degreeShift  /env2 /opt /ss0
      /hdShift /ff
      ] pushVariables
     [
       /aa arg1 def
       aa isArray { } { ( << array >> ecart.gen_input) 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 [hdShift 0 get degreeShift 0 get]]
       ecart.gb /ff set
       ff getRing ring_def
   
       ff 0 get { {toString } map } map /ff set
   
       [ff v wv degreeShift [hdShift 0 get degreeShift 0 get]] /arg1 set
     ] pop
     popVariables
     arg1
   } def
   [(ecart.gen_input)
   [([ff v weight_vector uv_shift_m [D_shift_n uv_shift_m]]  ecart.gen_input )
    (               [gg_h v weight_vector uv_shift_m [D_shift_n uv_shift_m]] )
    (It generates the input for the minimal filtered free resolution.)
    (Current ring is changed to the ring of gg_h.)
    (cf. ecart.minimalBase)
     $Example: [ [(t-x^3+y^2) (Dx+ 3 x^2 Dt) (Dy - 2 y Dt)] (t,x,y) $
     $           [ [(t) -1 (Dt) 1] [(t) -1 (x) -1 (y) -1 (Dt) 1 (Dx) 1 (Dy) 1]] $
     $           [ [0] ] $
     $           [ [0] [0] ] ] ecart.gen_input /gg set gg pmat $
   ]] putUsages
   
   
   [(ecart.minimalBase)
   [([ff v weight_vector uv_shift_m [D_shift_n uv_shift_m]]  ecart.minimalBase )
    (  [mbase gr_of_mbase )
    (     [syz v weight_vector new_uv_shift_m [new_D_shift_n new_uv_shift_m]])
    (     gr_of_syz ])
    (mbase is the minimal generators of ff in D^h in the sense of filtered minimal)
    (generators.)
     $Example: [ [(t-x^3+y^2) (Dx+ 3 x^2 Dt) (Dy - 2 y Dt)] (t,x,y) $
     $           [ [(t) -1 (Dt) 1] [(t) -1 (x) -1 (y) -1 (Dt) 1 (Dx) 1 (Dy) 1]] $
     $           [ [0] ] $
     $           [ [0] [0] ] ] ecart.gen_input /gg0 set $
     $         gg0 ecart.minimalBase /ss0 set $
     $         ss0 2 get ecart.minimalBase /ss1 set $
     $         ss1 2 get ecart.minimalBase /ss2 set $
     $     (---------  minimal filtered resolution -------) message $
     $     ss0 0 get pmat ss1 0 get pmat ss2 0 get pmat  $
     $     (---------  degree shift (n,m) n:D-shift m:uv-shift  -------) message $
     $     gg0       4 get message $
     $     ss0 2 get 4 get message $
     $     ss1 2 get 4 get message $
     $     ss2 2 get 4 get message ; $
   
   ]] 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
   
       ai [ ] eq {
         exit
       } {  } ifelse
   
       /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  ecart.removeZeroRow def
   
      } loop
      /arg1
        [  ai1
           ai1 {[wv 0 get weightv  degreeShift 0 get] init} map %Getting gr of A_{i-1}
           [ai v wv [degreeShiftUVnew] [degreeShiftDnew degreeShiftUVnew]]
           ai {[wv 0 get weightv  degreeShiftUVnew] init} map %Getting gr of A_i
        ]
      def
     ] pop
     popVariables
     arg1
   } def
   
   
 ( ) message-quiet  ( ) message-quiet
   
Legend:
Removed from v.1.12  
changed lines
  Added in v.1.14
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>