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

Diff for /OpenXM/src/kan96xx/Kan/dr.sm1 between version 1.23 and 1.56

version 1.23, 2003/09/12 02:52:50 version 1.56, 2013/09/22 01:26:07
Line 1 
Line 1 
 % $OpenXM: OpenXM/src/kan96xx/Kan/dr.sm1,v 1.22 2003/08/26 12:46:04 takayama Exp $  % $OpenXM: OpenXM/src/kan96xx/Kan/dr.sm1,v 1.55 2013/09/22 01:06:20 takayama Exp $
 %% dr.sm1 (Define Ring) 1994/9/25, 26  %% dr.sm1 (Define Ring) 1994/9/25, 26
 %% This file is error clean.  %% This file is error clean.
   
 @@@.quiet {   }  @@@.quiet {   }
 { (macro package : dr.sm1,   9/26,1995 --- Version 12/10, 2000. ) message } ifelse  { (macro package : dr.sm1,   9/26,1995 --- Version 09/22, 2013. ) message } ifelse
   
 /ctrlC-hook {  /ctrlC-hook {
 %%% define your own routing in case of error.  %%% define your own routing in case of error.
Line 50 
Line 50 
           } for            } for
      ] /dList set       ] /dList set
   
      [(H)] xList join [@@@.esymbol] join /xList set       [@@@.Hsymbol] xList join [@@@.esymbol] join /xList set
      [(h)] dList join [@@@.Esymbol] join /dList set       [(h)] dList join [@@@.Esymbol] join /dList set
      [0 %% dummy characteristic       [0 %% dummy characteristic
       << xList length >> << xList length >> << xList length >>        << xList length >> << xList length >> << xList length >>
Line 167 
Line 167 
      vars reverse /xList set         %[z y x]       vars reverse /xList set         %[z y x]
      vars {@@@.Dsymbol 2 1 roll 2 cat_n} map       vars {@@@.Dsymbol 2 1 roll 2 cat_n} map
      reverse /dList set              %[Dz Dy Dx]       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       [(h)] dList join [@@@.Esymbol] join /dList set
      [0 1 1 1 << xList length >>       [0 1 1 1 << xList length >>
         1 1 1 << xList length 1 sub >> ] /param set          1 1 1 << xList length 1 sub >> ] /param set
Line 269 
Line 269 
      vars reverse /xList set         %[z y x]       vars reverse /xList set         %[z y x]
      vars {@@@.diffEsymbol 2 1 roll 2 cat_n} map       vars {@@@.diffEsymbol 2 1 roll 2 cat_n} map
      reverse /dList set              %[Dz Dy Dx]       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       [(h)] dList join [@@@.Esymbol] join /dList set
      [0 1 1 << xList length >> << xList length >>       [0 1 1 << xList length >> << xList length >>
         1 1 << xList length 1 sub >> << xList length >> ] /param set          1 1 << xList length 1 sub >> << xList length >> ] /param set
Line 308 
Line 308 
      vars2 reverse       vars2 reverse
      vars {@@@.Dsymbol 2 1 roll 2 cat_n} map       vars {@@@.Dsymbol 2 1 roll 2 cat_n} map
      reverse join /dList set              %[s2 s1 Dz Dy Dx]       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       [(h)] dList join [@@@.Esymbol] join /dList set
      [0 1 1 << vars2 length 1 add >>  << xList length >>       [0 1 1 << vars2 length 1 add >>  << xList length >>
         1 1 << vars2 length 1 add >> << xList length 1 sub >> ] /param set          1 1 << vars2 length 1 add >> << xList length 1 sub >> ] /param set
Line 342 
Line 342 
      0 1 << set0 length 1 sub >>       0 1 << set0 length 1 sub >>
      {       {
         /i set          /i set
         << set0 i get >> a eq          set0 i get tag , a tag , eq {
         {            << set0 i get >> a eq
            /flag 1 def            {
          }               /flag 1 def  exit
         { }             }
         ifelse            { }
             ifelse
           } {  } ifelse
      } for       } for
   ] pop    ] pop
   /arg1 flag def    /arg1 flag def
Line 361 
Line 363 
   [    [
     /mat arg1 def      /mat arg1 def
     /m mat length def      /m mat length def
     {
       m 0 eq { /ans [ ] def exit } { } ifelse
     mat 0 get isArray      mat 0 get isArray
     {   }      {   }
     { (transpose: Argument must be an array of arrays.) error }      { (transpose: Argument must be an array of arrays.) error }
Line 374 
Line 378 
          ans [ j i ]  <<  mat i get j get >> put           ans [ j i ]  <<  mat i get j get >> put
       } for        } for
     } for      } for
       exit
      } loop
    /arg1 ans def     /arg1 ans def
   ] pop    ] pop
   popVariables    popVariables
Line 787 
Line 793 
    (    Pointer to the ring. )     (    Pointer to the ring. )
    (Example: [$x,y$ ring_of_q_difference_operators $Qx,Qy$ elimination_order)     (Example: [$x,y$ ring_of_q_difference_operators $Qx,Qy$ elimination_order)
    (          0] define_qring )     (          0] define_qring )
    (cf. define_ring, set_up_ring@ <coefficient ring>, ring_def, << ,, >>)     (cf. define_ring, set_up_ring@ <coefficient ring>, ring_def, << __ >>)
   ]    ]
 ] putUsages  ] putUsages
 /define_qring {  /define_qring {
Line 839 
Line 845 
   (one may use the command )    (one may use the command )
   (          f (ring) data_conversion /R set)    (          f (ring) data_conversion /R set)
   (cf. define_ring, define_qring, system_variable, poly (ring) data_conversion)    (cf. define_ring, define_qring, system_variable, poly (ring) data_conversion)
   (cf. << ,, >>)    (cf. << __ >>, getRing)
  ]   ]
 ] putUsages  ] putUsages
   
Line 1328 
Line 1334 
     /univ vars 0 get reverse      /univ vars 0 get reverse
           vars 1 get reverse join            vars 1 get reverse join
     def      def
       w-vectors to_int32 /w-vectors set
     [      [
     0 1 << w-vectors length 1 sub >>      0 1 << w-vectors length 1 sub >>
     {      {
Line 1350 
Line 1357 
   /arg2 set  /arg1 set    /arg2 set  /arg1 set
   [/univ /www /k /vname /vweight /ans] pushVariables    [/univ /www /k /vname /vweight /ans] pushVariables
   /univ arg1 def /www arg2 def    /univ arg1 def /www arg2 def
   [    [
       www to_int32 /www set
     /ans << univ length >> -1 0 evecw def      /ans << univ length >> -1 0 evecw def
     0  2  << www length 2 sub >>      0  2  << www length 2 sub >>
     {      {
Line 1405 
Line 1413 
        gg (0). eq         gg (0). eq
        { 0 }         { 0 }
        { gg (ring) data_conversion /rr set         { gg (ring) data_conversion /rr set
          gg  << var rr ,, >> degree           gg  << var rr __ >> degree
        } ifelse         } ifelse
     } map def      } map def
   %%degs message    %%degs message
Line 1520 
Line 1528 
   (type?) data_conversion  RingP eq    (type?) data_conversion  RingP eq
 } def  } def
   
   [(isByteArray)
    [(obj isByteArray bool) ]
   ] putUsages
   /isByteArray {
     (type?) data_conversion  ByteArrayP eq
   } def
   
 /toString.tmp {  /toString.tmp {
   /arg1 set    /arg1 set
   [/obj /fname] pushVariables    [/obj /fname] pushVariables
Line 1549 
Line 1564 
     { obj (string) data_conversion } { } ifelse      { obj (string) data_conversion } { } ifelse
     obj isRational      obj isRational
     { obj (string) data_conversion } { } ifelse      { obj (string) data_conversion } { } ifelse
       obj isByteArray
       { obj (array) data_conversion toString } { } ifelse
     obj tag 0 eq      obj tag 0 eq
     { (null) } { } ifelse      { (null) } { } ifelse
   
Line 1663 
Line 1680 
 /RationalFunctionP 16 def  /RationalFunctionP 16 def
 /ClassP 17 def  /ClassP 17 def
 /DoubleP 18 def  /DoubleP 18 def
   /ByteArrayP 19 def
 /@.datatypeConstant.usage [  /@.datatypeConstant.usage [
  (IntegerP, LiteralP, StringP, ExecutableArrayP, ArrayP, PolyP, FileP, RingP,)   (IntegerP, LiteralP, StringP, ExecutableArrayP, ArrayP, PolyP, FileP, RingP,)
  (UniversalNumberP, RationalFunctionP, ClassP, DoubleP)   (UniversalNumberP, RationalFunctionP, ClassP, DoubleP, ByteArrayP)
  (      return data type identifiers.)   (      return data type identifiers.)
  (Example:  7 tag IntegerP eq  ---> 1)   (Example:  7 tag IntegerP eq  ---> 1)
 ] def  ] def
Line 1680 
Line 1698 
 [(RationalFunctionP) @.datatypeConstant.usage ] putUsages  [(RationalFunctionP) @.datatypeConstant.usage ] putUsages
 [(ClassP) @.datatypeConstant.usage ] putUsages  [(ClassP) @.datatypeConstant.usage ] putUsages
 [(DoubleP) @.datatypeConstant.usage ] putUsages  [(DoubleP) @.datatypeConstant.usage ] putUsages
   [(ByteArrayP) @.datatypeConstant.usage ] putUsages
   
 [(,,)  [(__)
  [( string ring ,, polynomial)   [( string ring __ polynomial)
   (Parse the <<string>> as an element in the <<ring>> and returns)    (Parse the <<string>> as an element in the <<ring>> and returns)
   (the polynomial.)    (the polynomial.)
   (cf. define_ring, define_qring, ring_def)    (cf. define_ring, define_qring, ring_def)
   (Example: [(x,y) ring_of_polynomials [[(x) 1]] weight_vector 7]define_ring)    (Example: [(x,y) ring_of_polynomials [[(x) 1]] weight_vector 7]define_ring)
   (         /myring set)    (         /myring set)
   (         ((x+y)^4) myring ,, /f set)    (         ((x+y)^4) myring __ /f set)
 ]] putUsages  ]] putUsages
   
 /,, {  /__ {
   /arg2 set /arg1 set    /arg2 set /arg1 set
   [/rrr] pushVariables    [/rrr] pushVariables
   [ arg1 tag StringP eq    [ arg1 tag StringP eq
Line 1701 
Line 1720 
       /arg1 arg1 expand def        /arg1 arg1 expand def
       [(CurrentRingp) rrr] system_variable        [(CurrentRingp) rrr] system_variable
     }      }
     {(Argument Error for ,, ) error }      {(Argument Error for __ ) error }
     ifelse      ifelse
   ] pop    ] pop
   popVariables    popVariables
Line 1712 
Line 1731 
  [( string .. universalNumber)   [( string .. universalNumber)
   (Parse the << string >> as a universalNumber.)    (Parse the << string >> as a universalNumber.)
   (Example:  (123431232123123).. /n set)    (Example:  (123431232123123).. /n set)
     ({ commands }..  executes the commands.  << .. >> is equivalent to exec.)
 ]] putUsages  ]] putUsages
 /.. { (universalNumber) data_conversion } def  /.. { dup tag 3 eq { exec } { (universalNumber) data_conversion} ifelse } def
   
 [(dc)  [(dc)
  [(Abbreviation of data_conversion.)   [(Abbreviation of data_conversion.)
Line 1766 
Line 1786 
   /arg1 set    /arg1 set
   [/f /k /i /ans] pushVariables    [/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       /f arg1 def   /k arg2 ..int def
      k 0 lt {       k 0 lt {
        1 1 << 0 k sub >> {         1 1 << 0 k sub >> {
Line 1779 
Line 1803 
          /ans f ans {mul} sendmsg2 def           /ans f ans {mul} sendmsg2 def
        } for         } for
      } ifelse       } ifelse
      /arg1 ans def     } ifelse
      /arg1 ans def
   ] pop    ] pop
   popVariables    popVariables
   arg1    arg1
Line 1918  newline
Line 1943  newline
 } def  } def
 %%end of function  %%end of function
   
 /rest { % returns remainder of a given list  /rest {
   [ 2 1 roll  aload length -1 roll pop ]    /arg1 set [(Krest) arg1] extension
 } def  } def
 [(rest)  [(rest)
  [(array rest the-rest-of-the-array)   [(array rest the-rest-of-the-array)
Line 1942  newline
Line 1967  newline
         error          error
      } ifelse       } ifelse
      /myring  base 0 get (ring) dc def       /myring  base 0 get (ring) dc def
      /zero (0) myring ,, def       /zero (0) myring __ def
      base length 1 sub /n set       base length 1 sub /n set
      /minbase [ 0 1 n { /i set base i get } for ] def       /minbase [ 0 1 n { /i set base i get } for ] def
      0 1 n {       0 1 n {
Line 2251  newline
Line 2276  newline
         [(variableNames) M2N 0 get] system_variable          [(variableNames) M2N 0 get] system_variable
         f toString /f2 set          f toString /f2 set
         [(variableNames) M2N 3 get] system_variable          [(variableNames) M2N 3 get] system_variable
         f2 M2N 2 get ,, /f2 set          f2 M2N 2 get __ /f2 set
     } ifelse      } ifelse
     [(CurrentRingp) cp] system_variable      [(CurrentRingp) cp] system_variable
     /arg1 f2 def      /arg1 f2 def
Line 2277  newline
Line 2302  newline
   $/R2 set$    $/R2 set$
   $[[(x) (Dx)] [((t-1) Dt) (z)]] /r0 set$    $[[(x) (Dx)] [((t-1) Dt) (z)]] /r0 set$
   $r0 R1 R2 makeRingMap /maptable set$    $r0 R1 R2 makeRingMap /maptable set$
   $(Dx-1) R1 ,, /ff set$    $(Dx-1) R1 __ /ff set$
   $ ff maptable ringmap :: $    $ ff maptable ringmap :: $
  ]   ]
 ] putUsages  ] putUsages
Line 2363  newline
Line 2388  newline
        /rrr set         /rrr set
        base { . } map /base set         base { . } map /base set
      } ifelse       } ifelse
      vlist { dup isPolynomial {  } { rrr ,, } ifelse } map /vlist set       vlist { dup isPolynomial {  } { rrr __ } ifelse } map /vlist set
   
      [(hilbert) base vlist] extension /ff set       [(hilbert) base vlist] extension /ff set
      [(CurrentRingp) rrrorg] system_variable       [(CurrentRingp) rrrorg] system_variable
Line 2382  newline
Line 2407  newline
      /vv arg2 def       /vv arg2 def
      /f hhh 1 get def       /f hhh 1 get def
      f (0). eq { /ans [0] def /hilbReduce.label goto } { } ifelse       f (0). eq { /ans [0] def /hilbReduce.label goto } { } ifelse
      f vv << f (ring) dc >> ,,  degree /vv set       f vv << f (ring) dc >> __  degree /vv set
      hhh 0 get /d set       hhh 0 get /d set
      d   d  (integer) dc factorial /d set       d   d  (integer) dc factorial /d set
      d << vv (universalNumber) dc vv factorial >> idiv /d set       d << vv (universalNumber) dc vv factorial >> idiv /d set
Line 2458  newline
Line 2483  newline
     { /fn (0). def }      { /fn (0). def }
     {      {
        f (ring) dc /rrr set         f (ring) dc /rrr set
        v toString (^) n toString 3 cat_n rrr ,,         v toString (^) n toString 3 cat_n rrr __
        f mul         f mul
        [[v (0).] [(h) rrr ,, (1) rrr ,,]] replace /fn set         [[v (0).] [(h) rrr __ (1) rrr __]] replace /fn set
      } ifelse       } ifelse
      fn /arg1 set       fn /arg1 set
   ] pop    ] pop
Line 2517  newline
Line 2542  newline
   [    [
     /fff arg1 def      /fff arg1 def
     /www arg2 def      /www arg2 def
       www to_int32 /www set
     fff (0). eq { /ddd -intInfinity def /ord_w.LLL goto} { } ifelse      fff (0). eq { /ddd -intInfinity def /ord_w.LLL goto} { } ifelse
     fff (ring) dc /rrr set      fff (ring) dc /rrr set
     fff init /fff set      fff init /fff set
     /ddd 0 def      /ddd 0 def
     0 2 www length 1 sub {      0 2 www length 1 sub {
       /iii set        /iii set
       fff << www iii get rrr ,, >> degree        fff << www iii get rrr __ >> degree
       << www iii 1 add get >> mul        << www iii 1 add get >> mul
       ddd add /ddd set        ddd add /ddd set
     } for      } for
Line 2548  newline
Line 2574  newline
   [    [
     /fff arg1 def      /fff arg1 def
     /www arg2 def      /www arg2 def
       www to_int32 /www set
     fff (0). eq { /ddd -intInfinity def /ord_w_all.LLL goto} { } ifelse      fff (0). eq { /ddd -intInfinity def /ord_w_all.LLL goto} { } ifelse
     /ddd -intInfinity def      /ddd -intInfinity def
     fff (ring) dc /rrr set      fff (ring) dc /rrr set
     /zzz (0) rrr ,, def      /zzz (0) rrr __ def
     fff init /fff-in set      fff init /fff-in set
     fff fff-in sub /fff set      fff fff-in sub /fff set
     {      {
      /ddd-tmp 0 def       /ddd-tmp 0 def
      0 2 www length 1 sub {       0 2 www length 1 sub {
        /iii set         /iii set
        fff-in << www iii get rrr ,, >> degree         fff-in << www iii get rrr __ >> degree
        << www iii 1 add get >> mul         << www iii 1 add get >> mul
        ddd-tmp add /ddd-tmp set         ddd-tmp add /ddd-tmp set
      } for       } for
Line 2605  newline
Line 2632  newline
          /v0 vv ii get (string) dc def           /v0 vv ii get (string) dc def
          v0 (array) dc 0 get Dascii eq  %% If the first character is D?           v0 (array) dc 0 get Dascii eq  %% If the first character is D?
          {  rule  %% Dx-->x           {  rule  %% Dx-->x
             [v0 rr ,,              [v0 rr __
             v0 (array) dc rest { (string) dc} map aload length cat_n rr ,,]              v0 (array) dc rest { (string) dc} map aload length cat_n rr __]
             append /rule set              append /rule set
          }           }
          { rule   %% x --> -Dx           { rule   %% x --> -Dx
            [v0 rr ,,             [v0 rr __
             (0).              (0).
             [Dascii] v0 (array) dc join { (string) dc } map aload length              [Dascii] v0 (array) dc join { (string) dc } map aload length
             cat_n rr ,,  sub              cat_n rr __  sub
            ]             ]
            append /rule set             append /rule set
          } ifelse           } ifelse
       } ifelse        } ifelse
      } for       } for
      % rule message       % rule message
      ff rule replace [[(h) rr ,, (1) rr ,,]] replace /ans1 set       ff rule replace [[(h) rr __ (1) rr __]] replace /ans1 set
      } ifelse       } ifelse
     }      }
    {     {
Line 2762  newline
Line 2789  newline
   [/in-ngcd /nlist /g.ngcd /ans] pushVariables    [/in-ngcd /nlist /g.ngcd /ans] pushVariables
   [    [
      /nlist arg1 def       /nlist arg1 def
        nlist to_univNum /nlist set
      nlist length 2 lt       nlist length 2 lt
      { /ans nlist 0 get def /L.ngcd goto }       { /ans nlist 0 get def /L.ngcd goto }
      {       {
Line 2977  newline
Line 3005  newline
      {       {
         /xx xx (string) dc def          /xx xx (string) dc def
         /dxx [@@@.Dsymbol xx] cat def          /dxx [@@@.Dsymbol xx] cat def
         /xx xx f (ring) dc ,, def          /xx xx f (ring) dc __ def
         /dxx dxx f (ring) dc ,, def          /dxx dxx f (ring) dc __ def
         /one (1) f (ring) dc ,, def          /one (1) f (ring) dc __ def
   
         {          {
           /g f init def            /g f init def
Line 3056  newline
Line 3084  newline
     f (0). eq {  }      f (0). eq {  }
     {      {
       /rr f (ring) dc def        /rr f (ring) dc def
       xx {toString rr ,, } map /xx set        xx {toString rr __ } map /xx set
       dx {toString rr ,, } map /dx set        dx {toString rr __ } map /dx set
       ss {toString rr ,, } map /ss set        ss {toString rr __ } map /ss set
       /n xx length  def        /n xx length  def
       0 1 n 1 sub {        0 1 n 1 sub {
          /i set           /i set
Line 3088  newline
Line 3116  newline
   [    [
     /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def      /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def
     f (ring) dc /rr set      f (ring) dc /rr set
     /one (1) rr ,, def %%      /one (1) rr __ def %%
     /ww [ xx toString -1 dx toString 1 ] weightv  def      /ww [ xx toString -1 dx toString 1 ] weightv  def
     f ww init f sub (0). eq {   }      f ww init f sub (0). eq {   }
     { [(destraction2.1 : inhomogeneous with respect to )      { [(destraction2.1 : inhomogeneous with respect to )
Line 3435  newline
Line 3463  newline
 } def  } def
 [(getRing)  [(getRing)
 [(obj getRing rr)  [(obj getRing rr)
  (ring rr;)   (ring rr; )
  (getRing obtains the ring structure from obj.)   (getRing obtains the ring structure from obj.)
  (If obj is a polynomial, it returns the ring structure associated to)   (If obj is a polynomial, it returns the ring structure associated to)
  (the polynomial.)   (the polynomial.)
  (If obj is an array, it recursively looks for the ring structure.)   (If obj is an array, it recursively looks for the ring structure.)
    (cf. ring_def)
 ]] putUsages  ]] putUsages
 /toVectors {  /toVectors {
   /arg1 set    /arg1 set
Line 3651  $ [ff ff] fromVectors :: $ 
Line 3680  $ [ff ff] fromVectors :: $ 
  (         ff to_int { tag } map :: )   (         ff to_int { tag } map :: )
 ]] putUsages  ]] putUsages
   
   /to_int32 {
     /arg1 set
     [/to-int32 /ob /ans] pushVariables
     [
       /ob arg1 def
       /ans ob def
       ob isArray {
         ob {to_int32} map /ans set
         /LLL.to_int32 goto
       } {  } ifelse
       ob isUniversalNumber {
         ob (integer) dc /ans set
         /LLL.to_int32 goto
       } {  } ifelse
       /LLL.to_int32
       /arg1 ans def
     ] pop
     popVariables
     arg1
   } def
   [(to_int32)
   [(obj to_int32 obj2)
    $All universalNumber in obj are changed to integer (int32).$
    (Example: /ff [1 (2).. [(hello) (0).]] def  ff { tag } map ::)
    (         ff to_int32 { tag } map :: )
    (cf. to_int, to_univNum )
   ]] putUsages
   
 /define_ring_variables {  /define_ring_variables {
   [/in-define_ring_variables /drv._v /drv._p /drv._v0] pushVariables    [/in-define_ring_variables /drv._v /drv._p /drv._v0] pushVariables
 %% You cannot use these names for names for polynomials.  %% You cannot use these names for names for polynomials.
Line 3828  $ [ff ff] fromVectors :: $ 
Line 3885  $ [ff ff] fromVectors :: $ 
   arg1    arg1
 } def  } 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_int32. (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
   
   /getNode {
     /arg2 set
     /arg1 set
     [/in-getNode /ob /key /rr /tt /ii] pushVariables
     [
       /ob arg1 def
       /key arg2 def
       /rr null def
       {
         ob isArray {
           ob length 1 gt {
             ob 0 get isString {
               ob 0 get , key eq {
                 /rr ob 1 get def exit
               } {  } ifelse
             } { } ifelse
           }{ } ifelse
           ob { key getNode , dup tag 0 eq {pop} { } ifelse }  map /tt set
           tt length 0 gt { /rr tt 0 get def exit }
           {/rr null def exit } ifelse
         } { } ifelse
   
         ob isClass {
           ob (array) dc /ob set
         } { } ifelse
         ob isClass , ob isArray or { } { exit } ifelse
         ob 0 get key eq {
           /rr ob def
           exit
         } {  } ifelse
         ob 2 get /ob set
         0 1 ob length 1 sub {
            /ii set
            ob ii get key getNode /rr set
            rr tag 0 eq { } { exit } ifelse
         } for
         exit
       } loop
       /arg1 rr def
     ] pop
     popVariables
     arg1
   } def
   [(getNode)
   [(ob key getNode node-value)
    (ob is a class object or an array.)
    (The operator getNode returns the node with the key in ob.)
    (When ob is a class, the node is an array of the format [key attr-list node-list])
    (When ob is an array, the node is a value of key-value pairs.)
    (Example:)
    (  /dog [(dog) [[(legs) 4] ] [ ]] [(class) (tree)] dc def)
    (  /man [(man) [[(legs) 2] ] [ ]] [(class) (tree)] dc def)
    (  /ma [(mammal) [ ] [man dog]] [(class) (tree)] dc def)
    (  ma (dog) getNode )
    (Example 2:)
    ( [ [1 ] [2 3] [[(dog) 2]]] (dog) getNode ::)
   ]] putUsages
   
   /cons {
     /arg2 set /arg1 set
     [/aa /bb] pushVariables
     [
       /aa arg1 def /bb arg2 def
       [aa] (list) dc bb join /arg1 set
     ] pop
     popVariables
     arg1
   } def
   [(cons)
   [(obj list cons list)
   ]] putUsages
   /arrayToList {
     /arg1 set
     [/a /r] pushVariables
     [
       /a arg1 def
       {
         a isArray {
          a { arrayToList } map /a set
          a (list) dc  /r set
          exit
         } {  } ifelse
         /r a def
         exit
       } loop
       /arg1 r def
     ] pop
     popVariables
     arg1
   } def
   [(arrayToList)
   [(a arrayToList list)
   ]] putUsages
   
   /listToArray {
     /arg1 set
     [/a /r] pushVariables
     [
       /a arg1 def
       {
         a tag 12 eq {
          a (array) dc  /a set
          a { listToArray } map /r set
          exit
         } {  } ifelse
         a tag 0 eq {
          /r [ ] def
          exit
         } {  } ifelse
         /r a def
         exit
       } loop
       /arg1 r def
     ] pop
     popVariables
     arg1
   } def
   [(listToArray)
   [(list listToArray a)
   ]] putUsages
   
   % Body is moved to smacro.sm1
   [(makeInfix)
   [(literal makeInfix)
    (Change literal to an infix operator.)
    (Example: /+ { add } def )
    (  /+ makeInfix)
    (  /s 0 def 1 1 100 { /i set s + i /s set } for s message)
    (  [ 1 2 3 ] { /i set i + 2 } map ::)
   ]] putUsages
   
   /usages {
     /arg1 set
     [/name /flag /n /k /slist /m /i /sss /key /ukeys] pushVariables
     [
       /name arg1 def
       /flag true def
       {  % begin loop
   
          name isArray {
            /ukeys @.usages { 0 get } map shell def
            name { /key set [(regexec) key ukeys] extension
                   { 0 get } map } map /sss set
            exit
          } {  } ifelse
   
    name tag 1 eq {
      @.usages { 0 get } map shell { (, ) nl } map /sss set
      exit
    } {
   
       /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
      exit
    } ifelse
   
   } loop
      /arg1 sss cat def
      ] pop
      popVariables
      arg1
   } def
   [(usages)
    [(key usages usages-as-a-string)
     (num usages list-of-key-words)
     ([key1 key2 ... ] usages list-of-key-words  : it accepts regular expressions.)
   ]] putUsages
   
   /setMinus {
     /arg2 set /arg1 set
     [/aa /bb /i ] pushVariables
     [
       /aa arg1 def /bb arg2 def
       [
         0 1 aa length 1 sub {
           /i set
           aa i get bb memberQ {
           } { aa i get } ifelse
         } for
       ] /arg1 set
     ] pop
     popVariables
     arg1
   } def
   [(setMinus)
   [(a b setMinus c)
   ]] putUsages
   
   % Define  some infix operators
   /~add~ { add } def /~add~ makeInfix
   /~sub~ { sub } def /~sub~ makeInfix
   /~mul~ { mul } def /~mul~ makeInfix
   /~div~ { div } def /~div~ makeInfix
   /~power~ { power } def /~power~ makeInfix
   /~put~ {
     dup tag 3 eq { exec } {  } ifelse  put
   } def
   /~put~ makeInfix
   
   /toTokensBySpace {
     /arg1 set
     [(cgiToTokens) arg1 [ ]] extension
   } def
   [(toTokensBySpace)
   [
    ( string toTokensBySpace token_array )
   ]] putUsages
   
   /setAttributeList {
     /arg2 set
     /arg1 set
     [
       [(setAttributeList) arg1 arg2] extension /arg1 set
     ] pop
     arg1
   } def
   /getAttributeList {
     /arg1 set
     [(getAttributeList) arg1] extension
   } def
   /setAttribute {
     /arg3 set
     /arg2 set
     /arg1 set
     [
       [(setAttribute) arg1 arg2 arg3] extension /arg1 set
     ] pop
     arg1
   } def
   /getAttribute {
     /arg2 set
     /arg1 set
     [(getAttribute) arg1 arg2] extension
   } def
   [(setAttributeList)
   [
    (ob attr setAttributeList new-obj )
    (Example: [(x-1) (y-1)] [(gb) 1] setAttributeList /ff set )
   ]] putUsages
   [(setAttribute)
   [
    (ob key value setAttribute new-obj )
    (Example: [(x-1) (y-1)] (gb) 1 setAttribute /ff set )
   ]] putUsages
   [(getAttributeList)
   [
    (ob getAttributeList attr-obj )
    (Example: [(x-1) (y-1)] [(gb) 1] setAttributeList /ff set )
    (         ff getAttributeList :: )
   ]] putUsages
   [(getAttribute)
   [
    (ob key getAttribute value )
    (Example: [(x-1) (y-1)] (gb) 1 setAttribute /ff set )
    (         ff (gb) getAttribute :: )
   ]] putUsages
   
   % [(gbCheck) 1 (needSyz) 1 (countDown) 100]  (attribute format)
   % --> [(gbCheck) (needSyz) (countDown) 100]  (groebner option format)
   % cf. gb
   /configureGroebnerOption {
     /arg1 set
     [/opt /i] pushVariables
     [
       /opt arg1 def
       opt tag 0 eq {
        /arg1 null def
       } {
        [
         0 2 opt length 1 sub {
           /i set
           opt i get
           opt i get (countDown) eq {
              opt i 1 add get
           } { } ifelse
           opt i get (stopDegree) eq {
              opt i 1 add get
           } { } ifelse
         } for
        ] /arg1 set
       } ifelse
     ] pop
     popVariables
     arg1
   } def
   
   [(getFileType)
   [
    (string getFileType type)
    $Example: (/www/prog/cohom.sm1) getFileType ==> (sm1)$
   ]] putUsages
   /getFileType {
     /arg1 set
     [/ss ] pushVariables
     [ /ss arg1 def
       [(stringToArgv2) ss (.)] extension /ss set
       ss, ss length 1 sub, get /arg1 set
     ] pop
     popVariables
     arg1
   } def
   
   % Default initial value.
   /localizedString.file null def
   /localizedString.dic [ ] def
   /localizedString.local { } def
   
   % Clear and load
   /localizedString.load {
     /localizedString.dic [ ] def
     /localizedString.local { } def
     localizedString.file tag 0 eq { }
     { [(parse) localizedString.file pushfile] extension pop  } ifelse
   } def
   
   
   [(localizedString)
    [
     (string localizedString translatedString)
     (It returns localizedString if localizedString.dic [array] and)
     (localizedString.local [function] are set.)
    ]
   ] putUsages
   /localizedString {
     /arg1 set
     [/ss /ans /tt] pushVariables
     [
       arg1 /ss set
       /ans ss def
       {
         localizedString.dic length 0  eq { exit } { } ifelse
         localizedString.dic ss getNode /tt set
         tt tag 0 eq {  } { tt /ans set exit } ifelse
         ss localizedString.local /ans set
         exit
       } loop
       ans /arg1 set
     ] pop
     popVariables
     arg1
   } def
   
   [(univ2poly)
   [(list univ2poly list2)
    (Change universal numbers in list to an element of a ring of polynomials)
    (defined by other elements in list. If there is no polynomial element,)
    (the current ring is used.)
   ]] putUsages
   /univ2poly {
     /arg1 set
     [/aa /rg /ag /ans] pushVariables
     [
       arg1 /aa set
       [(CurrentRingp)] system_variable /rg set
       aa getRing /ag set
       ag tag 0 { } {
         ag ring_def
       } ifelse
       aa univ2poly.aux /ans set
       rg ring_def
       ans /arg1 set
     ] pop
     popVariables
     arg1
   } def
   
   /univ2poly.aux {
     /arg1 set
     [/aa /ans] pushVariables
     [
       arg1 /aa set
       aa getRing
       aa tag 6 eq {
         aa { univ2poly.aux} map /ans set
       }{
         aa tag 15 eq, aa tag 1 eq, or { aa toString . /ans set } {
           aa /ans set
         } ifelse
       } ifelse
       ans /arg1 set
     ] pop
     popVariables
     arg1
   } def
   
   /sm1log {
     /arg1 set
     [/ss /fd ] pushVariables
     [
       arg1 /ss set
       (/tmp/sm1log.txt) (a) file /fd set
       fd , [[(date)] extension
             ss (string) dc] cat , writestring
       fd closefile
     ] pop
     popVariables
   } def
   
 ;  ;
   
Legend:
Removed from v.1.23  
changed lines
  Added in v.1.56
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>