File: [local] / OpenXM / src / kan96xx / Kan / smacro.sm1.old1 (download)
Revision 1.1.1.1 (vendor branch), Fri Oct 8 02:12:02 1999 UTC (24 years, 11 months ago) by maekawa
Branch: OpenXM, MAIN
CVS Tags: maekawa-ipv6, R_1_3_1-2, RELEASE_20000124, RELEASE_1_3_1_13b, RELEASE_1_2_3_12, RELEASE_1_2_3, RELEASE_1_2_2_KNOPPIX_b, RELEASE_1_2_2_KNOPPIX, RELEASE_1_2_2, RELEASE_1_2_1, RELEASE_1_1_3, RELEASE_1_1_2, KNOPPIX_2006, HEAD, DEB_REL_1_2_3-9, ALPHA Changes since 1.1: +0 -0
lines
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
;