=================================================================== RCS file: /home/cvs/OpenXM/src/kan96xx/Kan/dr.sm1,v retrieving revision 1.1.1.1 retrieving revision 1.11 diff -u -p -r1.1.1.1 -r1.11 --- OpenXM/src/kan96xx/Kan/dr.sm1 1999/10/08 02:12:02 1.1.1.1 +++ OpenXM/src/kan96xx/Kan/dr.sm1 2003/05/15 00:42:07 1.11 @@ -1,8 +1,9 @@ +% $OpenXM: OpenXM/src/kan96xx/Kan/dr.sm1,v 1.10 2002/11/08 14:18:01 takayama Exp $ %% dr.sm1 (Define Ring) 1994/9/25, 26 %% This file is error clean. @@@.quiet { } -{ (macro package : dr.sm1, 9/26,1995 --- Version 9/8, 1999. ) message } ifelse +{ (macro package : dr.sm1, 9/26,1995 --- Version 12/10, 2000. ) message } ifelse /ctrlC-hook { %%% define your own routing in case of error. @@ -256,6 +257,8 @@ /arg1 set [/vars /n /i /xList /dList /param] pushVariables [ + (This is an obsolete macro. Use ring_of_differential_difference_operators) + error (mmLarger) (matrix) switch_function (mpMult) (difference) switch_function (red@) (module1) switch_function @@ -277,7 +280,44 @@ } def +/ring_of_differential_difference_operators { + /arg1 set + [/vars /n /i /xList /dList /param /dvar /evar /vars2 ] pushVariables + [ + /vars arg1 def + vars tag 6 eq not { + ( List is expected as the argument for ring_of_differential_difference_operators ) error + } { } ifelse + vars 0 get /dvar set + vars 1 get /evar set + (mmLarger) (matrix) switch_function + (mpMult) (difference) switch_function + (red@) (module1) switch_function + (groebner) (standard) switch_function + (isSameComponent) (x) switch_function + [dvar to_records pop] /vars set %[x y z] + vars reverse /xList set %[z y x] + + [evar to_records pop] /vars2 set %[s1 s2] + + vars2 reverse {@@@.Esymbol 2 1 roll 2 cat_n} map + xList + join /xList set %[Es2 Es1 z y x] + + vars2 reverse + vars {@@@.Dsymbol 2 1 roll 2 cat_n} map + reverse join /dList set %[s2 s1 Dz Dy Dx] + [(H)] xList join [@@@.esymbol] join /xList set + [(h)] dList join [@@@.Esymbol] join /dList set + [0 1 1 << vars2 length 1 add >> << xList length >> + 1 1 << vars2 length 1 add >> << xList length 1 sub >> ] /param set + [ xList dList param ] /arg1 set + ] pop + popVariables + arg1 +} def + /reverse { /arg1 set arg1 length 1 lt @@ -1473,6 +1513,13 @@ (type?) data_conversion RationalFunctionP eq } def +[(isRing) + [(obj isRing bool) ] +] putUsages +/isRing { + (type?) data_conversion RingP eq +} def + /toString.tmp { /arg1 set [/obj /fname] pushVariables @@ -1527,7 +1574,7 @@ /obj arg1 def obj isArray { - ( [ ) + [(LeftBracket)] system_variable %%( [ ) obj {toString.tmp2} map /r set /n r length 1 sub def [0 1 n { @@ -1539,7 +1586,7 @@ ifelse } for ] aload length cat_n - ( ] ) + [(RightBracket)] system_variable %%( ] ) 3 cat_n } { @@ -2275,7 +2322,7 @@ newline /tolower.aux { /arg1 set - arg1 64 gt arg1 96 lt and + arg1 64 gt arg1 91 lt and { arg1 32 add } { arg1 } ifelse } def @@ -2459,7 +2506,7 @@ newline [(ord_w) [(ff [v1 w1 v2 w2 ... vm wm] ord_w d) (poly ff; string v1; integer w1; ...) - (order of ff by the weight vector [w1 w2 ...]) + (order of the initial of ff by the weight vector [w1 w2 ...]) (Example: [(x,y) ring_of_polynomials 0] define_ring ) ( (x^2 y^3-x). [(x) 2 (y) 1] ord_w ::) ] @@ -3027,6 +3074,50 @@ newline arg1 } def +/distraction2* { + /arg1 set + [/in-distraction2* /aa /f /vlist /xlist /dlist /slist ] pushVariables + [(CurrentRingp)] pushEnv + [ + /aa arg1 def + /f aa 0 get def + /vlist aa 1 get def + /xlist aa 2 get def + /dlist aa 3 get def + /slist aa 4 get def + vlist isArray + { + vlist { toString } map /vlist set + } + { + vlist toString to_records /vlist set + } ifelse + xlist isArray + { + xlist { toString } map /xlist set + } + { + xlist toString to_records /xlist set + } ifelse + slist isArray + { + slist { toString } map /slist set + } + { + slist toString to_records /slist set + } ifelse + [vlist from_records ring_of_differential_operators 0] define_ring pop + f toString . + xlist { . } map + dlist { toString . } map + slist { toString . } map + distraction2 /arg1 set + ] pop + popEnv + popVariables + arg1 +} def + /message-quiet { @@@.quiet { pop } { message } ifelse } def @@ -3488,6 +3579,114 @@ $ [ff ff] fromVectors :: $ [(nl is the newline character.) $Example: [(You can break line) nl (here.)] cat message$ ]] putUsages + +/to_int { + /arg1 set + [/to-int /ob /ans] pushVariables + [ + /ob arg1 def + /ans ob def + ob isArray { + ob {to_int} map /ans set + /LLL.to_int goto + } { } ifelse + ob isInteger { + ob (universalNumber) dc /ans set + /LLL.to_int goto + } { } ifelse + /LLL.to_int + /arg1 ans def + ] pop + popVariables + arg1 +} def +[(to_int) +[(obj to_int obj2) + (All integers in obj are changed to universalNumber.) + (Example: /ff [1 2 [(hello) (0).]] def ff { tag } map ::) + ( ff to_int { tag } map :: ) +]] putUsages + +/define_ring_variables { + [/in-define_ring_variables /drv._v /drv._p /drv._v0] pushVariables +%% You cannot use these names for names for polynomials. + [ + /drv._v getVariableNames def + /drv._v0 drv._v def + drv._v { dup /drv._p set (/) 2 1 roll ( $) drv._p ($. def ) } map cat + /drv._v set +% drv._v message + [(parse) drv._v] extension + ] pop + popVariables +} def +[(define_ring_variables) +[(It binds a variable <> in the current ring to the sm1 variable <>.) + (For example, if x is a variable in the current ring, it defines the sm1) + (variable x by /x (x) def) +]] putUsages + +/boundp { + /arg1 set + [/a /ans] pushVariables + [ + /a arg1 def + [(parse) [(/) a ( load tag 0 eq { /ans 0 def } ) + ( { /ans 1 def } ifelse )] cat ] extension + /arg1 ans def + ] pop + popVariables + arg1 +} def +[(boundp) + [( a boundp b) + (string a, b is 0 or 1.) + (If the variable named << a >> is bounded to a value,) + (it returns 1 else it returns 0.) + $Example: (hoge) boundp ::$ +]] putUsages +[(isSubstr) + [ + (s1 s2 isSubstr pos) + (If s1 is a substring of s2, isSubstr returns the position in s2 from which) + (s1 is contained in s2.) + (If s1 is not a substring of s2, then isSubstr returns -1.) + ] +] putUsages +/isSubstr { + /arg2 set /arg1 set + [/in-isSubstr /s1 /s2 /i1 /i2 /n1 /n2 + /ans /flg + ] pushVariables + [ + /s1 arg1 def + /s2 arg2 def + s1 (array) dc /s1 set + s2 (array) dc /s2 set + /n1 s1 length def + /n2 s2 length def + /ans -1 def + 0 1 n2 n1 sub { + /i2 set + /flg 1 def + 0 1 n1 1 sub { + /i1 set + s1 i1 get s2 i2 i1 add get eq { + } { + /flg 0 def exit + } ifelse + } for + flg { + /ans i2 def + /isSubstr.L2 goto + } { /ans -1 def } ifelse + } for + /isSubstr.L2 + /arg1 ans def + ] pop + popVariables + arg1 +} def ;