=================================================================== RCS file: /home/cvs/OpenXM/src/kan96xx/Kan/dr.sm1,v retrieving revision 1.1.1.1 retrieving revision 1.47 diff -u -p -r1.1.1.1 -r1.47 --- OpenXM/src/kan96xx/Kan/dr.sm1 1999/10/08 02:12:02 1.1.1.1 +++ OpenXM/src/kan96xx/Kan/dr.sm1 2004/09/20 02:11:22 1.47 @@ -1,8 +1,9 @@ +% $OpenXM: OpenXM/src/kan96xx/Kan/dr.sm1,v 1.46 2004/09/17 00:47:08 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. @@ -49,7 +50,7 @@ } for ] /dList set - [(H)] xList join [@@@.esymbol] join /xList set + [@@@.Hsymbol] xList join [@@@.esymbol] join /xList set [(h)] dList join [@@@.Esymbol] join /dList set [0 %% dummy characteristic << xList length >> << xList length >> << xList length >> @@ -166,7 +167,7 @@ vars reverse /xList set %[z y x] vars {@@@.Dsymbol 2 1 roll 2 cat_n} map 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 [0 1 1 1 << xList length >> 1 1 1 << xList length 1 sub >> ] /param set @@ -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 @@ -266,7 +269,7 @@ vars reverse /xList set %[z y x] vars {@@@.diffEsymbol 2 1 roll 2 cat_n} map 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 [0 1 1 << xList length >> << xList length >> 1 1 << xList length 1 sub >> << xList length >> ] /param set @@ -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] + [@@@.Hsymbol] 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 @@ -302,12 +342,14 @@ 0 1 << set0 length 1 sub >> { /i set - << set0 i get >> a eq - { - /flag 1 def - } - { } - ifelse + set0 i get tag , a tag , eq { + << set0 i get >> a eq + { + /flag 1 def exit + } + { } + ifelse + } { } ifelse } for ] pop /arg1 flag def @@ -321,6 +363,8 @@ [ /mat arg1 def /m mat length def + { + m 0 eq { /ans [ ] def exit } { } ifelse mat 0 get isArray { } { (transpose: Argument must be an array of arrays.) error } @@ -334,6 +378,8 @@ ans [ j i ] << mat i get j get >> put } for } for + exit + } loop /arg1 ans def ] pop popVariables @@ -747,7 +793,7 @@ ( Pointer to the ring. ) (Example: [$x,y$ ring_of_q_difference_operators $Qx,Qy$ elimination_order) ( 0] define_qring ) - (cf. define_ring, set_up_ring@ , ring_def, << ,, >>) + (cf. define_ring, set_up_ring@ , ring_def, << __ >>) ] ] putUsages /define_qring { @@ -799,7 +845,7 @@ (one may use the command ) ( f (ring) data_conversion /R set) (cf. define_ring, define_qring, system_variable, poly (ring) data_conversion) - (cf. << ,, >>) + (cf. << __ >>) ] ] putUsages @@ -1288,6 +1334,7 @@ /univ vars 0 get reverse vars 1 get reverse join def + w-vectors to_int32 /w-vectors set [ 0 1 << w-vectors length 1 sub >> { @@ -1310,7 +1357,8 @@ /arg2 set /arg1 set [/univ /www /k /vname /vweight /ans] pushVariables /univ arg1 def /www arg2 def - [ + [ + www to_int32 /www set /ans << univ length >> -1 0 evecw def 0 2 << www length 2 sub >> { @@ -1365,7 +1413,7 @@ gg (0). eq { 0 } { gg (ring) data_conversion /rr set - gg << var rr ,, >> degree + gg << var rr __ >> degree } ifelse } map def %%degs message @@ -1473,6 +1521,20 @@ (type?) data_conversion RationalFunctionP eq } def +[(isRing) + [(obj isRing bool) ] +] putUsages +/isRing { + (type?) data_conversion RingP eq +} def + +[(isByteArray) + [(obj isByteArray bool) ] +] putUsages +/isByteArray { + (type?) data_conversion ByteArrayP eq +} def + /toString.tmp { /arg1 set [/obj /fname] pushVariables @@ -1502,6 +1564,8 @@ { obj (string) data_conversion } { } ifelse obj isRational { obj (string) data_conversion } { } ifelse + obj isByteArray + { obj (array) data_conversion toString } { } ifelse obj tag 0 eq { (null) } { } ifelse @@ -1527,7 +1591,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 +1603,7 @@ ifelse } for ] aload length cat_n - ( ] ) + [(RightBracket)] system_variable %%( ] ) 3 cat_n } { @@ -1616,9 +1680,10 @@ /RationalFunctionP 16 def /ClassP 17 def /DoubleP 18 def +/ByteArrayP 19 def /@.datatypeConstant.usage [ (IntegerP, LiteralP, StringP, ExecutableArrayP, ArrayP, PolyP, FileP, RingP,) - (UniversalNumberP, RationalFunctionP, ClassP, DoubleP) + (UniversalNumberP, RationalFunctionP, ClassP, DoubleP, ByteArrayP) ( return data type identifiers.) (Example: 7 tag IntegerP eq ---> 1) ] def @@ -1633,18 +1698,19 @@ [(RationalFunctionP) @.datatypeConstant.usage ] putUsages [(ClassP) @.datatypeConstant.usage ] putUsages [(DoubleP) @.datatypeConstant.usage ] putUsages +[(ByteArrayP) @.datatypeConstant.usage ] putUsages -[(,,) - [( string ring ,, polynomial) +[(__) + [( string ring __ polynomial) (Parse the <> as an element in the <> and returns) (the polynomial.) (cf. define_ring, define_qring, ring_def) (Example: [(x,y) ring_of_polynomials [[(x) 1]] weight_vector 7]define_ring) ( /myring set) - ( ((x+y)^4) myring ,, /f set) + ( ((x+y)^4) myring __ /f set) ]] putUsages -/,, { +/__ { /arg2 set /arg1 set [/rrr] pushVariables [ arg1 tag StringP eq @@ -1654,7 +1720,7 @@ /arg1 arg1 expand def [(CurrentRingp) rrr] system_variable } - {(Argument Error for ,, ) error } + {(Argument Error for __ ) error } ifelse ] pop popVariables @@ -1665,8 +1731,9 @@ [( string .. universalNumber) (Parse the << string >> as a universalNumber.) (Example: (123431232123123).. /n set) + ({ commands }.. executes the commands. << .. >> is equivalent to exec.) ]] putUsages -/.. { (universalNumber) data_conversion } def +/.. { dup tag 3 eq { exec } { (universalNumber) data_conversion} ifelse } def [(dc) [(Abbreviation of data_conversion.) @@ -1719,7 +1786,11 @@ /arg1 set [/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 k 0 lt { 1 1 << 0 k sub >> { @@ -1732,7 +1803,8 @@ /ans f ans {mul} sendmsg2 def } for } ifelse - /arg1 ans def + } ifelse + /arg1 ans def ] pop popVariables arg1 @@ -1871,8 +1943,8 @@ newline } def %%end of function -/rest { % returns remainder of a given list - [ 2 1 roll aload length -1 roll pop ] +/rest { + /arg1 set [(Krest) arg1] extension } def [(rest) [(array rest the-rest-of-the-array) @@ -1895,7 +1967,7 @@ newline error } ifelse /myring base 0 get (ring) dc def - /zero (0) myring ,, def + /zero (0) myring __ def base length 1 sub /n set /minbase [ 0 1 n { /i set base i get } for ] def 0 1 n { @@ -2204,7 +2276,7 @@ newline [(variableNames) M2N 0 get] system_variable f toString /f2 set [(variableNames) M2N 3 get] system_variable - f2 M2N 2 get ,, /f2 set + f2 M2N 2 get __ /f2 set } ifelse [(CurrentRingp) cp] system_variable /arg1 f2 def @@ -2230,7 +2302,7 @@ newline $/R2 set$ $[[(x) (Dx)] [((t-1) Dt) (z)]] /r0 set$ $r0 R1 R2 makeRingMap /maptable set$ - $(Dx-1) R1 ,, /ff set$ + $(Dx-1) R1 __ /ff set$ $ ff maptable ringmap :: $ ] ] putUsages @@ -2275,7 +2347,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 @@ -2316,7 +2388,7 @@ newline /rrr set base { . } map /base set } ifelse - vlist { dup isPolynomial { } { rrr ,, } ifelse } map /vlist set + vlist { dup isPolynomial { } { rrr __ } ifelse } map /vlist set [(hilbert) base vlist] extension /ff set [(CurrentRingp) rrrorg] system_variable @@ -2335,7 +2407,7 @@ newline /vv arg2 def /f hhh 1 get def 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 d d (integer) dc factorial /d set d << vv (universalNumber) dc vv factorial >> idiv /d set @@ -2411,9 +2483,9 @@ newline { /fn (0). def } { f (ring) dc /rrr set - v toString (^) n toString 3 cat_n rrr ,, + v toString (^) n toString 3 cat_n rrr __ f mul - [[v (0).] [(h) rrr ,, (1) rrr ,,]] replace /fn set + [[v (0).] [(h) rrr __ (1) rrr __]] replace /fn set } ifelse fn /arg1 set ] pop @@ -2459,7 +2531,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 ::) ] @@ -2470,13 +2542,14 @@ newline [ /fff arg1 def /www arg2 def + www to_int32 /www set fff (0). eq { /ddd -intInfinity def /ord_w.LLL goto} { } ifelse fff (ring) dc /rrr set fff init /fff set /ddd 0 def 0 2 www length 1 sub { /iii set - fff << www iii get rrr ,, >> degree + fff << www iii get rrr __ >> degree << www iii 1 add get >> mul ddd add /ddd set } for @@ -2487,6 +2560,47 @@ 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 + www to_int32 /www set + 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) @@ -2518,22 +2632,22 @@ newline /v0 vv ii get (string) dc def v0 (array) dc 0 get Dascii eq %% If the first character is D? { rule %% Dx-->x - [v0 rr ,, - v0 (array) dc rest { (string) dc} map aload length cat_n rr ,,] + [v0 rr __ + v0 (array) dc rest { (string) dc} map aload length cat_n rr __] append /rule set } { rule %% x --> -Dx - [v0 rr ,, + [v0 rr __ (0). [Dascii] v0 (array) dc join { (string) dc } map aload length - cat_n rr ,, sub + cat_n rr __ sub ] append /rule set } ifelse } ifelse } for % rule message - ff rule replace [[(h) rr ,, (1) rr ,,]] replace /ans1 set + ff rule replace [[(h) rr __ (1) rr __]] replace /ans1 set } ifelse } { @@ -2675,6 +2789,7 @@ newline [/in-ngcd /nlist /g.ngcd /ans] pushVariables [ /nlist arg1 def + nlist to_univNum /nlist set nlist length 2 lt { /ans nlist 0 get def /L.ngcd goto } { @@ -2890,9 +3005,9 @@ newline { /xx xx (string) dc def /dxx [@@@.Dsymbol xx] cat def - /xx xx f (ring) dc ,, def - /dxx dxx f (ring) dc ,, def - /one (1) f (ring) dc ,, def + /xx xx f (ring) dc __ def + /dxx dxx f (ring) dc __ def + /one (1) f (ring) dc __ def { /g f init def @@ -2969,9 +3084,9 @@ newline f (0). eq { } { /rr f (ring) dc def - xx {toString rr ,, } map /xx set - dx {toString rr ,, } map /dx set - ss {toString rr ,, } map /ss set + xx {toString rr __ } map /xx set + dx {toString rr __ } map /dx set + ss {toString rr __ } map /ss set /n xx length def 0 1 n 1 sub { /i set @@ -3001,7 +3116,7 @@ newline [ /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def f (ring) dc /rr set - /one (1) rr ,, def %% + /one (1) rr __ def %% /ww [ xx toString -1 dx toString 1 ] weightv def f ww init f sub (0). eq { } { [(destraction2.1 : inhomogeneous with respect to ) @@ -3027,6 +3142,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 +3350,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 @@ -3488,6 +3651,738 @@ $ [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 + +/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 { + [/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 + +/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 + ;