%% This package requires kan/sm1 version 951228 or later.
%% The binary file of kan/sm1 of this version is temporary obtainable from
%% ftp.math.s.kobe-u.ac.jp. The file /pub/kan/sm1.binary.sunos4.3.japanese
%% is for sun with JLE.
%% How to Install
%% 1.Copy this file and rename it to sm1 (mv sm1.binary.sunos4.3.japanese sm1).
%% 2.Add executable property (chmod +x sm1).

(factor-a.sm1 : kan/sm1 package to factor polynomials by calling risa/asir.)
message
(             : kan/sm1 package to simplify rationals by calling risa/asir.)
message
(             : kan/sm1 package to compute hilbert polynomials by calling sm0.)
message
(               Version June 30, 1997. It runs on kan/sm1 version 951228 or later.) message


[(factor)
 [(polynomial factor list_of_strings)
  (Example: (x^2-1). factor :: ---> [[$1$ $1$] [$x-1$ $1$] [$x+1$ $1$]])
  (cf.:     data_conversion, map, get, pushfile)
  (Note:    The function call creates work files asir-tmp.t, asir-tmp.tt,)
  (          asir-tmp-out.t, asri-tmp-log.t and asir-tmp-out.tt )
  (          in the current directory.)
 ]
] putUsages

%% /f (Dx^10*d*a-d*a) def

/factor-asir-1 {
 /arg1 set
 [/f /fd /fnewline] pushVariables
 [
  arg1 /f set
  %% (factor-asir-1 is tested with Asir version 950831 on Linux.) message
  (asir-tmp.t) (w) file /fd set
  /fnewline { fd 10 (string) data_conversion writestring } def
  fd $output("asir-tmp-out.t");$ writestring fnewline
  fd $fctr($ writestring 
  fd  f writestring
  fd $); output(); quit(); $ writestring fnewline
  fd closefile
  (/bin/rm -f asir-tmp.tt) system
  (sed "s/D/kanD/g" asir-tmp.t | sed "s/E/kanE/g" | sed "s/Q/kanQ/g" >asir-tmp.tt) system
  (/bin/rm -f asir-tmp-out.t asir-tmp-out.tt asir-tmp-log.t) system
  (asir <asir-tmp.tt >asir-tmp-log.t) system
  (sed "s/\[1\]/ /g" asir-tmp-out.t | sed "s/\[2\]/ /g" | sed "1s/1/ /g"| sed "s/\[/{/g" | sed "s/\]/}/g" | sed "s/kanD/D/g" | sed "s/kanE/E/g" | sed "s/kanQ/Q/g" >asir-tmp-out.tt) system
 ] pop
 popVariables
} def

/clean-workfiles {
 (/bin/rm -f asir-tmp-out.t asir-tmp-out.tt asir-tmp.t asir-tmp.tt sm0-tmp.t sm0-tmp-out.t asir-tmp-log.t) system
} def


%% comment: there is not data conversion function from string --> array
%%                           e.g. (abc) ---> [0x61, 0x62, 0x63]
%%          We can do (abc) 1 10 put, but "get" does not work for strings.

%% f factor-asir-1

%%/aaa 
%% ({{1,1},{x-1,1},{x+1,1},{x^4+x^3+x^2+x+1,1},{x^4-x^3+x^2-x+1,1}})
%%def

/asir-list-to-kan {
  /arg1 set
  [/aaa /ftmp /ftmp2] pushVariables
  [
    /aaa arg1 def
    [ aaa to_records pop ] /ftmp set
    ftmp { to_records pop [ 3 1 roll ] } map /ftmp2 set
    /arg1 ftmp2 def
  ] pop
  popVariables
  arg1
} def

/foo {
  (input string is in f) message
  f ::
  f factor-asir-1
  %% (asir-tmp-out.tt) run 
  %% (answer in @asir.out) message
  %% bug of run.
  (asir-tmp-out.tt) pushfile /@asir.out set
  @asir.out asir-list-to-kan /ff2 set
  (answer in ff2) message
} def

/factor {
  (string) data_conversion
  factor-asir-1
  (asir-tmp-out.tt) pushfile asir-list-to-kan
} def

%%%%%%%%%%%%%%%%% macros for simplification (reduction, cancel)
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
[(cancel)
 [(polynomial cancel list_of_strings)
  (This function simplifies rationals.)
  (Example: $x^2-1$. $x+1$. div cancel :: ---> [[$x-1$ , $1$]])
  (Note:    The function call creates work files asir-tmp.t, asir-tmp.tt,)
  (          asir-tmp-out.t, asri-tmp-log.t and asir-tmp-out.tt )
  (          in the current directory.)
 ]
] putUsages

/reduce-asir-1 {
 /arg1 set
 [/f /fd /fnewline] pushVariables
 [
  arg1 /f set
  %% (reduce-asir-1 is tested with Asir version 950831 on Linux.) message
  (asir-tmp.t) (w) file /fd set
  /fnewline { fd 10 (string) data_conversion writestring } def
  fd $output("asir-tmp-out.t");$ writestring fnewline
  fd $AsirTmp012=red($ writestring 
  fd  f writestring
  fd $)$ writestring 
  fd ($ )  writestring fnewline
  fd $AsirTmp013=ptozp(nm(AsirTmp012))$ writestring
  fd ($ )  writestring fnewline
  fd $AsirTmp014=red(nm(AsirTmp012)/AsirTmp013)$ writestring
  fd ($ )  writestring fnewline
  fd $[[nm(AsirTmp014)*AsirTmp013,dn(AsirTmp014)*dn(AsirTmp012)]];output();quit(); $ writestring fnewline
  fd closefile
  (/bin/rm -f asir-tmp.tt) system
  (sed "s/D/kanD/g" asir-tmp.t | sed "s/E/kanE/g" | sed "s/Q/kanQ/g" >asir-tmp.tt) system
  (/bin/rm -f asir-tmp-out.t asir-tmp-out.tt asir-tmp-log.t) system
  (asir <asir-tmp.tt >asir-tmp-log.t) system
  (sed "s/\[1\]/ /g" asir-tmp-out.t | sed "s/\[2\]/ /g" |sed "s/\[3\]/ /g" |sed "s/\[4\]/ /g" |sed "s/\[5\]/ /g" | sed "1s/1/ /g"| sed "s/\[/{/g" | sed "s/\]/}/g" | sed "s/kanD/D/g" | sed "s/kanE/E/g" | sed "s/kanQ/Q/g" | sed "s/kanLeftBrace/\[/g" | sed "s/kanRightBrace/\]/g" | sed "s/kanComma/\,/g" >asir-tmp-out.tt) system


 ] pop
 popVariables
} def

/cancel {
  (string) data_conversion
  reduce-asir-1
  (asir-tmp-out.tt) pushfile asir-list-to-kan
} def

%%%%%%%%%%%%%%%%% macros for Hilbert functions
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
/hilbert {
 /arg2 set
 /arg1 set
 [/bases /vars] pushVariables
 [
   /bases arg1 def
   /vars arg2 def
   bases {init (string) data_conversion} map /bases set
   bases vars execSm0

   (sed '1s/^\$/{/g' sm0-tmp-out.t | sed '1s/\$$/ , /g' | sed '2s/^\$//g' | sed '2s/\$$/}/g' | sed 's/V//g' >sm0-tmp-out.tt) system
 ] pop
 popVariables
 [ (sm0-tmp-out.tt) pushfile to_records pop]
} def
[(hilbert)
 [(------------------------------------------------------------------------)
  (list_of_polynomials variables hilbert hilbert_function)
  (Example: [(x^2-1). (x y -2).] (x,y)  hilbert :: ---> [$n !$ $a_d x^d + ...$] )
  (Example: [(x^2-1). (x y -2).] (x,y) hilbert (x) hilbReduce --> m x^d + ...::)
  (         where m is the multiplicity.)
  (cf.:     hilbReduce, data_conversion, map, get, pushfile)
  (Note:    The function call creates work files sm0-tmp.t, sm0-tmp-out.tt,)
  (         sm0-tmp-log.t and sm0-tmp-out.t in the current directory.)
 ]
] putUsages


%% Ex. [(x^2) (y^3) (x y)] (x,y) execSm0
/execSm0 {
 /arg2 set
 /arg1 set
 [/monoms /fd /tmp /vars] pushVariables
 [
  /monoms arg1 def
  /vars arg2 def
  (/bin/rm -f sm0-tmp-out.t sm0-tmp-out.tt sm0-tmp-log.t) system
  (sm0-tmp.t) (w) file /fd set
  fd ( ${-p,0}$ options ) writestring
  fd ( $) writestring
  ${$ vars $}$ 3 cat_n /tmp set
  fd tmp writestring
  fd ($  ) writestring
  fd ( polynomial_ring set_up_ring ${-proof}$ options ) writestring
  fd monoms writeArray
  fd ( /ff =  ff yaGroebner /gg = gg hilbert2 /ans = ) writestring
  fd (ans :: ans decompose $sm0-tmp-out.t$ printn_to_file quit) writestring
  fd closefile
  (sm0 -f sm0-tmp.t >>sm0-tmp-log.t) system
  (When the output is [$ a V^k + ... $ $p!$], the multiplicity is ) message
  $               (k! a)/p! $ message
  (    ) message
 ] pop
 popVariables
} def


/writeArray {
  /arg2 set /arg1 set
  [/fd /arr /k] pushVariables
  [ /fd arg1 def
    /arr arg2 def
    fd ([ ) writestring
    0 1 arr length 1 sub
    {
      /k set
      fd ($ ) writestring
      fd arr k get writestring
      fd ($     ) writestring
    } for
    fd ( ] ) writestring
  ] pop
  popVariables
} def

[(hilbReduce)
 [([f,g] v hilbReduce h) 
  $ [(x-z).  (y^3).] (x,y,z) hilbert (x) hilbReduce $
 ]
] putUsages
/hilbReduce {
  /arg2 set
  /arg1 set
  [/hhh /f /d /vv /ans] pushVariables
  [
     /hhh arg1 def
     /vv arg2 def
     /f hhh 1 get . def
     f vv . degree /vv set
     hhh 0 get /d set  d << d length 1 sub >> 0 put %% remove !
     << d .. >> << d .. (integer) dc >> factorial /d set
     d << vv (universalNumber) dc vv factorial >> idiv /d set
     [(divByN) f d] gbext /ans set
     ans 1 get (0). eq 
     {  }
     { (hilbReduce : Invalid hilbert function ) message error } ifelse
     ans 0 get /arg1 set
  ]  pop
  popVariables
  arg1
} def[(hilbReduce)
 [([f,g] v hilbReduce h) 
  $ [(x-z).  (y^3).] (x,y,z) hilbert (x) hilbReduce $
 ]
] putUsages
/hilbReduce {
  /arg2 set
  /arg1 set
  [/hhh /f /d /vv /ans] pushVariables
  [
     /hhh arg1 def
     /vv arg2 def
     /f hhh 1 get . def
     f vv . degree /vv set
     hhh 0 get /d set  d << d length 1 sub >> 0 put %% remove !
     << d .. >> << d .. (integer) dc >> factorial /d set
     d << vv (universalNumber) dc vv factorial >> idiv /d set
     [(divByN) f d] gbext /ans set
     ans 1 get (0). eq 
     {  }
     { (hilbReduce : Invalid hilbert function ) message error } ifelse
     ans 0 get /arg1 set
  ]  pop
  popVariables
  arg1
} def

(Loaded macros "factor", "cancel", "hilbert", "hilbReduce".) message