=================================================================== RCS file: /home/cvs/OpenXM/src/kan96xx/Kan/dr.sm1,v retrieving revision 1.32 retrieving revision 1.56 diff -u -p -r1.32 -r1.56 --- OpenXM/src/kan96xx/Kan/dr.sm1 2004/08/31 04:45:42 1.32 +++ OpenXM/src/kan96xx/Kan/dr.sm1 2013/09/22 01:26:07 1.56 @@ -1,9 +1,9 @@ -% $OpenXM: OpenXM/src/kan96xx/Kan/dr.sm1,v 1.31 2004/08/27 08:33:27 takayama Exp $ +% $OpenXM: OpenXM/src/kan96xx/Kan/dr.sm1,v 1.55 2013/09/22 01:06:20 takayama Exp $ %% dr.sm1 (Define Ring) 1994/9/25, 26 %% This file is error clean. @@@.quiet { } -{ (macro package : dr.sm1, 9/26,1995 --- Version 12/10, 2000. ) message } ifelse +{ (macro package : dr.sm1, 9/26,1995 --- Version 09/22, 2013. ) message } ifelse /ctrlC-hook { %%% define your own routing in case of error. @@ -342,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 @@ -361,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 } @@ -374,6 +378,8 @@ ans [ j i ] << mat i get j get >> put } for } for + exit + } loop /arg1 ans def ] pop popVariables @@ -787,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 { @@ -839,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. << __ >>, getRing) ] ] putUsages @@ -1328,7 +1334,7 @@ /univ vars 0 get reverse vars 1 get reverse join def - w-vectors to_int /w-vectors set + w-vectors to_int32 /w-vectors set [ 0 1 << w-vectors length 1 sub >> { @@ -1352,7 +1358,7 @@ [/univ /www /k /vname /vweight /ans] pushVariables /univ arg1 def /www arg2 def [ - www to_int /www set + www to_int32 /www set /ans << univ length >> -1 0 evecw def 0 2 << www length 2 sub >> { @@ -1407,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 @@ -1522,6 +1528,13 @@ (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 @@ -1551,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 @@ -1665,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 @@ -1682,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 @@ -1703,7 +1720,7 @@ /arg1 arg1 expand def [(CurrentRingp) rrr] system_variable } - {(Argument Error for ,, ) error } + {(Argument Error for __ ) error } ifelse ] pop popVariables @@ -1714,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.) @@ -1925,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) @@ -1949,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 { @@ -2258,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 @@ -2284,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 @@ -2370,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 @@ -2389,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 @@ -2465,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 @@ -2524,14 +2542,14 @@ newline [ /fff arg1 def /www arg2 def - www to_int /www set + 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 @@ -2556,18 +2574,18 @@ newline [ /fff arg1 def /www arg2 def - www to_int /www set + 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 + /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 + fff-in << www iii get rrr __ >> degree << www iii 1 add get >> mul ddd-tmp add /ddd-tmp set } for @@ -2614,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 } { @@ -2987,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 @@ -3066,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 @@ -3098,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 ) @@ -3445,11 +3463,12 @@ newline } def [(getRing) [(obj getRing rr) - (ring rr;) + (ring rr; ) (getRing obtains the ring structure from obj.) (If obj is a polynomial, it returns the ring structure associated to) (the polynomial.) (If obj is an array, it recursively looks for the ring structure.) + (cf. ring_def) ]] putUsages /toVectors { /arg1 set @@ -3661,6 +3680,34 @@ $ [ff ff] fromVectors :: $ ( 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. @@ -3842,16 +3889,16 @@ $ [ff ff] fromVectors :: $ [(>) (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 { ___ } map /arg1 set } { ff toString . /arg1 set } ifelse @@ -3881,7 +3928,7 @@ $ [ff ff] fromVectors :: $ [(to_univNum) [(obj to_univNum obj2) (Example. [ 2 (3).. ] to_univNum) - (cf. to_int) + $cf. to_int32. (to_int)$ ]] putUsages [(lcm) @@ -4119,15 +4166,29 @@ $ [ff ff] fromVectors :: $ /getNode { /arg2 set /arg1 set - [/in-getNode /ob /key /rr /rr /ii] pushVariables + [/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 - } { exit } ifelse + } { } ifelse + ob isClass , ob isArray or { } { exit } ifelse ob 0 get key eq { /rr ob def exit @@ -4146,28 +4207,111 @@ $ [ff ff] fromVectors :: $ arg1 } def [(getNode) -[(ob key getNode) - (ob is a class object.) +[(ob key getNode node-value) + (ob is a class object or an array.) (The operator getNode returns the node with the key in ob.) - (The node is an array of the format [key attr-list node-list]) + (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] pushVariables + [/name /flag /n /k /slist /m /i /sss /key /ukeys] pushVariables [ /name arg1 def /flag true def + { % begin loop - %BUG: should use regular expression in a future. + 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 @@ -4194,7 +4338,10 @@ $ [ff ff] fromVectors :: $ {name Usage /sss [(Usage of ) name ( could not obtained.) nl ] def} { } ifelse + exit } ifelse + +} loop /arg1 sss cat def ] pop popVariables @@ -4203,7 +4350,238 @@ $ [ff ff] fromVectors :: $ [(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 + +/toTokensBySpace { + /arg1 set + [(cgiToTokens) arg1 [ ]] extension +} def +[(toTokensBySpace) +[ + ( string toTokensBySpace token_array ) +]] putUsages + +/setAttributeList { + /arg2 set + /arg1 set + [ + [(setAttributeList) arg1 arg2] extension /arg1 set + ] pop + arg1 +} def +/getAttributeList { + /arg1 set + [(getAttributeList) arg1] extension +} def +/setAttribute { + /arg3 set + /arg2 set + /arg1 set + [ + [(setAttribute) arg1 arg2 arg3] extension /arg1 set + ] pop + arg1 +} def +/getAttribute { + /arg2 set + /arg1 set + [(getAttribute) arg1 arg2] extension +} def +[(setAttributeList) +[ + (ob attr setAttributeList new-obj ) + (Example: [(x-1) (y-1)] [(gb) 1] setAttributeList /ff set ) +]] putUsages +[(setAttribute) +[ + (ob key value setAttribute new-obj ) + (Example: [(x-1) (y-1)] (gb) 1 setAttribute /ff set ) +]] putUsages +[(getAttributeList) +[ + (ob getAttributeList attr-obj ) + (Example: [(x-1) (y-1)] [(gb) 1] setAttributeList /ff set ) + ( ff getAttributeList :: ) +]] putUsages +[(getAttribute) +[ + (ob key getAttribute value ) + (Example: [(x-1) (y-1)] (gb) 1 setAttribute /ff set ) + ( ff (gb) getAttribute :: ) +]] putUsages + +% [(gbCheck) 1 (needSyz) 1 (countDown) 100] (attribute format) +% --> [(gbCheck) (needSyz) (countDown) 100] (groebner option format) +% cf. gb +/configureGroebnerOption { + /arg1 set + [/opt /i] pushVariables + [ + /opt arg1 def + opt tag 0 eq { + /arg1 null def + } { + [ + 0 2 opt length 1 sub { + /i set + opt i get + opt i get (countDown) eq { + opt i 1 add get + } { } ifelse + opt i get (stopDegree) eq { + opt i 1 add get + } { } ifelse + } for + ] /arg1 set + } ifelse + ] pop + popVariables + arg1 +} def + +[(getFileType) +[ + (string getFileType type) + $Example: (/www/prog/cohom.sm1) getFileType ==> (sm1)$ +]] putUsages +/getFileType { + /arg1 set + [/ss ] pushVariables + [ /ss arg1 def + [(stringToArgv2) ss (.)] extension /ss set + ss, ss length 1 sub, get /arg1 set + ] pop + popVariables + arg1 +} def + +% Default initial value. +/localizedString.file null def +/localizedString.dic [ ] def +/localizedString.local { } def + +% Clear and load +/localizedString.load { + /localizedString.dic [ ] def + /localizedString.local { } def + localizedString.file tag 0 eq { } + { [(parse) localizedString.file pushfile] extension pop } ifelse +} def + + +[(localizedString) + [ + (string localizedString translatedString) + (It returns localizedString if localizedString.dic [array] and) + (localizedString.local [function] are set.) + ] +] putUsages +/localizedString { + /arg1 set + [/ss /ans /tt] pushVariables + [ + arg1 /ss set + /ans ss def + { + localizedString.dic length 0 eq { exit } { } ifelse + localizedString.dic ss getNode /tt set + tt tag 0 eq { } { tt /ans set exit } ifelse + ss localizedString.local /ans set + exit + } loop + ans /arg1 set + ] pop + popVariables + arg1 +} def + +[(univ2poly) +[(list univ2poly list2) + (Change universal numbers in list to an element of a ring of polynomials) + (defined by other elements in list. If there is no polynomial element,) + (the current ring is used.) +]] putUsages +/univ2poly { + /arg1 set + [/aa /rg /ag /ans] pushVariables + [ + arg1 /aa set + [(CurrentRingp)] system_variable /rg set + aa getRing /ag set + ag tag 0 { } { + ag ring_def + } ifelse + aa univ2poly.aux /ans set + rg ring_def + ans /arg1 set + ] pop + popVariables + arg1 +} def + +/univ2poly.aux { + /arg1 set + [/aa /ans] pushVariables + [ + arg1 /aa set + aa getRing + aa tag 6 eq { + aa { univ2poly.aux} map /ans set + }{ + aa tag 15 eq, aa tag 1 eq, or { aa toString . /ans set } { + aa /ans set + } ifelse + } ifelse + ans /arg1 set + ] pop + popVariables + arg1 +} def + +/sm1log { + /arg1 set + [/ss /fd ] pushVariables + [ + arg1 /ss set + (/tmp/sm1log.txt) (a) file /fd set + fd , [[(date)] extension + ss (string) dc] cat , writestring + fd closefile + ] pop + popVariables +} def ;