=================================================================== RCS file: /home/cvs/OpenXM/src/kan96xx/Kan/dr.sm1,v retrieving revision 1.1.1.1 retrieving revision 1.24 diff -u -p -r1.1.1.1 -r1.24 --- OpenXM/src/kan96xx/Kan/dr.sm1 1999/10/08 02:12:02 1.1.1.1 +++ OpenXM/src/kan96xx/Kan/dr.sm1 2003/09/13 13:14:03 1.24 @@ -1,8 +1,9 @@ +% $OpenXM: OpenXM/src/kan96xx/Kan/dr.sm1,v 1.23 2003/09/12 02:52:50 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 ::) ] @@ -2487,6 +2534,46 @@ newline arg1 } def +[(ord_w_all) + [(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 ...]) + (Example: [(x,y,t) ring_of_polynomials 0] define_ring ) + ( (x^2 y^3-x-t). [(t) 1 ] ord_w_all ::) + ] +] putUsages +/ord_w_all { + /arg2 set /arg1 set + [/ord_w_all-in /fff /fff-in /www /rrr /iii /ddd /zzz /ddd-tmp] pushVariables + [ + /fff arg1 def + /www arg2 def + fff (0). eq { /ddd -intInfinity def /ord_w_all.LLL goto} { } ifelse + /ddd -intInfinity def + fff (ring) dc /rrr set + /zzz (0) rrr ,, def + fff init /fff-in set + fff fff-in sub /fff set + { + /ddd-tmp 0 def + 0 2 www length 1 sub { + /iii set + fff-in << www iii get rrr ,, >> degree + << www iii 1 add get >> mul + ddd-tmp add /ddd-tmp set + } for + ddd-tmp ddd gt { /ddd ddd-tmp def } { } ifelse + fff zzz eq { exit } { } ifelse + fff init /fff-in set + fff fff-in sub /fff set + } loop + /ord_w_all.LLL + /arg1 ddd def + ] pop + popVariables + arg1 +} def + [(laplace0) [ (f [v1 ... vn] laplace0 g) @@ -3027,6 +3114,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 @@ -3191,6 +3322,10 @@ newline ]] putUsages /cancelCoeff { + /arg1 set + [(reduceContent) arg1] gbext 0 get +} def +/cancelCoeff_org { /arg1 set [/in-cancelCoeff /ff /gg /dd /dd2] pushVariables [ /ff arg1 def @@ -3487,6 +3622,257 @@ $ [ff ff] fromVectors :: $ [(nl) [(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 + +[(execve) + [ + (command execve) + ([arg0 arg1 arg2 ...] execve ) + (It executes the command by the system call execve.) + (cf. system, forkExec) + ] +] putUsages + +/execve { + /execve.arg set + [(forkExec) execve.arg [ ] 1] extension +} def + +[(beginEcart) + [ + (beginEcart) + (Set the environments for the ecart division algorithm.) + ] +] putUsages + +/ecart.debug_reduction1 0 def +/beginEcart { + (red@) (ecart) switch_function + [(Ecart) 1] system_variable + [(CheckHomogenization) 0] system_variable + [(ReduceLowerTerms) 0] system_variable + [(AutoReduce) 0] system_variable + [(EcartAutomaticHomogenization) 0] system_variable + ecart.debug_reduction1 { + (red@) (debug) switch_function + } { } ifelse +} def + +[(endEcart) + [ + (endEcart) + (End of using the ecart division algorithm.) + ] +] putUsages + +/endEcart { + (red@) (standard) switch_function + [(Ecart) 0] system_variable + [(degreeShift) (reset)] homogenize pop +} def + +/ord_ws_all { + /arg2 set /arg1 set + [(ord_ws_all) arg1 arg2] gbext +} def +[(ord_ws_all) + [ + (fv wv ord_ws_all degree) + ( ord_ws_all returns the ord with respect to the weight vector wv.) + $Example: [(x,y) ring_of_differential_operators 0] define_ring $ + $ (Dx^2+x*Dx*Dy+2). [(Dx) 1 (Dy) 1] weightv ord_ws_all :: $ + ( ) + (fv [wv shiftv] ord_ws_all degree) + ( ord_ws_all returns the ord with respect to the weight vector wv and) + ( the shift vector shiftv.) + $Example: [(x,y) ring_of_differential_operators 0] define_ring $ + $ [(Dx^2+x*Dx*Dy+2). (Dx).] [[(Dx) 1 (Dy) 1] weightv [0 2]] ord_ws_all ::$ + ( ) + (cf: init, gbext. Obsolete: ord_w, ord_w_all) + ] +] putUsages + +[(newVector) + [( n newVector vec) +]] putUsages +/newVector { + /arg1 set + [/in-newVector /n] pushVariables + [ + /n arg1 def + [(newVector) n] extension /arg1 set + ] pop + popVariables + arg1 +} def + +[(newMatrix) + [( [m n] newMatrix mat) +]] putUsages +/newMatrix { + /arg1 set + [/in-newMatrix /n] pushVariables + [ + /n arg1 def + [(newMatrix) n 0 get n 1 get] extension /arg1 set + ] pop + popVariables + arg1 +} def + +/usages { + /arg1 set + [/name /flag /n /k /slist /m /i /sss] pushVariables + [ + /name arg1 def + /flag true def + + %BUG: should use regular expression in a future. + name tag 1 eq { + @.usages { 0 get } map shell { (, ) nl } map /sss set + } { + + /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 + } ifelse + /arg1 sss cat def + ] pop + popVariables + arg1 +} def +[(usages) + [(key usages usages-as-a-string) + (num usages list-of-key-words) ]] putUsages ;