Return to smacro.sm1.old1 CVS log

Up to [local] / OpenXM / src / kan96xx / Kan

o import OpenXM sources

/; %%% prompt of the sm1 
{
   [$PrintDollar$ 0] system_variable pop
   $sm1>$ print
   [$PrintDollar$ 1] system_variable pop
} def

/?
{
   show_systemdictionary
   (------------ Use  show_user_dictionary  to see the user dictionary.---)
   message
   (------------ Use $keyWord$ usage  to see the usages. ---------------)
     message
} def

/??
{
   show_systemdictionary
   (------------ system macros defined in the UserDictionary -----------) 
     message
   show_user_dictionary  %% it should use other command
   (------------ Use $keyWord$ usage  to see the usages. ---------------)
     message
} def

/::
{
   print  newline ;
} def

/. {expand} def

/, {   } def

/false 0 def

/expand {
  $poly$ data_conversion
} def

/<< {  } def
/>> {  } def

% v1 v2 join
/join {
 /arg2 set /arg1 set
 [/v1 /v2] pushVariables
 /v1 arg1 def /v2 arg2 def
 [
   [v1 aload pop v2 aload pop] /arg1 set
 ] pop
 popVariables
 arg1
} def

/n.map 0 def  /i.map 0 def /ar.map 0 def /res.map 0 def  %% declare variables
/map.old {  %% recursive
 /arg1.map set %%  arg1.map = {   }
 /arg2.map set %%  arg2.map = [   ]
 %%%debug: /arg1.map load print arg2.map print 
 [n.map /com.map load i.map ar.map %% local variables.  Don't push com! 
  %%It's better to use load for all variables.
 /com.map /arg1.map load def  
 /ar.map arg2.map def %% set variables
 /n.map ar.map length 1 sub def
 [
   0 1 n.map {
     /i.map set
     << ar.map i.map get >> com.map
   } for
 ] /res.map set
 /ar.map set /i.map set /com.map set /n.map set ] pop %% pop local variables
 res.map %% push the result
} def

/message {
   [$PrintDollar$ 0] system_variable pop
   print newline
   [$PrintDollar$ 1] system_variable pop
} def  

/messagen {
   [$PrintDollar$ 0] system_variable pop
   print 
   [$PrintDollar$ 1] system_variable pop
} def  

/newline {
   [$PrintDollar$ 0] system_variable pop
   10 $string$ data_conversion print
   [$PrintDollar$ 1] system_variable pop
} def

/pushVariables {
  { dup [ 3 1 roll load ] } map
} def

/popVariables {
  % dup print
  { aload pop def } map pop
} def



/timer {
  set_timer
  exec
  set_timer
} def

/true 1 def



%%% prompter
;




%% dr.sm1 (Define Ring) 1994/9/25, 26

(dr.sm1  Version 11/9,1994. ) message
%% n evenQ  bool
/evenQ {
  /arg1 set
  arg1 2 idiv  2 mul arg1 sub 0 eq
  { true }
  { false } ifelse
} def

%% (x,y,z) polynomial_ring [x-list, d-list , paramList]
/ring_of_polynomials {
  /arg1 set
  [/vars /n /i /xList /dList /param] pushVariables
  %dup print (-----) message
  [
     (mmLarger) (matrix) switch_function
     (mpMult)   (poly) switch_function
     (red@)     (module1) switch_function
     (groebner) (standard) switch_function

     [arg1 to_records pop] /vars set
     vars length evenQ
     { }
     { vars [(PAD)] join /vars set }
     ifelse
     vars length 2 idiv /n set
     [ << n 1 sub >> -1 0
          { /i set
            vars i get
          } for
     ] /xList set
     [ << n 1 sub >> -1 0
          { /i set
            vars << i n add >> get
          } for
     ] /dList set

     [(H)] xList join [(e)] join /xList set
     [(h)] dList join [(E)] join /dList set
     [0 %% dummy characteristic
      << xList length >> << xList length >> << xList length >> 
                                            << xList length >>
      << xList length 1 sub >> << xList length >> << xList length >> 
                                                  << xList length >>
     ] /param set

     [xList dList param] /arg1 set
   ] pop
   popVariables
   arg1
} def

%% (x,y,z) polynomial_ring [x-list, d-list , paramList]
%% with no graduation and homogenization variables.
/ring_of_polynomials2 {
  /arg1 set
  [/vars /n /i /xList /dList /param] pushVariables
  %dup print (-----) message
  [
     (mmLarger) (matrix) switch_function
     (mpMult)   (poly) switch_function
     (red@)     (module1) switch_function
     (groebner) (standard) switch_function

     [arg1 to_records pop] /vars set
     vars length evenQ
     { }
     { vars [(PAD)] join /vars set }
     ifelse
     vars length 2 idiv /n set
     [ << n 1 sub >> -1 0
          { /i set
            vars i get
          } for
     ] /xList set
     [ << n 1 sub >> -1 0
          { /i set
            vars << i n add >> get
          } for
     ] /dList set

     [0 %% dummy characteristic
      << xList length >> << xList length >> << xList length >> 
                                            << xList length >>
      << xList length >> << xList length >> << xList length >> 
                                            << xList length >>
     ] /param set

     [xList dList param] /arg1 set
   ] pop
   popVariables
   arg1
} def

%% (x,y,z) polynomial_ring [x-list, d-list , paramList]
%% with no homogenization variables.
/ring_of_polynomials3 {
  /arg1 set
  [/vars /n /i /xList /dList /param] pushVariables
  %dup print (-----) message
  [
     (mmLarger) (matrix) switch_function
     (mpMult)   (poly) switch_function
     (red@)     (module1) switch_function
     (groebner) (standard) switch_function

     [arg1 to_records pop] /vars set
     vars length evenQ
     { }
     { vars [(PAD)] join /vars set }
     ifelse
     vars length 2 idiv /n set
     [ << n 1 sub >> -1 0
          { /i set
            vars i get
          } for
     ] /xList set
     xList [(e)] join /xList set
     [ << n 1 sub >> -1 0
          { /i set
            vars << i n add >> get
          } for
     ] /dList set
     dList [(E)] join /dList set

     [0 %% dummy characteristic
      << xList length >> << xList length >> << xList length >> 
                                            << xList length >>
      << xList length >> << xList length >> << xList length >> 
                                            << xList length >>
     ] /param set

     [xList dList param] /arg1 set
   ] pop
   popVariables
   arg1
} def

/ring_of_differential_operators {
  /arg1 set
  [/vars /n /i /xList /dList /param] pushVariables
  [
     (mmLarger) (matrix) switch_function
     (mpMult)   (diff) switch_function
     (red@)     (module1) switch_function
     (groebner) (standard) switch_function

     [arg1 to_records pop] /vars set %[x y z]
     vars reverse /xList set         %[z y x]
     vars {(D) 2 1 roll 2 cat_n} map
     reverse /dList set              %[Dz Dy Dx]
     [(H)] xList join [(e)] join /xList set
     [(h)] dList join [(E)] join /dList set
     [0 1 1 1 << xList length >>
        1 1 1 << xList length 1 sub >> ] /param set
     [ xList dList param ] /arg1 set
  ] pop
  popVariables
  arg1
} def

/ring_of_differential_operators3 {
%% with no homogenization variables.
  /arg1 set
  [/vars /n /i /xList /dList /param] pushVariables
  [
     (mmLarger) (matrix) switch_function
     (mpMult)   (diff) switch_function
     (red@)     (module1) switch_function
     (groebner) (standard) switch_function

     [arg1 to_records pop] /vars set %[x y z]
     vars reverse /xList set         %[z y x]
     vars {(D) 2 1 roll 2 cat_n} map
     reverse /dList set              %[Dz Dy Dx]
     xList [(e)] join /xList set
     dList [(E)] join /dList set
     [0 0 0 0 << xList length >>
        0 0 0 << xList length 1 sub >> ] /param set
     [ xList dList param ] /arg1 set
  ] pop
  popVariables
  arg1
} def

/ring_of_q_difference_operators {
  /arg1 set
  [/vars /n /i /xList /dList /param] pushVariables
  [
     (mmLarger) (qmatrix) switch_function
     (mpMult)   (diff) switch_function
     (red@)     (qmodule1) switch_function
     (groebner) (standard) switch_function

     [arg1 to_records pop] /vars set %[x y z]
     vars reverse /xList set         %[z y x]
     vars {(Q) 2 1 roll 2 cat_n} map
     reverse /dList set              %[Dz Dy Dx]
     [(q)] xList join [(e)] join /xList set
     [(h)] dList join [(E)] join /dList set
     [0 1 << xList length >> << xList length >> << xList length >>
        1 << xList length 1 sub >> << xList length >> << xList length >> ]
     /param set
     [ xList dList param ] /arg1 set
  ] pop
  popVariables
  arg1
} def

/ring_of_q_difference_operators3 {
%% with no homogenization and q variables.
  /arg1 set
  [/vars /n /i /xList /dList /param] pushVariables
  [
     (mmLarger) (qmatrix) switch_function
     (mpMult)   (diff) switch_function
     (red@)     (qmodule1) switch_function
     (groebner) (standard) switch_function

     [arg1 to_records pop] /vars set %[x y z]
     vars reverse /xList set         %[z y x]
     vars {(Q) 2 1 roll 2 cat_n} map
     reverse /dList set              %[Dz Dy Dx]
     xList  [(e)] join /xList set
     dList  [(E)] join /dList set
     [0 0 << xList length >> << xList length >> << xList length >>
        0 << xList length 1 sub >> << xList length >> << xList length >> ]
     /param set
     [ xList dList param ] /arg1 set
  ] pop
  popVariables
  arg1
} def

/reverse {
  /arg1 set
  arg1 length 1 lt
  { [ ] }
  {
    [
     <<  arg1 length 1 sub >> -1 0 
     {
        arg1 2 1 roll get
      } for
     ]
   } ifelse
} def

/memberQ {
%% a set0 memberQ bool
  /arg2 set  /arg1 set
  [/a /set0 /flag /i ] pushVariables
  [
     /a arg1 def  /set0 arg2 def
     /flag 0 def
     0 1 << set0 length 1 sub >>
     {
        /i set
        << set0 i get >> a eq
        {
           /flag 1 def 
         }
        { }
        ifelse
     } for
  ] pop
  /arg1 flag def
  popVariables
  arg1
} def

/transpose {
%% mat transpose  mat2
  /arg1 set
  [/i /j /m /n /flat /mat] pushVariables
  [
    /mat arg1 def
    /n mat length def
    /m mat 0 get length def

    [
      0 1 << n 1 sub >>
      {
         /i set
         mat i get aload pop
      } for
    ] /flat set
    %% [[1 2] [3 4]] ---> flat == [1 2 3 4]

    [
       0 1 << m 1 sub >> 
       {
          /i set
          [
             0 1 << n 1 sub >> 
             {
                /j set
                flat
                << j m mul >> i add
                get
             } for
           ]
        } for
     ] /arg1 set
   ] pop
   popVariables
   arg1
} def

    
/getPerm {
%% old new getPerm perm
  /arg2 set /arg1 set
  [/old /new /i /j /p] pushVariables
  [
    /old arg1 def
    /new arg2 def
    [
        /p old length def
        0 1 << p 1 sub >> 
        {
           /i set
           0 1 << p 1 sub >>
           {
              /j set
              old i get
              new j get
              eq
              { j }
              {   } ifelse
            } for
         } for
     ] /arg1 set
   ] pop
   popVariables
   arg1
} def

/permuteOrderMatrix {
%% order perm puermuteOrderMatrix newOrder
  /arg2 set /arg1 set
  [/order /perm /newOrder /k ] pushVariables
  [
    /order arg1 def
    /perm arg2 def
    order transpose /order set
    order 1 copy /newOrder set pop

    0 1 << perm length 1 sub >> 
    {
       /k set
       newOrder << perm k get >> << order k get >> put
    } for
    newOrder transpose /newOrder set
  ] pop
  /arg1 newOrder def
  popVariables
  arg1
} def



/complement {
%% set0 universe complement compl
  /arg2 set /arg1 set
  [/set0 /universe /compl /i] pushVariables
   /set0 arg1 def  /universe arg2 def
  [
     0 1 << universe length 1 sub >>
     {
        /i set
        << universe i get >> set0 memberQ
        {   }
        { universe i get }
        ifelse
      } for
   ] /arg1 set
   popVariables
   arg1
} def


%%% from order.sm1

%% size i evec [0 0 ... 0 1 0 ... 0]
/evec {
 /arg2 set /arg1 set
 [/size /iii] pushVariables
 /size arg1 def  /iii arg2 def
 [
   0 1 << size 1 sub >>
   {
      iii eq
      {  1 }
      {  0 }
      ifelse
   } for
  ] /arg1 set
  popVariables
  arg1
} def

%% size i evec_neg [0 0 ... 0 -1 0 ... 0]
/evec_neg {
 /arg2 set /arg1 set
 [/size /iii] pushVariables
 /size arg1 def  /iii arg2 def
 [
   0 1 << size 1 sub >>
   {
      iii eq
      {  -1 }
      {  0 }
      ifelse
   } for
  ] /arg1 set
  popVariables
  arg1
} def


%% size i j e_ij  << matrix e(i,j) >>
/e_ij {
  /arg3 set /arg2 set /arg1 set
  [/size /k /i /j] pushVariables
  [
    /size arg1 def  /i arg2 def /j arg3 def
    [ 0 1 << size 1 sub >>
      {
         /k set
         k i eq
         { size j evec }
         {
            k j eq
            { size i evec }
            { size k evec }
            ifelse
          } ifelse
       } for
     ] /arg1 set
   ] pop
   popVariables
   arg1
} def


%% size i j d_ij  << matrix E_{ij} >>
/d_ij {
  /arg3 set /arg2 set /arg1 set
  [/size /k /i /j] pushVariables
  [
    /size arg1 def  /i arg2 def /j arg3 def
    [ 0 1 << size 1 sub >>
      {
         /k set
         k i eq
         { size j evec }
         {
            [ 0 1 << size 1 sub >> { pop 0} for ]
          } ifelse
       } for
     ] /arg1 set
   ] pop
   popVariables
   arg1
} def

%% size matid << id matrix  >>
/matid {
  /arg1 set
  [/size /k ] pushVariables
  [
    /size arg1 def 
    [ 0 1 << size 1 sub >>
      {
         /k set
         size k evec
       } for
     ] /arg1 set
   ] pop
   popVariables
   arg1
} def


%% m1 m2 oplus
/oplus {
  /arg2 set /arg1 set
  [/m1 /m2 /n /m  /k ] pushVariables
  [
    /m1 arg1 def  /m2 arg2 def
    m1 length /n set
    m2 length /m set
    [
      0 1 << n m add 1 sub >>
      { 
        /k set
        k n lt
        {
            << m1 k get >> << m -1 evec >> join
        }
        {
            << n -1 evec >> << m2 << k n sub >> get >> join
        } ifelse
      } for
     ] /arg1 set
   ] pop
   popVariables
   arg1   
} def

%%%%%%%%%%%%%%%%%%%%%%%

/eliminationOrderTemplate  { %% esize >= 1
%% if esize == 0, it returns reverse lexicographic order.
%%  m esize eliminationOrderTemplate mat
  /arg2 set /arg1 set
  [/m  /esize /m1 /m2 /k ] pushVariables
  [
    /m arg1 def  /esize arg2 def
    /m1 m esize sub 1 sub def
    /m2 esize 1 sub def
     [esize 0 gt
      {
       [1 1 esize
        { pop 1 } for
        esize 1 << m 1 sub >>
        { pop 0 } for
       ]  %% 1st vector
      }
      { } ifelse

      m esize gt
      {    
       [1 1  esize 
        { pop 0 } for
        esize 1 << m 1 sub >>
        { pop 1 } for
       ]  %% 2nd vector
      }
      { } ifelse

      m1 0 gt
      {
         m 1 sub -1 << m m1 sub >>
         {
              /k set
              m  k  evec_neg
         } for
      }
      { } ifelse

      m2 0 gt
      {
         << esize 1 sub >> -1 1
         {
              /k set
              m  k  evec_neg
         } for
      }
      { } ifelse

    ] /arg1 set
   ] pop
   popVariables
   arg1
} def

/elimination_order {
%% [x-list d-list params]  (x,y,z) elimination_order 
%%  vars                    evars
%% [x-list d-list params order]
  /arg2 set  /arg1 set
  [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
  /vars arg1 def /evars [arg2 to_records pop] def
  [
    /univ vars 0 get reverse
          vars 1 get reverse join
    def

    << univ length 2 sub >>
    << evars length >>
    eliminationOrderTemplate /order set

    [[1]] order oplus [[1]] oplus /order set

    /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y,h] --> [x,y,h]

    /compl 
      [univ 0 get] evars join evars univ0 complement join
    def
    compl univ
    getPerm /perm set
    %%perm :: univ :: compl ::

    order perm permuteOrderMatrix /order set

    
    vars [order] join /arg1 set
  ] pop
  popVariables
  arg1
} def

/elimination_order2 {
%% [x-list d-list params]  (x,y,z) elimination_order 
%%  vars                    evars
%% [x-list d-list params order]
%% with no graduation and homogenization variables.
  /arg2 set  /arg1 set
  [/vars /evars /univ /order /perm /compl] pushVariables
  /vars arg1 def /evars [arg2 to_records pop] def
  [
    /univ vars 0 get reverse
          vars 1 get reverse join
    def

    << univ length  >>
    << evars length >>
    eliminationOrderTemplate /order set
    /compl 
      evars << evars univ complement >> join
    def
    compl univ
    getPerm /perm set
    %%perm :: univ :: compl ::

    order perm permuteOrderMatrix /order set
    
    vars [order] join /arg1 set
  ] pop
  popVariables
  arg1
} def


/elimination_order3 {
%% [x-list d-list params]  (x,y,z) elimination_order 
%%  vars                    evars
%% [x-list d-list params order]
  /arg2 set  /arg1 set
  [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
  /vars arg1 def /evars [arg2 to_records pop] def
  [
    /univ vars 0 get reverse
          vars 1 get reverse join
    def

    << univ length 1 sub >>
    << evars length >>
    eliminationOrderTemplate /order set

    [[1]] order oplus  /order set

    /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y] --> [x,y]

    /compl 
      [univ 0 get] evars join evars univ0 complement join
    def
    compl univ
    getPerm /perm set
    %%perm :: univ :: compl ::

    order perm permuteOrderMatrix /order set
    
    vars [order] join /arg1 set
  ] pop
  popVariables
  arg1
} def


/define_ring {
%[  (x,y,z) ring_of_polynominals
%   (x,y) elimination_order
%   17
%] define_ring
   /arg1 set
   [/rp /param /foo] pushVariables
   [/rp arg1 def
    [
      rp 0 get 0 get
      rp 0 get 1 get
      rp 0 get 2 get /param set
      param 0 << rp 1 get >> put
      param
      rp 0 get 3 get
    ]  /foo set
    foo aload pop set_up_ring@
   ] pop
   popVariables
} def

/defineTests1 {
/test {
   [[1 2 3]
    [0 1 0]
    [0 1 2]]
   [0 2 1] permuteOrderMatrix ::
} def

/test2 { (x,y,z) ring_of_polynomials (z,y) elimination_order /ans set } def

/test3 {
 [ (x,y,z) ring_of_polynomials
  (x,y) elimination_order
  17
 ] define_ring
} def

/test4 {
 [ (x,y,z) ring_of_polynomials
  ( ) elimination_order
  17
 ] define_ring
} def

} def

%% misterious bug  (x,y) miss
/miss {
  /arg1 set
  %[/vars /n /i /xList /dList /param] pushVariables
  [/vars /i] pushVariables
  [  arg1 print
     [arg1 to_records pop] /vars set

   ] pop
   dup print
   popVariables
   arg1
} def


/lexicographicOrderTemplate {
% size lexicographicOrderTemplate matrix
  /arg1 set
  [/k /size] pushVariables
  [
    /size arg1 def
    [ 0 1 << size 1 sub >> 
      { 
         /k set 
         size k evec
       } for
    ] /arg1 set
  ] pop
  popVariables
  arg1
} def

/lexicographic_order {
%% [x-list d-list params]  (x,y,z) lexicograhic_order 
%%  vars                    evars
%% [x-list d-list params order]
  /arg2 set  /arg1 set
  [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
  /vars arg1 def /evars [arg2 to_records pop] def
  [
    /univ vars 0 get reverse
          vars 1 get reverse join
    def

    << univ length 2 sub >>
    lexicographicOrderTemplate /order set

    [[1]] order oplus [[1]] oplus /order set

    /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y,h] --> [x,y,h]

    /compl 
      [univ 0 get] evars join evars univ0 complement join
    def
    compl univ
    getPerm /perm set
    %%perm :: univ :: compl ::

    order perm permuteOrderMatrix /order set
    
    vars [order] join /arg1 set
  ] pop
  popVariables
  arg1
} def

/lexicographic_order2 {
%% [x-list d-list params]  (x,y,z) lexicograhic_order 
%%  vars                    evars
%% [x-list d-list params order]
%% with no graduation and homogenization variables
  /arg2 set  /arg1 set
  [/vars /evars /univ /order /perm /compl] pushVariables
  /vars arg1 def /evars [arg2 to_records pop] def
  [
    /univ vars 0 get reverse
          vars 1 get reverse join
    def

    << univ length  >>
    lexicographicOrderTemplate /order set

    /compl 
      evars << evars univ complement >> join
    def
    compl univ
    getPerm /perm set

    order perm permuteOrderMatrix /order set
    
    vars [order] join /arg1 set
  ] pop
  popVariables
  arg1
} def

/lexicographic_order3 {
%% [x-list d-list params]  (x,y,z) lexicograhic_order 
%%  vars                    evars
%% [x-list d-list params order]
%% with no homogenization variable.
  /arg2 set  /arg1 set
  [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
  /vars arg1 def /evars [arg2 to_records pop] def
  [
    /univ vars 0 get reverse
          vars 1 get reverse join
    def

    << univ length 1 sub >>
    lexicographicOrderTemplate /order set

    [[1]] order oplus /order set

    /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y] --> [x,y]

    /compl 
      [univ 0 get] evars join evars univ0 complement join
    def
    compl univ
    getPerm /perm set
    %%perm :: univ :: compl ::

    order perm permuteOrderMatrix /order set
    
    vars [order] join /arg1 set
  ] pop
  popVariables
  arg1
} def

%%%%%%   add_rings %%%%%%%%%%%%%% 10/5

/graded_reverse_lexicographic_order {
  (  ) elimination_order
} def


/getX {
%% param [1|2|3|4] getX [var-lists]  ;  1->c,2->l,3->m,4->n
  /arg2 set /arg1 set
  [/k /param /func /low /top] pushVariables
  [
     /param arg1 def  /func arg2 def
     func 1 eq
     { 
       /low 0 def
     }
     {
       /low << param 2 get >> << func 1 sub >> get def
     } ifelse
     /top << param 2 get >> << func 4 add >> get 1 sub def
     [
       low 1 top 
       {
           /k set
          param 0 get k get
        } for
     ] /arg1 set
  ] pop
  popVariables
  arg1
} def

/getD {
%% param [1|2|3|4] getD [var-lists]  ;  1->c,2->l,3->m,4->n
  /arg2 set /arg1 set
  [/k /param /func /low /top] pushVariables
  [
     /param arg1 def  /func arg2 def
     func 1 eq
     { 
       /low 0 def
     }
     {
       /low << param 2 get >> << func 1 sub >> get def
     } ifelse
     /top << param 2 get >> << func 4 add >> get 1 sub def
     [
       low 1 top 
       {
           /k set
          param 1 get k get
        } for
     ] /arg1 set
  ] pop
  popVariables
  arg1
} def

/getXV {
%% param [1|2|3|4] getXV [var-lists]  ;  1->c,2->l,3->m,4->n
  /arg2 set /arg1 set
  [/k /param /func /low /top] pushVariables
  [
     /param arg1 def  /func arg2 def
     /low << param 2 get >> << func 4 add >> get def
     /top << param 2 get >>  func get 1 sub def
     [
       low 1 top 
       {
           /k set
          param 0 get k get
        } for
     ] /arg1 set
  ] pop
  popVariables
  arg1
} def

/getDV {
%% param [1|2|3|4] getDV [var-lists]  ;  1->c,2->l,3->m,4->n
  /arg2 set /arg1 set
  [/k /param /func /low /top] pushVariables
  [
     /param arg1 def  /func arg2 def
     /low << param 2 get >> << func 4 add >> get def
     /top << param 2 get >>  func get 1 sub def
     [
       low 1 top 
       {
           /k set
          param 1 get k get
        } for
     ] /arg1 set
  ] pop
  popVariables
  arg1
} def

/reNaming {
  %% It also changes oldx2 and oldd2, which are globals.
  /arg1 set
  [/i /j /new /count /ostr /k] pushVariables
  [
    /new arg1 def
    /count 0 def
    0 1 << new length 1 sub >> {
       /i set  
      << i 1 add >> 1 << new length 1 sub >> {
          /j set 
          << new i get >> << new j get >> eq
          {
             new j get /ostr set
             (The two rings have the same name :) messagen
             new i get messagen (.) message
             (The name ) messagen
             new i get messagen ( is changed into ) messagen
             new j << new i get << 48 count add $string$ data_conversion >>
                      2 cat_n >> put
             new j get messagen (.) message
             /oldx2 ostr << new j get >> reNaming2
             /oldd2 ostr << new j get >> reNaming2
             /count count 1 add def
           }
           { }
           ifelse
      } for
    } for
    /arg1 new def
  ] pop
  popVariables
  arg1
} def

/reNaming2 {
  %% array oldString newString reNaming2
  %% /aa (x) (y) reNaming2
  /arg3 set /arg2 set /arg1 set
  [/array /oldString /newString /k] pushVariables
  [
    /array arg1 def /oldString arg2 def /newString arg3 def
      0 1 << array load length 1 sub >>
      {
         /k set
         << array load k get  >> oldString eq
         {
            array load k newString put
          }
          { } ifelse
      } for
   ] pop
   popVariables
} def

/add_rings {
  /arg2 set /arg1 set
  [/param1 /param2 
   /newx /newd  /newv
   /k /const /od1 /od2 /od
   /oldx2 /oldd2  % these will be changed in reNaming.
   /oldv
  ] pushVariables
  [
     /param1 arg1 def /param2 arg2 def
   %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
     /newx 
       [ ]  
       param2 1 getX join  param1 1 getX join 
       param2 1 getXV join param1 1 getXV join

       param2 2 getX join  param1 2 getX join 
       param2 2 getXV join param1 2 getXV join

       param2 3 getX join  param1 3 getX join 
       param2 3 getXV join param1 3 getXV join

       param2 4 getX join  param1 4 getX join 
       param2 4 getXV join param1 4 getXV join
     def
     /newd 
       [ ]  
       param2 1 getD join  param1 1 getD join 
       param2 1 getDV join param1 1 getDV join

       param2 2 getD join  param1 2 getD join 
       param2 2 getDV join param1 2 getDV join

       param2 3 getD join  param1 3 getD join 
       param2 3 getDV join param1 3 getDV join

       param2 4 getD join  param1 4 getD join 
       param2 4 getDV join param1 4 getDV join
     def

     /newv  newx newd join def
     /oldx2 param2 0 get def  /oldd2 param2 1 get def
     /oldx2 oldx2 {1 copy 2 1 roll pop} map def
     /oldd2 oldd2 {1 copy 2 1 roll pop} map def
     /newv newv reNaming def

     /newx [
       0 1 << newv length 2 idiv 1 sub >> 
       { 
          /k set
          newv k get
       } for
     ] def
     /newd [
       0 1 << newv length 2 idiv 1 sub >> 
       { 
          /k set
          newv << newv length 2 idiv k add >> get
       } for
     ] def
     /const [
        << param1 2 get 0 get >>
        << param1 2 get 1 get  param2 2 get 1 get add >>
        << param1 2 get 2 get  param2 2 get 2 get add >>
        << param1 2 get 3 get  param2 2 get 3 get add >>
        << param1 2 get 4 get  param2 2 get 4 get add >>
        << param1 2 get 5 get  param2 2 get 5 get add >>
        << param1 2 get 6 get  param2 2 get 6 get add >>
        << param1 2 get 7 get  param2 2 get 7 get add >>
        << param1 2 get 8 get  param2 2 get 8 get add >>
    ] def

    /od1 param1 3 get def /od2 param2 3 get def
    od1 od2 oplus /od set
    
    %%oldx2 :: oldd2 ::        
    << param1 0 get reverse >> << param1 1 get reverse >> join
    << oldx2 reverse >> << oldd2 reverse >> join
    join /oldv set


    od << oldv << newx reverse newd reverse join >> getPerm >>
    permuteOrderMatrix /od set

     /arg1 [newx newd const od] def
  ] pop
  popVariables
  arg1
} def


/test5 {
  (t) ring_of_polynomials ( ) elimination_order /r1 set
  (x) ring_of_differential_operators (Dx) elimination_order /r2 set
  r2 r1 add_rings 
} def

/test6 {
  (H,h) ring_of_polynomials2 (H,h) lexicographic_order2 /r0 set
  (x,y,z) ring_of_polynomials2 (x,y) elimination_order2 /r1 set
  (t) ring_of_differential_operators3 (Dt) elimination_order3 /r2 set
  [r2 r1 add_rings r0 add_rings 0] define_ring
} def

/test7 {
  (H,h) ring_of_polynomials2 (H,h) lexicographic_order2 /r0 set
  (a,b,c,cp) ring_of_polynomials2 ( ) elimination_order2 /r1 set
  (x,y) ring_of_differential_operators3 (Dx,Dy) elimination_order3 /r2 set
  [r2 r1 add_rings r0 add_rings 0] define_ring
  [(Dx (x Dx + c-1) - (x Dx + y Dy + a) (x Dx + y Dy + b)).
   (Dy (y Dy + cp-1) - (x Dx + y Dy + a) (x Dx + y Dy + b)).] /ff set
  ff {[[$h$. $1$.]] replace} map homogenize /ff set
} def
%%%% end of add_rings

%%%%%%%% usages %%%%%%%%%%%%%%%%
/@.usages [  ] def
/putUsages {  
   /arg1 set
   /@.usages @.usages [ arg1 ] join def
} def

/showKeywords {
  @.usages { 0 get } map print ( ) message
} def

/Usage {
  /arg1 set
  [/name /flag /n /k /slist /m /i] pushVariables
  [
    /name arg1 def
    /flag true 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
          slist i get message
        } for
        /flag false def
      }
      { }
      ifelse
   } for
      
   flag
   {name usage}
   { }
   ifelse
   ] pop
   popVariables
} def


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


[(swap01) [
   $[ .... ] swap01 [....]$
   $Examples: [(x,y) ring_of_polynomials (x) elmination_order 0] swap01 $
   $          define_ring$
]] putUsages
%
/swap01 {
  /arg1 set
  [/rg /ch ] pushVariables
  [
    arg1 0 get /rg set  % ring
    arg1 1 get /ch set  % characteristics
    [rg 0 get , rg 1 get , rg 2 get , 
     << rg 3 get length >> 0 1 e_ij << rg 3 get >> mul ] /rg set
    /arg1 [ rg ch ] def
  ] pop
  popVariables
  arg1
} def

[(swap0k) [
   $[ .... ] k swap0k [....]$
   $Examples: [(x,y) ring_of_polynomials (x) elmination_order 0] 1 swap0k $
   $          define_ring$
   $swap01 == 1 swap0k$
]] putUsages
%
/swap0k {
  /arg2 set
  /arg1 set
  [/rg /ch /kk] pushVariables
  [
    arg2 /kk set
    arg1 0 get /rg set  % ring
    arg1 1 get /ch set  % characteristics
    [rg 0 get , rg 1 get , rg 2 get , 
     << rg 3 get length >> 0 kk e_ij << rg 3 get >> mul ] /rg set
    /arg1 [ rg ch ] def
  ] pop
  popVariables
  arg1
} def


;
/toVectors {
  { $array$ data_conversion } map
} def

/resolution {
  /arg1 set
  [/resol /gen /syz /maxLength] pushVariables
  [
    /gen arg1 0 get def
    arg1 length 1 eq
    { /maxLength -1 def }
    { /maxLength arg1 1 get def }
    ifelse
    /resol [ ] def
    {
      resol [gen] join /resol set
      (Betti Number = ) messagen
      gen length print 
      (    ) message

      /maxLength maxLength 1 sub def
      maxLength 0 eq
      {(<<Stop the resolution because of the given max depth.>>) message exit}
      {   }
      ifelse

      [gen [$needBack$ $needSyz$]] groebner 2 get /syz set 
    
      syz length 0 eq
      {exit}
      { }
      ifelse

      /gen syz def
      %% homogenization %%%%%%%%%%%%%%%%%%
      (Note: The next line is removed for a test. 11/9.) message
      %gen { {[[$h$. $1$.]] replace} map } map /gen set
      gen {homogenize} map /gen set
      %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    } loop
    /arg1 resol def
   ] pop
   popVariables
   arg1
} def

/TESTS {
/test1 {
  $red@$ $module1$ switch_function
  [ [ (x^2) . (x^2-x h) . ] [ (x) . (x-h) . ] ] /ff set ;
  (ff is the input data.) message
} def

/test2 {
  $red@$ $module1$ switch_function
  [ [ (1) . (0) . ] [ (0) . (1) . ] ] /ff set ;
  (ff is the input data.) message
} def  

/test3 {
  $red@$ $module1$ switch_function
  [ (x,y) ring_of_polynomials
    ( ) elimination_order
    0
  ] define_ring
  [ [ (h) . (x) . (y ) .] 
    [ (y) . (0) . (h) .]
    [ (x^2) . (x h) . (0) .]] /ff set
  (ff is the input data.) message

} def

/test4 {
  $red@$ $module1$ switch_function
  [ ${x,y}$ ring_of_polynomials
    ( ) elimination_order
    0
  ] define_ring
  [ [ (x^2 + y^2 - h^2) . ] 
    [ (x y - h^2) . ] ] /ff set
  (ff is the input data.) message

} def
%% characteristic variety
/test4 {
  %% Test 1.
  [(x,y) ring_of_differential_operators (Dx,Dy) elimination_order 0] 
  swap01 define_ring

  [((x Dx^2+Dy^2-1)+e*(Dx)).  (0+e*(Dx^2)).  (Dx+Dy+1). ] /ff set

  ff print ( ------------------ ) message
  ff characteristic print ( ) message ( ) message

  %% Test 2.
  [(a,b,c,d,x) ring_of_differential_operators (Dx) elimination_order 0]
  swap01 define_ring

  [[(x*Dx-a). (-b).] [(-c). ((x-1)*Dx-d).]] /ff set
  /ff ff homogenize  def
  [ff] groebner /ans set
  ans 0 get toVectors print ( ) message
  ans 0 get characteristic print (  ) message ( ) message

  %% Test 3.
  [(a,b,c,d,x) ring_of_differential_operators (Dx) elimination_order 0]
  define_ring

  [[(x*Dx-a). (-b).] [(-c). ((x-1)*Dx-d).]] /ff set
  /ff ff homogenize  def
  [ff] groebner /ans set
  ans 0 get toVectors print ( ) message ( ) message

} def


%%%%%%%%%%%%%%%%%%%%%%%%%%

(type in test1,2,3.) message
(Use toVectors to get vector representations.) message

} def



/lpoint { init (e). degree } def
/characteristic {
  /arg1 set
  [/gb  /lps /i /n /ans /maxp /ansp /k] pushVariables
  [  /gb arg1 def
     /ans [ ] def
     /maxp 0 def
     /lps gb {lpoint} map def
     0 1 << lps length 1 sub >>
     {
       /i set
       lps i get maxp gt
       { /maxp lps i get def }
       {  }
       ifelse
     } for

     %%lps print
     /ans [
      0 1 maxp { pop [ ]   } for
     ] def

     gb toVectors /gb set

     0 1 << lps length 1 sub >>
     {
       /i set  /k lps i get def
       /ansp ans k get def
       << gb i get >> k  get principal /f set
       /ansp ansp [f] join def
       ans k ansp put
     } for
    
     /arg1 ans def     
  ] pop
  popVariables
  arg1
} def

;