From 9624e08dd80d9f83f6c82104fe5dcbb8f01f6dc9 Mon Sep 17 00:00:00 2001 From: Tim Daly Date: Sat, 15 Aug 2015 15:28:36 -0400 Subject: [PATCH] books/bookvol10.* extract code for COQ proof system Goal: Proving Axiom Correct Collect all of the functions in the categories, domains, and packages into obj/sys/proofs/coq.v --- books/bookvol10.2.pamphlet | 2 + books/bookvol10.3.pamphlet |78754 ++++++++++++++++++++++++++++++---------- books/bookvol10.4.pamphlet |59172 ++++++++++++++++++++++++++++-- books/bookvolbib.pamphlet | 15 + changelog | 5 + patch | 7 +- src/axiom-website/patches.html | 2 + 7 files changed, 116794 insertions(+), 21163 deletions(-) diff --git a/books/bookvol10.2.pamphlet b/books/bookvol10.2.pamphlet index a8f2a63..9dc0c81 100644 --- a/books/bookvol10.2.pamphlet +++ b/books/bookvol10.2.pamphlet @@ -5192,6 +5192,8 @@ Aggregate: Category == Type with *) +\end{chunk} + \begin{chunk}{AGG.dotabb} "AGG" [color=lightblue,href="bookvol10.2.pdf#nameddest=AGG"]; "AGG" -> "TYPE" diff --git a/books/bookvol10.3.pamphlet b/books/bookvol10.3.pamphlet index 661d0b4..0de9b22 100644 --- a/books/bookvol10.3.pamphlet +++ b/books/bookvol10.3.pamphlet @@ -19659,7 +19659,8 @@ AttributeButtons(): E == I where setAttributeButtonStep(n:F):F == positive?(n)$F and (n<1$F) => attributeStep:F := n - error("setAttributeButtonStep","New value must be in (0..1)")$ErrorFunctions + error("setAttributeButtonStep",_ + "New value must be in (0..1)")$ErrorFunctions resetAttributeButtons():Void == attributeButtons := buttons() @@ -19670,7 +19671,8 @@ AttributeButtons(): E == I where f case Float => n>=0$F and n<=1$F => setelt(attributeButtons,routineName attributeName,n)$Rep - error("setAttributeButtonStep","New value must be in [0..1]")$ErrorFunctions + error("setAttributeButtonStep",_ + "New value must be in [0..1]")$ErrorFunctions error("setButtonValue","attribute name " attributeName " not found for routine " routineName)$ErrorFunctions @@ -19741,6 +19743,114 @@ AttributeButtons(): E == I where \begin{chunk}{COQ ATTRBUT} (* domain ATTRBUT *) (* + + Rep := StringTable(F) + import Rep + + buttons:() -> $ + buttons():$ == + eList := empty()$List(Record(key:ST,entry:F)) + l1:List String := ["stability","stiffness","accuracy","expense"] + l2:List String := ["functionEvaluations"] + ro1 := selectODEIVPRoutines(r := routines()$RoutinesTable)$RoutinesTable + ro2 := selectIntegrationRoutines(r)$RoutinesTable + k1:List String := [string(i)$Symbol for i in keys(ro1)$RoutinesTable] + k2:List String := [string(i)$Symbol for i in keys(ro2)$RoutinesTable] + for i in k1 repeat + for j in l1 repeat + e:Record(key:ST,entry:F) := [i j,0.5] + eList := cons(e,eList)$List(Record(key:ST,entry:F)) + for i in k2 repeat + for j in l2 repeat + e:Record(key:ST,entry:F) := [i j,0.5] + eList := cons(e,eList)$List(Record(key:ST,entry:F)) + construct(eList)$Rep + + attributeButtons:$ := buttons() + + attributeStep:F := 0.5 + + setAttributeButtonStep(n:F):F == + positive?(n)$F and (n<1$F) => attributeStep:F := n + error("setAttributeButtonStep",_ + "New value must be in (0..1)")$ErrorFunctions + + resetAttributeButtons():Void == + attributeButtons := buttons() + void()$Void + + setButtonValue(routineName:ST,attributeName:ST,n:F):F == + f := search(routineName attributeName,attributeButtons)$Rep + f case Float => + n>=0$F and n<=1$F => + setelt(attributeButtons,routineName attributeName,n)$Rep + error("setAttributeButtonStep",_ + "New value must be in [0..1]")$ErrorFunctions + error("setButtonValue","attribute name " attributeName + " not found for routine " routineName)$ErrorFunctions + + setButtonValue(attributeName:ST,n:F):F == + ro1 := selectODEIVPRoutines(r := routines()$RoutinesTable)$RoutinesTable + ro2 := selectIntegrationRoutines(r)$RoutinesTable + l1:List String := ["stability","stiffness","accuracy","expense"] + l2:List String := ["functionEvaluations"] + if attributeName="functionEvaluations" then + for i in keys(ro2)$RoutinesTable repeat + setButtonValue(string(i)$Symbol,attributeName,n) + else + for i in keys(ro1)$RoutinesTable repeat + setButtonValue(string(i)$Symbol,attributeName,n) + n + + increase(routineName:ST,attributeName:ST):F == + f := search(routineName attributeName,attributeButtons)$Rep + f case Float => + newValue:F := (1$F-attributeStep)*f+attributeStep + setButtonValue(routineName,attributeName,newValue) + error("increase","attribute name " attributeName + " not found for routine " routineName)$ErrorFunctions + + increase(attributeName:ST):F == + ro1 := selectODEIVPRoutines(r := routines()$RoutinesTable)$RoutinesTable + ro2 := selectIntegrationRoutines(r)$RoutinesTable + l1:List String := ["stability","stiffness","accuracy","expense"] + l2:List String := ["functionEvaluations"] + if attributeName="functionEvaluations" then + for i in keys(ro2)$RoutinesTable repeat + increase(string(i)$Symbol,attributeName) + else + for i in keys(ro1)$RoutinesTable repeat + increase(string(i)$Symbol,attributeName) + getButtonValue(string(i)$Symbol,attributeName) + + decrease(routineName:ST,attributeName:ST):F == + f := search(routineName attributeName,attributeButtons)$Rep + f case Float => + newValue:F := (1$F-attributeStep)*f + setButtonValue(routineName,attributeName,newValue) + error("increase","attribute name " attributeName + " not found for routine " routineName)$ErrorFunctions + + decrease(attributeName:ST):F == + ro1 := selectODEIVPRoutines(r := routines()$RoutinesTable)$RoutinesTable + ro2 := selectIntegrationRoutines(r)$RoutinesTable + l1:List String := ["stability","stiffness","accuracy","expense"] + l2:List String := ["functionEvaluations"] + if attributeName="functionEvaluations" then + for i in keys(ro2)$RoutinesTable repeat + decrease(string(i)$Symbol,attributeName) + else + for i in keys(ro1)$RoutinesTable repeat + decrease(string(i)$Symbol,attributeName) + getButtonValue(string(i)$Symbol,attributeName) + + + getButtonValue(routineName:ST,attributeName:ST):F == + f := search(routineName attributeName,attributeButtons)$Rep + f case Float => f + error("getButtonValue","attribute name " attributeName + " not found for routine " routineName)$ErrorFunctions + *) \end{chunk} @@ -19852,6 +19962,7 @@ Automorphism(R:Ring): Join(Group, Eltable(R, R)) with morphism: ((R, Integer) -> R) -> % ++ morphism(f) returns the morphism given by \spad{f^n(x) = f(x,n)}. == add + err: R -> R ident: (R, Integer) -> R iter: (R -> R, NonNegativeInteger, R) -> R @@ -19861,16 +19972,27 @@ Automorphism(R:Ring): Join(Group, Eltable(R, R)) with Rep := ((R, Integer) -> R) 1 == ident + err r == error "Morphism is not invertible" + ident(r, n) == r + f = g == EQ(f, g)$Lisp + elt(f, r) == apply(f, r, 1) + inv f == (r1:R, i2:Integer):R +-> apply(f, r1, - i2) + f ** n == (r1:R, i2:Integer):R +-> apply(f, r1, n * i2) + coerce(f:%):OutputForm == message("R -> R") + morphism(f:(R, Integer) -> R):% == f + morphism(f:R -> R):% == morphism(f, err) + morphism(f, g) == (r1:R, i2:Integer):R +-> iterat(f, g, i2, r1) + apply(f, r, n) == (g := f pretend ((R, Integer) -> R); g(r, n)) iterat(f, g, n, r) == @@ -19893,6 +20015,54 @@ Automorphism(R:Ring): Join(Group, Eltable(R, R)) with \begin{chunk}{COQ AUTOMOR} (* domain AUTOMOR *) (* + + + Rep := ((R, Integer) -> R) + + 1 == ident + + err: R -> R + err r == error "Morphism is not invertible" + + ident: (R, Integer) -> R + ident(r, n) == r + + f = g == EQ(f, g)$Lisp + + elt(f, r) == apply(f, r, 1) + + inv f == (r1:R, i2:Integer):R +-> apply(f, r1, - i2) + + f ** n == (r1:R, i2:Integer):R +-> apply(f, r1, n * i2) + + coerce(f:%):OutputForm == message("R -> R") + + morphism(f:(R, Integer) -> R):% == f + + morphism(f:R -> R):% == morphism(f, err) + + morphism(f, g) == (r1:R, i2:Integer):R +-> iterat(f, g, i2, r1) + + apply: (%, R, Integer) -> R + apply(f, r, n) == (g := f pretend ((R, Integer) -> R); g(r, n)) + + iterat: (R -> R, R -> R, Integer, R) -> R + iterat(f, g, n, r) == + n < 0 => iter(g, (-n)::NonNegativeInteger, r) + iter(f, n::NonNegativeInteger, r) + + iter: (R -> R, NonNegativeInteger, R) -> R + iter(f, n, r) == + for i in 1..n repeat r := f r + r + + f * g == + f = g => f**2 + (r1:R, i2:Integer):R +-> + iterat((u1:R):R +-> f g u1, + (v1:R):R +-> (inv g)(inv f) v1, + i2, r1) + *) \end{chunk} @@ -20295,14 +20465,13 @@ BalancedBinaryTree(S: SetCategory): Exports == Implementation where ++X t2 Implementation == BinaryTree(S) add + Rep := BinaryTree(S) + leaf? x == empty? x => false empty? left x and empty? right x --- balancedBinaryTree(x: S, u: List S) == --- n := #u --- n = 0 => empty() --- setleaves_!(balancedBinaryTree(n, x), u) + setleaves_!(t, u) == n := #u n = 0 => @@ -20319,16 +20488,19 @@ BalancedBinaryTree(S: SetCategory): Exports == Implementation where setleaves_!(left t, reverse_! acc) setleaves_!(right t, u) t + balancedBinaryTree(n: NonNegativeInteger, val: S) == n = 0 => empty() n = 1 => node(empty(),val,empty()) m := n quo 2 node(balancedBinaryTree(m, val), val, balancedBinaryTree((n - m) pretend NonNegativeInteger, val)) + mapUp_!(x,fn) == empty? x => error "mapUp! called on a null tree" leaf? x => x.value x.value := fn(mapUp_!(x.left,fn),mapUp_!(x.right,fn)) + mapUp_!(x,y,fn) == empty? x => error "mapUp! is called on a null tree" leaf? x => @@ -20339,12 +20511,14 @@ BalancedBinaryTree(S: SetCategory): Exports == Implementation where mapUp_!(x.right,y.right,fn) x.value := fn(x.left.value,x.right.value,y.left.value,y.right.value) x + mapDown_!(x: %, p: S, fn: (S,S) -> S ) == empty? x => x x.value := fn(p, x.value) mapDown_!(x.left, x.value, fn) mapDown_!(x.right, x.value, fn) x + mapDown_!(x: %, p: S, fn: (S,S,S) -> List S) == empty? x => x x.value := p @@ -20359,6 +20533,70 @@ BalancedBinaryTree(S: SetCategory): Exports == Implementation where \begin{chunk}{COQ BBTREE} (* domain BBTREE *) (* + BinaryTree(S) add + + Rep := BinaryTree(S) + + leaf? x == + empty? x => false + empty? left x and empty? right x + + setleaves_!(t, u) == + n := #u + n = 0 => + empty? t => t + error "the tree and list must have the same number of elements" + n = 1 => + setvalue_!(t,first u) + t + m := n quo 2 + acc := empty()$(List S) + for i in 1..m repeat + acc := [first u,:acc] + u := rest u + setleaves_!(left t, reverse_! acc) + setleaves_!(right t, u) + t + + balancedBinaryTree(n: NonNegativeInteger, val: S) == + n = 0 => empty() + n = 1 => node(empty(),val,empty()) + m := n quo 2 + node(balancedBinaryTree(m, val), val, + balancedBinaryTree((n - m) pretend NonNegativeInteger, val)) + + mapUp_!(x,fn) == + empty? x => error "mapUp! called on a null tree" + leaf? x => x.value + x.value := fn(mapUp_!(x.left,fn),mapUp_!(x.right,fn)) + + mapUp_!(x,y,fn) == + empty? x => error "mapUp! is called on a null tree" + leaf? x => + leaf? y => x + error "balanced binary trees are incompatible" + leaf? y => error "balanced binary trees are incompatible" + mapUp_!(x.left,y.left,fn) + mapUp_!(x.right,y.right,fn) + x.value := fn(x.left.value,x.right.value,y.left.value,y.right.value) + x + + mapDown_!(x: %, p: S, fn: (S,S) -> S ) == + empty? x => x + x.value := fn(p, x.value) + mapDown_!(x.left, x.value, fn) + mapDown_!(x.right, x.value, fn) + x + + mapDown_!(x: %, p: S, fn: (S,S,S) -> List S) == + empty? x => x + x.value := p + leaf? x => x + u := fn(x.left.value, x.right.value, p) + mapDown_!(x.left, u.1, fn) + mapDown_!(x.right, u.2, fn) + x + *) \end{chunk} @@ -20930,6 +21168,47 @@ BasicFunctions(): E == I where \begin{chunk}{COQ BFUNCT} (* domain BFUNCT *) (* + + Rep := Table(Symbol,RS) + import Rep, SDF + + f(x:DF):DF == + positive?(x) => -x + -x+1 + + bf():$ == + import RS + dpi := pi()$DF + ndpi:SDF := map(x1+->x1*dpi,(z := generate(f,0))) -- [n pi for n in Z] + n1dpi:SDF := map(x1+->-(2*(x1)-1)*dpi/2,z) -- [(n+1) pi /2] + n2dpi:SDF := map(x1+->2*x1*dpi,z) -- [2 n pi for n in Z] + n3dpi:SDF := map(x1+->-(4*(x1)-1)*dpi/4,z) + n4dpi:SDF := map(x1+->-(4*(x1)-1)*dpi/2,z) + sinEntry:RS := [ndpi, n4dpi, empty()$SDF] + cosEntry:RS := [n1dpi, n2dpi, esdf := empty()$SDF] + tanEntry:RS := [ndpi, n3dpi, n1dpi] + asinEntry:RS := [construct([0$DF])$SDF, + construct([float(8414709848078965,-16,10)$DF]), esdf] + acosEntry:RS := [construct([1$DF])$SDF, + construct([float(54030230586813977,-17,10)$DF]), esdf] + atanEntry:RS := [construct([0$DF])$SDF, + construct([float(15574077246549023,-16,10)$DF]), esdf] + secEntry:RS := [esdf, n2dpi, n1dpi] + cscEntry:RS := [esdf, n4dpi, ndpi] + cotEntry:RS := [n1dpi, n3dpi, ndpi] + logEntry:RS := [construct([1$DF])$SDF,esdf, construct([0$DF])$SDF] + entryList:List(Record(key:Symbol,entry:RS)) := + [[sin@Symbol, sinEntry], [cos@Symbol, cosEntry], + [tan@Symbol, tanEntry], [sec@Symbol, secEntry], + [csc@Symbol, cscEntry], [cot@Symbol, cotEntry], + [asin@Symbol, asinEntry], [acos@Symbol, acosEntry], + [atan@Symbol, atanEntry], [log@Symbol, logEntry]] + construct(entryList)$Rep + + bfKeys():List Symbol == keys(bf())$Rep + + bfEntry(k:Symbol):RS == qelt(bf(),k)$Rep + *) \end{chunk} @@ -21432,27 +21711,47 @@ BasicOperator(): Exports == Implementation where oper: (Symbol, SingleInteger, P) -> $ is?(op, s) == name(op) = s + name op == op.opname + properties op == op.props + setProperties(op, l) == (op.props := l; op) + operator s == oper(s, -1::SingleInteger, table()) + operator(s, n) == oper(s, n::Integer::SingleInteger, table()) + property(op, name) == search(name, op.props) + assert(op, s) == setProperty(op, s, NIL$Lisp) + has?(op, name) == key?(name, op.props) + oper(se, n, prop) == [se, n, prop] + weight(op, n) == setProperty(op, WEIGHT, n pretend None) + nullary? op == zero?(op.narg) --- unary? op == one?(op.narg) + unary? op == ((op.narg) = 1) + nary? op == negative?(op.narg) + equality(op, func) == setProperty(op, EQUAL?, func pretend None) + comparison(op, func) == setProperty(op, LESS?, func pretend None) + display(op:$, f:O -> O) == display(op,(x1:List(O)):O +-> f first x1) + deleteProperty_!(op, name) == (remove_!(name, properties op); op) + setProperty(op, name, valu) == (op.props.name := valu; op) + coerce(op:$):OutputForm == name(op)::OutputForm + input(op:$, f:List SEX -> SEX) == setProperty(op, SEXPR, f pretend None) + display(op:$, f:List O -> O) == setProperty(op, DISPLAY, f pretend None) display op == @@ -21512,6 +21811,107 @@ BasicOperator(): Exports == Implementation where \begin{chunk}{COQ BOP} (* domain BOP *) (* + -- if narg < 0 then the operator has variable arity. + Rep := Record(opname:Symbol, narg:SingleInteger, props:P) + + oper: (Symbol, SingleInteger, P) -> $ + + is?(op, s) == name(op) = s + + name op == op.opname + + properties op == op.props + + setProperties(op, l) == (op.props := l; op) + + operator s == oper(s, -1::SingleInteger, table()) + + operator(s, n) == oper(s, n::Integer::SingleInteger, table()) + + property(op, name) == search(name, op.props) + + assert(op, s) == setProperty(op, s, NIL$Lisp) + + has?(op, name) == key?(name, op.props) + + oper(se, n, prop) == [se, n, prop] + + weight(op, n) == setProperty(op, WEIGHT, n pretend None) + + nullary? op == zero?(op.narg) + + unary? op == ((op.narg) = 1) + + nary? op == negative?(op.narg) + + equality(op, func) == setProperty(op, EQUAL?, func pretend None) + + comparison(op, func) == setProperty(op, LESS?, func pretend None) + + display(op:$, f:O -> O) == display(op,(x1:List(O)):O +-> f first x1) + + deleteProperty_!(op, name) == (remove_!(name, properties op); op) + + setProperty(op, name, valu) == (op.props.name := valu; op) + + coerce(op:$):OutputForm == name(op)::OutputForm + + input(op:$, f:List SEX -> SEX) == setProperty(op, SEXPR, f pretend None) + + display(op:$, f:List O -> O) == setProperty(op, DISPLAY, f pretend None) + + display op == + (u := property(op, DISPLAY)) case "failed" => "failed" + (u::None) pretend (List O -> O) + + input op == + (u := property(op, SEXPR)) case "failed" => "failed" + (u::None) pretend (List SEX -> SEX) + + arity op == + negative?(n := op.narg) => "failed" + convert(n)@Integer :: NonNegativeInteger + + copy op == + oper(name op, op.narg, + table([[r.key, r.entry] for r in entries(properties op)@L]$L)) + +-- property EQUAL? contains a function f: (BOP, BOP) -> Boolean +-- such that f(o1, o2) is true iff o1 = o2 + op1 = op2 == + (EQ$Lisp)(op1, op2) => true + name(op1) ^= name(op2) => false + op1.narg ^= op2.narg => false + brace(keys properties op1)^=$Set(String) _ + brace(keys properties op2) => false + (func := property(op1, EQUAL?)) case None => + ((func::None) pretend (($, $) -> Boolean)) (op1, op2) + true + +-- property WEIGHT allows one to change the ordering around +-- by default, every operator has weigth 1 + weight op == + (w := property(op, WEIGHT)) case "failed" => 1 + (w::None) pretend NonNegativeInteger + +-- property LESS? contains a function f: (BOP, BOP) -> Boolean +-- such that f(o1, o2) is true iff o1 < o2 + op1 < op2 == + (w1 := weight op1) ^= (w2 := weight op2) => w1 < w2 + op1.narg ^= op2.narg => op1.narg < op2.narg + name(op1) ^= name(op2) => name(op1) < name(op2) + n1 := #(k1 := brace(keys(properties op1))$Set(String)) + n2 := #(k2 := brace(keys(properties op2))$Set(String)) + n1 ^= n2 => n1 < n2 + not zero?(n1 := #(d1 := difference(k1, k2))) => + n1 ^= (n2 := #(d2 := difference(k2, k1))) => n1 < n2 + inspect(d1) < inspect(d2) + (func := property(op1, LESS?)) case None => + ((func::None) pretend (($, $) -> Boolean)) (op1, op2) + (func := property(op1, EQUAL?)) case None => + not(((func::None) pretend (($, $) -> Boolean)) (op1, op2)) + false + *) \end{chunk} @@ -22030,7 +22430,9 @@ BasicStochasticDifferential(): category == implementation where tableIto(X) copyBSD() == [ds::% for ds in members(setBSD)] + copyIto() == tableIto + getSmgl(ds:%):Union(Symbol,"failed") == tableBSD(ds) \end{chunk} @@ -22038,6 +22440,41 @@ BasicStochasticDifferential(): category == implementation where \begin{chunk}{COQ BSD} (* domain BSD *) (* + + Rep := Symbol + + setBSD := empty()$Set(Symbol) + tableIto:Table(Symbol,%) := table() + tableBSD:Table(%,Symbol) := table() + + convertIfCan(ds:Symbol):Union(%,"failed") == + not(member?(ds,setBSD)) => "failed" + ds::% + + convert(ds:Symbol):% == + (du:=convertIfCan(ds)) + case "failed" => + print(hconcat(ds::Symbol::OF, + message(" is not a stochastic differential")$OF)) + error "above causes failure in convert$BSD" + du + + introduce!(X,dX) == + member?(dX,setBSD) => "failed" + insert!(dX,setBSD) + tableBSD(dX::%) := X + tableIto(X) := dX::% + + d(X) == + search(X,tableIto) case "failed" => 0::INT + tableIto(X) + + copyBSD() == [ds::% for ds in members(setBSD)] + + copyIto() == tableIto + + getSmgl(ds:%):Union(Symbol,"failed") == tableBSD(ds) + *) \end{chunk} @@ -22440,7 +22877,7 @@ BinaryExpansion(): Exports == Implementation where coerce: % -> Fraction Integer ++ coerce(b) converts a binary expansion to a rational number. coerce: % -> RadixExpansion(2) - ++ coerce(b) converts a binary expansion to a radix expansion with base 2. + ++ coerce(b) converts a binary expansion to a radix expansion with base 2 fractionPart: % -> Fraction Integer ++ fractionPart(b) returns the fractional part of a binary expansion. binary: Fraction Integer -> % @@ -22457,6 +22894,12 @@ BinaryExpansion(): Exports == Implementation where \begin{chunk}{COQ BINARY} (* domain BINARY *) (* + RadixExpansion(2) add + + binary r == r :: % + + coerce(x:%): RadixExpansion(2) == x pretend RadixExpansion(2) + *) \end{chunk} @@ -22575,22 +23018,13 @@ BinaryFile: Cat == Def where fileState: FileState, _ fileIOmode: String) --- direc : Symbol := INTERN("DIRECTION","KEYWORD")$Lisp --- input : Symbol := INTERN("INPUT","KEYWORD")$Lisp --- output : Symbol := INTERN("OUTPUT","KEYWORD")$Lisp --- eltype : Symbol := INTERN("ELEMENT-TYPE","KEYWORD")$Lisp --- bytesize : SExpression := LIST(QUOTE(UNSIGNED$Lisp)$Lisp,8)$Lisp - - defstream(fn: FileName, mode: String): FileState == mode = "input" => not readable? fn => error ["File is not readable", fn] BINARY__OPEN__INPUT(fn::String)$Lisp --- OPEN(fn::String, direc, input, eltype, bytesize)$Lisp mode = "output" => not writable? fn => error ["File is not writable", fn] BINARY__OPEN__OUTPUT(fn::String)$Lisp --- OPEN(fn::String, direc, output, eltype, bytesize)$Lisp error ["IO mode must be input or output", mode] open(fname, mode) == @@ -22616,26 +23050,24 @@ BinaryFile: Cat == Def where f.fileIOmode ^= "input" => error "File not in read state" BINARY__SELECT__INPUT(f.fileState)$Lisp BINARY__READBYTE()$Lisp --- READ_-BYTE(f.fileState)$Lisp + readIfCan_! f == f.fileIOmode ^= "input" => error "File not in read state" BINARY__SELECT__INPUT(f.fileState)$Lisp n:SingleInteger:=BINARY__READBYTE()$Lisp n = -1 => "failed" n::Union(SingleInteger,"failed") --- READ_-BYTE(f.fileState,NIL$Lisp, --- "failed"::Union(SingleInteger,"failed"))$Lisp + write_!(f, x) == f.fileIOmode ^= "output" => error "File not in write state" x < 0 or x>255 => error "integer cannot be represented as a byte" BINARY__PRINBYTE(x)$Lisp --- WRITE_-BYTE(x, f.fileState)$Lisp x --- # f == FILE_-LENGTH(f.fileState)$Lisp position f == f.fileIOmode ^= "input" => error "file must be in read state" FILE_-POSITION(f.fileState)$Lisp + position_!(f,i) == f.fileIOmode ^= "input" => error "file must be in read state" (FILE_-POSITION(f.fileState,i)$Lisp ; i) @@ -22645,6 +23077,68 @@ BinaryFile: Cat == Def where \begin{chunk}{COQ BINFILE} (* domain BINFILE *) (* + File(SingleInteger) add + + FileState ==> SExpression + + Rep := Record(fileName: FileName, _ + fileState: FileState, _ + fileIOmode: String) + + defstream(fn: FileName, mode: String): FileState == + mode = "input" => + not readable? fn => error ["File is not readable", fn] + BINARY__OPEN__INPUT(fn::String)$Lisp + mode = "output" => + not writable? fn => error ["File is not writable", fn] + BINARY__OPEN__OUTPUT(fn::String)$Lisp + error ["IO mode must be input or output", mode] + + open(fname, mode) == + fstream := defstream(fname, mode) + [fname, fstream, mode] + + reopen_!(f, mode) == + fname := f.fileName + f.fileState := defstream(fname, mode) + f.fileIOmode:= mode + f + + close_! f == + f.fileIOmode = "output" => + BINARY__CLOSE__OUTPUT()$Lisp + f + f.fileIOmode = "input" => + BINARY__CLOSE__INPUT()$Lisp + f + error "file must be in read or write state" + + read! f == + f.fileIOmode ^= "input" => error "File not in read state" + BINARY__SELECT__INPUT(f.fileState)$Lisp + BINARY__READBYTE()$Lisp + + readIfCan_! f == + f.fileIOmode ^= "input" => error "File not in read state" + BINARY__SELECT__INPUT(f.fileState)$Lisp + n:SingleInteger:=BINARY__READBYTE()$Lisp + n = -1 => "failed" + n::Union(SingleInteger,"failed") + + write_!(f, x) == + f.fileIOmode ^= "output" => error "File not in write state" + x < 0 or x>255 => error "integer cannot be represented as a byte" + BINARY__PRINBYTE(x)$Lisp + x + + position f == + f.fileIOmode ^= "input" => error "file must be in read state" + FILE_-POSITION(f.fileState)$Lisp + + position_!(f,i) == + f.fileIOmode ^= "input" => error "file must be in read state" + (FILE_-POSITION(f.fileState,i)$Lisp ; i) + *) \end{chunk} @@ -23024,12 +23518,15 @@ BinarySearchTree(S: OrderedSet): Exports == Implementation where ++X split(3,t1) Implementation == BinaryTree(S) add + Rep := BinaryTree(S) + binarySearchTree(u:List S) == null u => empty() tree := binaryTree(first u) for x in rest u repeat insert_!(x,tree) tree + insert_!(x,t) == empty? t => binaryTree(x) x >= value t => @@ -23037,6 +23534,7 @@ BinarySearchTree(S: OrderedSet): Exports == Implementation where t setleft_!(t,insert_!(x,left t)) t + split(x,t) == empty? t => [empty(),empty()] x > value t => @@ -23044,6 +23542,7 @@ BinarySearchTree(S: OrderedSet): Exports == Implementation where [node(left t, value t, a.less), a.greater] a := split(x,left t) [a.less, node(a.greater, value t, right t)] + insertRoot_!(x,t) == a := split(x,t) node(a.less, x, a.greater) @@ -23053,6 +23552,36 @@ BinarySearchTree(S: OrderedSet): Exports == Implementation where \begin{chunk}{COQ BSTREE} (* domain BSTREE *) (* + BinaryTree(S) add + + Rep := BinaryTree(S) + + binarySearchTree(u:List S) == + null u => empty() + tree := binaryTree(first u) + for x in rest u repeat insert_!(x,tree) + tree + + insert_!(x,t) == + empty? t => binaryTree(x) + x >= value t => + setright_!(t,insert_!(x,right t)) + t + setleft_!(t,insert_!(x,left t)) + t + + split(x,t) == + empty? t => [empty(),empty()] + x > value t => + a := split(x,right t) + [node(left t, value t, a.less), a.greater] + a := split(x,left t) + [a.less, node(a.greater, value t, right t)] + + insertRoot_!(x,t) == + a := split(x,t) + node(a.less, x, a.greater) + *) \end{chunk} @@ -23229,12 +23758,15 @@ BinaryTournament(S: OrderedSet): Exports == Implementation where ++X t1 Implementation == BinaryTree(S) add + Rep := BinaryTree(S) + binaryTournament(u:List S) == null u => empty() tree := binaryTree(first u) for x in rest u repeat insert_!(x,tree) tree + insert_!(x,t) == empty? t => binaryTree(x) x > value t => @@ -23249,6 +23781,25 @@ BinaryTournament(S: OrderedSet): Exports == Implementation where \begin{chunk}{COQ BTOURN} (* domain BTOURN *) (* + BinaryTree(S) add + + Rep := BinaryTree(S) + + binaryTournament(u:List S) == + null u => empty() + tree := binaryTree(first u) + for x in rest u repeat insert_!(x,tree) + tree + + insert_!(x,t) == + empty? t => binaryTree(x) + x > value t => + setleft_!(t,copy t) + setvalue_!(t,x) + setright_!(t,empty()) + setright_!(t,insert_!(x,right t)) + t + *) \end{chunk} @@ -23422,32 +23973,47 @@ BinaryTree(S: SetCategory): Exports == Implementation where ++X binaryTree(t1,[7,8,9],t2) Implementation == add + Rep := List Tree S + t1 = t2 == (t1::Rep) =$Rep (t2::Rep) + empty()== [] pretend % + empty()== [] pretend % + node(l,v,r) == cons(tree(v,l:Rep),r:Rep) + binaryTree(l,v,r) == node(l,v,r) + binaryTree(v:S) == node(empty(),v,empty()) + empty? t == empty?(t)$Rep + leaf? t == empty? t or empty? left t and empty? right t + right t == empty? t => error "binaryTree:no right" rest t + left t == empty? t => error "binaryTree:no left" children first t + value t== empty? t => error "binaryTree:no value" value first t + setvalue_! (t,nd)== empty? t => error "binaryTree:no value to set" setvalue_!(first(t:Rep),nd) nd + setleft_!(t1,t2) == empty? t1 => error "binaryTree:no left to set" setchildren_!(first(t1:Rep),t2:Rep) t1 + setright_!(t1,t2) == empty? t1 => error "binaryTree:no right to set" setrest_!(t1:List Tree S,t2) @@ -23457,6 +24023,51 @@ BinaryTree(S: SetCategory): Exports == Implementation where \begin{chunk}{COQ BTREE} (* domain BTREE *) (* + + Rep := List Tree S + + t1 = t2 == (t1::Rep) =$Rep (t2::Rep) + + empty()== [] pretend % + + empty()== [] pretend % + + node(l,v,r) == cons(tree(v,l:Rep),r:Rep) + + binaryTree(l,v,r) == node(l,v,r) + + binaryTree(v:S) == node(empty(),v,empty()) + + empty? t == empty?(t)$Rep + + leaf? t == empty? t or empty? left t and empty? right t + + right t == + empty? t => error "binaryTree:no right" + rest t + + left t == + empty? t => error "binaryTree:no left" + children first t + + value t== + empty? t => error "binaryTree:no value" + value first t + + setvalue_! (t,nd)== + empty? t => error "binaryTree:no value to set" + setvalue_!(first(t:Rep),nd) + nd + + setleft_!(t1,t2) == + empty? t1 => error "binaryTree:no left to set" + setchildren_!(first(t1:Rep),t2:Rep) + t1 + + setright_!(t1,t2) == + empty? t1 => error "binaryTree:no right to set" + setrest_!(t1:List Tree S,t2) + *) \end{chunk} @@ -23674,6 +24285,7 @@ Bits(): Exports == Implementation where bits: (NonNegativeInteger, Boolean) -> % ++ bits(n,b) creates bits with n values of b Implementation == IndexedBits(1) add + bits(n,b) == new(n,b) \end{chunk} @@ -23681,6 +24293,10 @@ Bits(): Exports == Implementation where \begin{chunk}{COQ BITS} (* domain BITS *) (* + IndexedBits(1) add + + bits(n,b) == new(n,b) + *) \end{chunk} @@ -23773,6 +24389,7 @@ BlowUpWithHamburgerNoether: Exports == Implementation where Exports ==> BlowUpMethodCategory with HamburgerNoether Implementation == add + Rep := MetRec infClsPt_? a == a.infClsPt @@ -23792,11 +24409,33 @@ BlowUpWithHamburgerNoether: Exports == Implementation where type a == a.type coerce(c:%):OutputForm== ( (c :: Rep ) :: MetRec) :: OutputForm + \end{chunk} \begin{chunk}{COQ BLHN} (* domain BLHN *) (* + + Rep := MetRec + + infClsPt_? a == a.infClsPt + + createHN( a,b,c,d,e,f,g)==[a,b,c,d,e,f,g]$Rep + + excepCoord a == a.ex + + chartCoord a == a.ch + + transCoord a == a.tr + + ramifMult a == a.ramif + + quotValuation a == a.quotVal + + type a == a.type + + coerce(c:%):OutputForm== ( (c :: Rep ) :: MetRec) :: OutputForm + *) \end{chunk} @@ -23890,6 +24529,7 @@ BlowUpWithQuadTrans: Exports == Implementation where QuadraticTransform Implementation == add + Rep := MetRec coerce(la:List(Integer)):% == [la.1, la.2,la.3, 1 ]$Rep @@ -23915,6 +24555,27 @@ BlowUpWithQuadTrans: Exports == Implementation where \begin{chunk}{COQ BLQT} (* domain BLQT *) (* + + Rep := MetRec + + coerce(la:List(Integer)):% == [la.1, la.2,la.3, 1 ]$Rep + + ramifMult a == One$Integer + + excepCoord a == a.ex + + chartCoord a == a.ch + + transCoord a == a.tr + + ramifMult a == a.ramif + + quotValuation a == One$Integer + + coerce(c:%):OutputForm== + oo: outRec := [ excepCoord(c) , chartCoord(c) ]$outRec + oo :: OutputForm + *) \end{chunk} @@ -24056,32 +24717,51 @@ Boolean(): Join(OrderedSet, Finite, Logic, ConvertibleTo InputForm) with ++ test(b) returns b and is provided for compatibility with the ++ new compiler. == add + nt: % -> % test a == a pretend Boolean nt b == (b pretend Boolean => false; true) + true == EQ(2,2)$Lisp --well, 1 is rather special + false == NIL$Lisp + sample() == true + not b == (test b => false; true) + _^ b == (test b => false; true) + _~ b == (test b => false; true) + _and(a, b) == (test a => b; false) + _/_\(a, b) == (test a => b; false) + _or(a, b) == (test a => true; b) + _\_/(a, b) == (test a => true; b) + xor(a, b) == (test a => nt b; b) + nor(a, b) == (test a => false; nt b) + nand(a, b) == (test a => nt b; true) + a = b == BooleanEquality(a, b)$Lisp + implies(a, b) == (test a => b; true) + a < b == (test b => not(test a);false) size() == 2 + index i == even?(i::Integer) => false true + lookup a == a pretend Boolean => 1 2 @@ -24102,6 +24782,67 @@ Boolean(): Join(OrderedSet, Finite, Logic, ConvertibleTo InputForm) with \begin{chunk}{COQ BOOLEAN} (* domain BOOLEAN *) (* + + nt: % -> % + + test a == a pretend Boolean + + nt b == (b pretend Boolean => false; true) + + true == EQ(2,2)$Lisp --well, 1 is rather special + + false == NIL$Lisp + + sample() == true + + not b == (test b => false; true) + + _^ b == (test b => false; true) + + _~ b == (test b => false; true) + + _and(a, b) == (test a => b; false) + + _/_\(a, b) == (test a => b; false) + + _or(a, b) == (test a => true; b) + + _\_/(a, b) == (test a => true; b) + + xor(a, b) == (test a => nt b; b) + + nor(a, b) == (test a => false; nt b) + + nand(a, b) == (test a => nt b; true) + + a = b == BooleanEquality(a, b)$Lisp + + implies(a, b) == (test a => b; true) + + a < b == (test b => not(test a);false) + + size() == 2 + + index i == + even?(i::Integer) => false + true + + lookup a == + a pretend Boolean => 1 + 2 + + random() == + even?(random()$Integer) => false + true + + convert(x:%):InputForm == + x pretend Boolean => convert("true"::Symbol) + convert("false"::Symbol) + + coerce(x:%):OutputForm == + x pretend Boolean => message "true" + message "false" + *) \end{chunk} @@ -24620,8 +25361,11 @@ CardinalNumber: Join(OrderedSet, AbelianMonoid, Monoid, -- Creation 0 == [FINord, 0] + 1 == [FINord, 1] + coerce(n:NonNegativeInteger):% == [FINord, n] + Aleph n == [n, DUMMYval] -- Output @@ -24636,27 +25380,33 @@ CardinalNumber: Join(OrderedSet, AbelianMonoid, Monoid, x.order ^= y.order => false finite? x => x.ival = y.ival true -- equal transfinites + x < y == x.order < y.order => true x.order > y.order => false finite? x => x.ival < y.ival false -- equal transfinites + x:% + y:% == finite? x and finite? y => [FINord, x.ival+y.ival] max(x, y) + x - y == x < y => "failed" finite? x => [FINord, x.ival-y.ival] x > y => x "failed" -- equal transfinites + x:% * y:% == finite? x and finite? y => [FINord, x.ival*y.ival] x = 0 or y = 0 => 0 max(x, y) + n:NonNegativeInteger * x:% == finite? x => [FINord, n*x.ival] n = 0 => 0 x + x**y == y = 0 => x ^= 0 => 1 @@ -24670,6 +25420,7 @@ CardinalNumber: Join(OrderedSet, AbelianMonoid, Monoid, error "Transfinite exponentiation only implemented under GCH" finite? x == x.order = FINord + countable? x == x.order < 1 retract(x:%):NonNegativeInteger == @@ -24682,6 +25433,7 @@ CardinalNumber: Join(OrderedSet, AbelianMonoid, Monoid, -- State manipulation generalizedContinuumHypothesisAssumed?() == GCHypothesis() + generalizedContinuumHypothesisAssumed b == (GCHypothesis() := b) \end{chunk} @@ -24689,6 +25441,91 @@ CardinalNumber: Join(OrderedSet, AbelianMonoid, Monoid, \begin{chunk}{COQ CARD} (* domain CARD *) (* + NNI ==> NonNegativeInteger + FINord ==> -1 + DUMMYval ==> -1 + + Rep := Record(order: Integer, ival: Integer) + + GCHypothesis: Reference(Boolean) := ref false + + -- Creation + 0 == [FINord, 0] + + 1 == [FINord, 1] + + coerce(n:NonNegativeInteger):% == [FINord, n] + + Aleph n == [n, DUMMYval] + + -- Output + ALEPHexpr := "Aleph"::OutputForm + + coerce(x: %): OutputForm == + x.order = FINord => (x.ival)::OutputForm + prefix(ALEPHexpr, [(x.order)::OutputForm]) + + -- Manipulation + x = y == + x.order ^= y.order => false + finite? x => x.ival = y.ival + true -- equal transfinites + + x < y == + x.order < y.order => true + x.order > y.order => false + finite? x => x.ival < y.ival + false -- equal transfinites + + x:% + y:% == + finite? x and finite? y => [FINord, x.ival+y.ival] + max(x, y) + + x - y == + x < y => "failed" + finite? x => [FINord, x.ival-y.ival] + x > y => x + "failed" -- equal transfinites + + x:% * y:% == + finite? x and finite? y => [FINord, x.ival*y.ival] + x = 0 or y = 0 => 0 + max(x, y) + + n:NonNegativeInteger * x:% == + finite? x => [FINord, n*x.ival] + n = 0 => 0 + x + + x**y == + y = 0 => + x ^= 0 => 1 + error "0**0 not defined for cardinal numbers." + finite? y => + not finite? x => x + [FINord,x.ival**(y.ival):NNI] + x = 0 => 0 + x = 1 => 1 + GCHypothesis() => [max(x.order-1, y.order) + 1, DUMMYval] + error "Transfinite exponentiation only implemented under GCH" + + finite? x == x.order = FINord + + countable? x == x.order < 1 + + retract(x:%):NonNegativeInteger == + finite? x => (x.ival)::NNI + error "Not finite" + + retractIfCan(x:%):Union(NonNegativeInteger, "failed") == + finite? x => (x.ival)::NNI + "failed" + + -- State manipulation + generalizedContinuumHypothesisAssumed?() == GCHypothesis() + + generalizedContinuumHypothesisAssumed b == (GCHypothesis() := b) + *) \end{chunk} @@ -25963,7 +26800,6 @@ CartesianTensor(minix, dim, R): Exports == Implementation where PERM ==> Vector Integer -- 1-based entries from 1..n INDEX ==> Vector Integer -- 1-based entries from minix..minix+dim-1 - get ==> elt$Rep set_! ==> setelt$Rep @@ -25982,6 +26818,7 @@ CartesianTensor(minix, dim, R): Exports == Implementation where dim4: NNI := dim**4 sample()==kroneckerDelta()$% + int2index(n: Integer, indv: INDEX): INDEX == n < 0 => error "Index error (too small)" rnk := #indv @@ -26059,7 +26896,6 @@ CartesianTensor(minix, dim, R): Exports == Implementation where odd? totTrans => -1 1 - ---- Exported functions ravel x == [get(x,i) for i in 0..#x-1] @@ -26095,15 +26931,19 @@ CartesianTensor(minix, dim, R): Exports == Implementation where elt(x) == #x ^= 1 => error "Index error (the rank is not 0)" get(x,0) + elt(x, i: I) == #x ^= dim => error "Index error (the rank is not 1)" get(x,(i-minix)) + elt(x, i: I, j: I) == #x ^= dim2 => error "Index error (the rank is not 2)" get(x,(dim*(i-minix) + (j-minix))) + elt(x, i: I, j: I, k: I) == #x ^= dim3 => error "Index error (the rank is not 3)" get(x,(dim2*(i-minix) + dim*(j-minix) + (k-minix))) + elt(x, i: I, j: I, k: I, l: I) == #x ^= dim4 => error "Index error (the rank is not 4)" get(x,(dim3*(i-minix)+dim2*(j-minix)+dim*(k-minix)+(l-minix))) @@ -26122,6 +26962,7 @@ CartesianTensor(minix, dim, R): Exports == Implementation where z := new(dim, 0) for r in lr for i in 0..dim-1 repeat set_!(z, i, r) z + coerce(lx: List %): % == #lx ^= dim => error "Incorrect number of slices" rx := rank first lx @@ -26136,6 +26977,7 @@ CartesianTensor(minix, dim, R): Exports == Implementation where retractIfCan(x:%):Union(R,"failed") == zero? rank(x) => x() "failed" + Outf ==> OutputForm mkOutf(x:%, i0:I, rnk:NNI): Outf == @@ -26153,6 +26995,7 @@ CartesianTensor(minix, dim, R): Exports == Implementation where mkOutf(x, 0, rank x) 0 == 0$R::Rep + 1 == 1$R::Rep --coerce(n: I): % == new(1, n::R) @@ -26177,43 +27020,51 @@ CartesianTensor(minix, dim, R): Exports == Implementation where for i in 0..#x-1 repeat if get(x,i) ^= get(y,i) then return false true + x + y == #x ^= #y => error "Rank mismatch" -- z := [xi + yi for xi in x for yi in y] z := new(#x, 0) for i in 0..#x-1 repeat set_!(z, i, get(x,i) + get(y,i)) z + x - y == #x ^= #y => error "Rank mismatch" -- [xi - yi for xi in x for yi in y] z := new(#x, 0) for i in 0..#x-1 repeat set_!(z, i, get(x,i) - get(y,i)) z + - x == -- [-xi for xi in x] z := new(#x, 0) for i in 0..#x-1 repeat set_!(z, i, -get(x,i)) z + n * x == -- [n * xi for xi in x] z := new(#x, 0) for i in 0..#x-1 repeat set_!(z, i, n * get(x,i)) z + x * n == -- [n * xi for xi in x] z := new(#x, 0) for i in 0..#x-1 repeat set_!(z, i, n* get(x,i)) -- Commutative!! z + r * x == -- [r * xi for xi in x] z := new(#x, 0) for i in 0..#x-1 repeat set_!(z, i, r * get(x,i)) z + x * r == -- [xi*r for xi in x] z := new(#x, 0) for i in 0..#x-1 repeat set_!(z, i, r* get(x,i)) -- Commutative!! z + product(x, y) == nx := #x; ny := #y z := new(nx * ny, 0) @@ -26284,6 +27135,7 @@ CartesianTensor(minix, dim, R): Exports == Implementation where transpose x == transpose(x, 1, rank x) + transpose(x, i, j) == rx := rank x i < 1 or i > rx or j < 1 or j > rx or i = j => @@ -26324,6 +27176,381 @@ CartesianTensor(minix, dim, R): Exports == Implementation where \begin{chunk}{COQ CARTEN} (* domain CARTEN *) (* + + PERM ==> Vector Integer -- 1-based entries from 1..n + INDEX ==> Vector Integer -- 1-based entries from minix..minix+dim-1 + + get ==> elt$Rep + set_! ==> setelt$Rep + + -- Use row-major order: + -- x[h,i,j] <-> x[(h-minix)*dim**2+(i-minix)*dim+(j-minix)] + + Rep := IndexedVector(R,0) + + n: Integer + r,s: R + x,y,z: % + + ---- Local stuff + dim2: NNI := dim**2 + dim3: NNI := dim**3 + dim4: NNI := dim**4 + + sample()==kroneckerDelta()$% + + int2index(n: Integer, indv: INDEX): INDEX == + n < 0 => error "Index error (too small)" + rnk := #indv + for i in 1..rnk repeat + qr := divide(n, dim) + n := qr.quotient + indv.((rnk-i+1) pretend NNI) := qr.remainder + minix + n ^= 0 => error "Index error (too big)" + indv + + index2int(indv: INDEX): Integer == + n: I := 0 + for i in 1..#indv repeat + ix := indv.i - minix + ix<0 or ix>dim-1 => error "Index error (out of range)" + n := dim*n + ix + n + + lengthRankOrElse(v: Integer): NNI == + v = 1 => 0 + v = dim => 1 + v = dim2 => 2 + v = dim3 => 3 + v = dim4 => 4 + rx := 0 + while v ^= 0 repeat + qr := divide(v, dim) + v := qr.quotient + if v ^= 0 then + qr.remainder ^= 0 => error "Rank is not a whole number" + rx := rx + 1 + rx + + -- l must be a list of the numbers 1..#l + mkPerm(n: NNI, l: List Integer): PERM == + #l ^= n => + error "The list is not a permutation." + p: PERM := new(n, 0) + seen: Vector Boolean := new(n, false) + for i in 1..n for e in l repeat + e < 1 or e > n => error "The list is not a permutation." + p.i := e + seen.e := true + for e in 1..n repeat + not seen.e => error "The list is not a permutation." + p + + -- permute s according to p into result t. + permute_!(t: INDEX, s: INDEX, p: PERM): INDEX == + for i in 1..#p repeat t.i := s.(p.i) + t + + -- permsign!(v) = 1, 0, or -1 according as + -- v is an even, is not, or is an odd permutation of minix..minix+#v-1. + permsign_!(v: INDEX): Integer == + -- sum minix..minix+#v-1. + maxix := minix+#v-1 + psum := (((maxix+1)*maxix - minix*(minix-1)) exquo 2)::Integer + -- +/v ^= psum => 0 + n := 0 + for i in 1..#v repeat n := n + v.i + n ^= psum => 0 + -- Bubble sort! This is pretty grotesque. + totTrans: Integer := 0 + nTrans: Integer := 1 + while nTrans ^= 0 repeat + nTrans := 0 + for i in 1..#v-1 for j in 2..#v repeat + if v.i > v.j then + nTrans := nTrans + 1 + e := v.i; v.i := v.j; v.j := e + totTrans := totTrans + nTrans + for i in 1..dim repeat + if v.i ^= minix+i-1 then return 0 + odd? totTrans => -1 + 1 + + ---- Exported functions + ravel x == + [get(x,i) for i in 0..#x-1] + + unravel l == + -- lengthRankOrElse #l gives sytnax error + nz: NNI := # l + lengthRankOrElse nz + z := new(nz, 0) + for i in 0..nz-1 for r in l repeat set_!(z, i, r) + z + + kroneckerDelta() == + z := new(dim2, 0) + for i in 1..dim for zi in 0.. by (dim+1) repeat set_!(z, zi, 1) + z + leviCivitaSymbol() == + nz := dim**dim + z := new(nz, 0) + indv: INDEX := new(dim, 0) + for i in 0..nz-1 repeat + set_!(z, i, permsign_!(int2index(i, indv))::R) + z + + -- from GradedModule + degree x == + rank x + + rank x == + n := #x + lengthRankOrElse n + + elt(x) == + #x ^= 1 => error "Index error (the rank is not 0)" + get(x,0) + + elt(x, i: I) == + #x ^= dim => error "Index error (the rank is not 1)" + get(x,(i-minix)) + + elt(x, i: I, j: I) == + #x ^= dim2 => error "Index error (the rank is not 2)" + get(x,(dim*(i-minix) + (j-minix))) + + elt(x, i: I, j: I, k: I) == + #x ^= dim3 => error "Index error (the rank is not 3)" + get(x,(dim2*(i-minix) + dim*(j-minix) + (k-minix))) + + elt(x, i: I, j: I, k: I, l: I) == + #x ^= dim4 => error "Index error (the rank is not 4)" + get(x,(dim3*(i-minix)+dim2*(j-minix)+dim*(k-minix)+(l-minix))) + + elt(x, i: List I) == + #i ^= rank x => error "Index error (wrong rank)" + n: I := 0 + for ii in i repeat + ix := ii - minix + ix<0 or ix>dim-1 => error "Index error (out of range)" + n := dim*n + ix + get(x,n) + + coerce(lr: List R): % == + #lr ^= dim => error "Incorrect number of components" + z := new(dim, 0) + for r in lr for i in 0..dim-1 repeat set_!(z, i, r) + z + + coerce(lx: List %): % == + #lx ^= dim => error "Incorrect number of slices" + rx := rank first lx + for x in lx repeat + rank x ^= rx => error "Inhomogeneous slice ranks" + nx := # first lx + z := new(dim * nx, 0) + for x in lx for offz in 0.. by nx repeat + for i in 0..nx-1 repeat set_!(z, offz + i, get(x,i)) + z + + retractIfCan(x:%):Union(R,"failed") == + zero? rank(x) => x() + "failed" + + Outf ==> OutputForm + + mkOutf(x:%, i0:I, rnk:NNI): Outf == + odd? rnk => + rnk1 := (rnk-1) pretend NNI + nskip := dim**rnk1 + [mkOutf(x, i0+nskip*i, rnk1) for i in 0..dim-1]::Outf + rnk = 0 => + get(x,i0)::Outf + rnk1 := (rnk-2) pretend NNI + nskip := dim**rnk1 + matrix [[mkOutf(x, i0+nskip*(dim*i + j), rnk1) + for j in 0..dim-1] for i in 0..dim-1] + coerce(x): Outf == + mkOutf(x, 0, rank x) + + 0 == 0$R::Rep + + 1 == 1$R::Rep + + --coerce(n: I): % == new(1, n::R) + coerce(r: R): % == new(1,r) + + coerce(v: DP(dim,R)): % == + z := new(dim, 0) + for i in 0..dim-1 for j in minIndex v .. maxIndex v repeat + set_!(z, i, v.j) + z + coerce(m: SM(dim,R)): % == + z := new(dim**2, 0) + offz := 0 + for i in 0..dim-1 repeat + for j in 0..dim-1 repeat + set_!(z, offz + j, m(i+1,j+1)) + offz := offz + dim + z + + x = y == + #x ^= #y => false + for i in 0..#x-1 repeat + if get(x,i) ^= get(y,i) then return false + true + + x + y == + #x ^= #y => error "Rank mismatch" + -- z := [xi + yi for xi in x for yi in y] + z := new(#x, 0) + for i in 0..#x-1 repeat set_!(z, i, get(x,i) + get(y,i)) + z + + x - y == + #x ^= #y => error "Rank mismatch" + -- [xi - yi for xi in x for yi in y] + z := new(#x, 0) + for i in 0..#x-1 repeat set_!(z, i, get(x,i) - get(y,i)) + z + + - x == + -- [-xi for xi in x] + z := new(#x, 0) + for i in 0..#x-1 repeat set_!(z, i, -get(x,i)) + z + + n * x == + -- [n * xi for xi in x] + z := new(#x, 0) + for i in 0..#x-1 repeat set_!(z, i, n * get(x,i)) + z + + x * n == + -- [n * xi for xi in x] + z := new(#x, 0) + for i in 0..#x-1 repeat set_!(z, i, n* get(x,i)) -- Commutative!! + z + + r * x == + -- [r * xi for xi in x] + z := new(#x, 0) + for i in 0..#x-1 repeat set_!(z, i, r * get(x,i)) + z + + x * r == + -- [xi*r for xi in x] + z := new(#x, 0) + for i in 0..#x-1 repeat set_!(z, i, r* get(x,i)) -- Commutative!! + z + + product(x, y) == + nx := #x; ny := #y + z := new(nx * ny, 0) + for i in 0..nx-1 for ioff in 0.. by ny repeat + for j in 0..ny-1 repeat + set_!(z, ioff + j, get(x,i) * get(y,j)) + z + x * y == + rx := rank x + ry := rank y + rx = 0 => get(x,0) * y + ry = 0 => x * get(y,0) + contract(x, rx, y, 1) + + contract(x, i, j) == + rx := rank x + i < 1 or i > rx or j < 1 or j > rx or i = j => + error "Improper index for contraction" + if i > j then (i,j) := (j,i) + + rl:= (rx- j) pretend NNI; nl:= dim**rl; zol:= 1; xol:= zol + rm:= (j-i-1) pretend NNI; nm:= dim**rm; zom:= nl; xom:= zom*dim + rh:= (i - 1) pretend NNI; nh:= dim**rh; zoh:= nl*nm + xoh:= zoh*dim**2 + xok := nl*(1 + nm*dim) + z := new(nl*nm*nh, 0) + for h in 1..nh _ + for xh in 0.. by xoh for zh in 0.. by zoh repeat + for m in 1..nm _ + for xm in xh.. by xom for zm in zh.. by zom repeat + for l in 1..nl _ + for xl in xm.. by xol for zl in zm.. by zol repeat + set_!(z, zl, 0) + for k in 1..dim for xk in xl.. by xok repeat + set_!(z, zl, get(z,zl) + get(x,xk)) + z + + contract(x, i, y, j) == + rx := rank x + ry := rank y + + i < 1 or i > rx or j < 1 or j > ry => + error "Improper index for contraction" + + rly:= (ry-j) pretend NNI; nly:= dim**rly; oly:= 1; zoly:= 1 + rhy:= (j -1) pretend NNI; nhy:= dim**rhy + ohy:= nly*dim; zohy:= zoly*nly + rlx:= (rx-i) pretend NNI; nlx:= dim**rlx + olx:= 1; zolx:= zohy*nhy + rhx:= (i -1) pretend NNI; nhx:= dim**rhx + ohx:= nlx*dim; zohx:= zolx*nlx + + z := new(nlx*nhx*nly*nhy, 0) + + for dxh in 1..nhx _ + for xh in 0.. by ohx for zhx in 0.. by zohx repeat + for dxl in 1..nlx _ + for xl in xh.. by olx for zlx in zhx.. by zolx repeat + for dyh in 1..nhy _ + for yh in 0.. by ohy for zhy in zlx.. by zohy repeat + for dyl in 1..nly _ + for yl in yh.. by oly for zly in zhy.. by zoly repeat + set_!(z, zly, 0) + for k in 1..dim _ + for xk in xl.. by nlx for yk in yl.. by nly repeat + set_!(z, zly, get(z,zly)+get(x,xk)*get(y,yk)) + z + + transpose x == + transpose(x, 1, rank x) + + transpose(x, i, j) == + rx := rank x + i < 1 or i > rx or j < 1 or j > rx or i = j => + error "Improper indicies for transposition" + if i > j then (i,j) := (j,i) + + rl:= (rx- j) pretend NNI; nl:= dim**rl; zol:= 1; zoi := zol*nl + rm:= (j-i-1) pretend NNI; nm:= dim**rm; zom:= nl*dim; zoj := zom*nm + rh:= (i - 1) pretend NNI; nh:= dim**rh; zoh:= nl*nm*dim**2 + z := new(#x, 0) + for h in 1..nh for zh in 0.. by zoh repeat _ + for m in 1..nm for zm in zh.. by zom repeat _ + for l in 1..nl for zl in zm.. by zol repeat _ + for p in 1..dim _ + for zp in zl.. by zoi for xp in zl.. by zoj repeat + for q in 1..dim _ + for zq in zp.. by zoj for xq in xp.. by zoi repeat + set_!(z, zq, get(x,xq)) + z + + reindex(x, l) == + nx := #x + z: % := new(nx, 0) + + rx := rank x + p := mkPerm(rx, l) + xiv: INDEX := new(rx, 0) + ziv: INDEX := new(rx, 0) + + -- Use permutation + for i in 0..#x-1 repeat + pi := index2int(permute_!(ziv, int2index(i,xiv),p)) + set_!(z, pi, get(x,i)) + z + *) \end{chunk} @@ -26476,6 +27703,50 @@ Cell(TheField) : PUB == PRIV where \begin{chunk}{COQ CELL} (* domain CELL *) (* + + Rep := List(SCELL) + + coerce(c:%):O == + paren [sc::O for sc in c] + + projection(cell) == + null cell => error "projection: should not appear" + r := rest(cell) + null r => "failed" + r + + makeCell(l:List(SCELL)) == l + + makeCell(scell,toAdd) == cons(scell,toAdd) + + mainVariableOf(cell) == + null(cell) => + error "Should not appear" + variableOf(first(cell)) + + variablesOf(cell) == + null(cell) => [] + cons(mainVariableOf(cell),variablesOf(rest(cell)::%)) + + dimension(cell) == + null(cell) => 0 + hasDimension?(first(cell)) => 1+dimension(rest(cell)) + dimension(rest(cell)) + + hasDimension?(cell,var) == + null(cell) => + error "Should not appear" + sc : SCELL := first(cell) + v := variableOf(sc) + v = var => hasDimension?(sc) + v < var => false + v > var => true + error "Caca Prout" + + samplePoint(cell) == + null(cell) => [] + cons(samplePoint(first(cell)),samplePoint(rest(cell))) + *) \end{chunk} @@ -26857,22 +28128,39 @@ Character: OrderedFinite() with minChar := minIndex OutChars a = b == a =$Rep b + a < b == a <$Rep b + size() == 256 + index n == char((n - 1)::Integer) + lookup c == (1 + ord c)::PositiveInteger + char(n:Integer) == n::% + ord c == convert(c)$Rep + random() == char(random()$Integer rem size()) + space == QENUM(" ", 0$Lisp)$Lisp + quote == QENUM("_" ", 0$Lisp)$Lisp + escape == QENUM("__ ", 0$Lisp)$Lisp + coerce(c:%):OutputForm == OutChars(minChar + ord c) + digit? c == member?(c pretend Character, digit()) + hexDigit? c == member?(c pretend Character, hexDigit()) + upperCase? c == member?(c pretend Character, upperCase()) + lowerCase? c == member?(c pretend Character, lowerCase()) + alphabetic? c == member?(c pretend Character, alphabetic()) + alphanumeric? c == member?(c pretend Character, alphanumeric()) latex c == @@ -26894,6 +28182,67 @@ Character: OrderedFinite() with \begin{chunk}{COQ CHAR} (* domain CHAR *) (* + + Rep := SingleInteger -- 0..255 + + CC ==> CharacterClass() + import CC + + OutChars:PrimitiveArray(OutputForm) := + construct [CODE_-CHAR(i)$Lisp for i in 0..255] + + minChar := minIndex OutChars + + a = b == a =$Rep b + + a < b == a <$Rep b + + size() == 256 + + index n == char((n - 1)::Integer) + + lookup c == (1 + ord c)::PositiveInteger + + char(n:Integer) == n::% + + ord c == convert(c)$Rep + + random() == char(random()$Integer rem size()) + + space == QENUM(" ", 0$Lisp)$Lisp + + quote == QENUM("_" ", 0$Lisp)$Lisp + + escape == QENUM("__ ", 0$Lisp)$Lisp + + coerce(c:%):OutputForm == OutChars(minChar + ord c) + + digit? c == member?(c pretend Character, digit()) + + hexDigit? c == member?(c pretend Character, hexDigit()) + + upperCase? c == member?(c pretend Character, upperCase()) + + lowerCase? c == member?(c pretend Character, lowerCase()) + + alphabetic? c == member?(c pretend Character, alphabetic()) + + alphanumeric? c == member?(c pretend Character, alphanumeric()) + + latex c == + concat("\mbox{`", concat(new(1,c pretend Character)$String, "'}")_ + $String)$String + + char(s:String) == + (#s) = 1 => s(minIndex s) pretend % + error "String is not a single character" + + upperCase c == + QENUM(PNAME(UPCASE(CODE_-CHAR(ord c)$Lisp)$Lisp)$Lisp,0$Lisp)$Lisp + + lowerCase c == + QENUM(PNAME(DOWNCASE(CODE_-CHAR(ord c)$Lisp)$Lisp)$Lisp,0$Lisp)$Lisp + *) \end{chunk} @@ -27331,22 +28680,32 @@ CharacterClass: Join(SetCategory, ConvertibleTo String, a, b: % digit() == charClass "0123456789" + hexDigit() == charClass "0123456789abcdefABCDEF" + upperCase() == charClass "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + lowerCase() == charClass "abcdefghijklmnopqrstuvwxyz" + alphabetic() == union(upperCase(), lowerCase()) + alphanumeric() == union(alphabetic(), digit()) a = b == a =$Rep b member?(c, a) == a(ord c) + union(a,b) == Or(a, b) + intersect (a,b) == And(a, b) + difference(a,b) == And(a, Not b) + complement a == Not a convert(cl):String == construct(convert(cl)@List(Character)) + convert(cl:%):List(Character) == [char(i) for i in 0..N-1 | cl.i] @@ -27363,11 +28722,15 @@ CharacterClass: Join(SetCategory, ConvertibleTo String, coerce(cl):OutputForm == (convert(cl)@String)::OutputForm -- Stuff to make a legal SetAggregate view + # a == (n := 0; for i in 0..N-1 | a.i repeat n := n+1; n) + empty():% == charClass [] + brace():% == charClass [] insert_!(c, a) == (a(ord c) := true; a) + remove_!(c, a) == (a(ord c) := false; a) inspect(a) == @@ -27386,6 +28749,7 @@ CharacterClass: Join(SetCategory, ConvertibleTo String, b temp: % := new(N, false)$Rep + map_!(f, a) == fill_!(temp, false) for i in 0..N-1 | a.i repeat temp(ord f char i) := true @@ -27399,6 +28763,90 @@ CharacterClass: Join(SetCategory, ConvertibleTo String, \begin{chunk}{COQ CCLASS} (* domain CCLASS *) (* + Rep := IndexedBits(0) + N := size()$Character + + a, b: % + + digit() == charClass "0123456789" + + hexDigit() == charClass "0123456789abcdefABCDEF" + + upperCase() == charClass "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + + lowerCase() == charClass "abcdefghijklmnopqrstuvwxyz" + + alphabetic() == union(upperCase(), lowerCase()) + + alphanumeric() == union(alphabetic(), digit()) + + a = b == a =$Rep b + + member?(c, a) == a(ord c) + + union(a,b) == Or(a, b) + + intersect (a,b) == And(a, b) + + difference(a,b) == And(a, Not b) + + complement a == Not a + + convert(cl):String == + construct(convert(cl)@List(Character)) + + convert(cl:%):List(Character) == + [char(i) for i in 0..N-1 | cl.i] + + charClass(s: String) == + cl := new(N, false) + for i in minIndex(s)..maxIndex(s) repeat cl(ord s.i) := true + cl + + charClass(l: List Character) == + cl := new(N, false) + for c in l repeat cl(ord c) := true + cl + + coerce(cl):OutputForm == (convert(cl)@String)::OutputForm + + -- Stuff to make a legal SetAggregate view + + # a == (n := 0; for i in 0..N-1 | a.i repeat n := n+1; n) + + empty():% == charClass [] + + brace():% == charClass [] + + insert_!(c, a) == (a(ord c) := true; a) + + remove_!(c, a) == (a(ord c) := false; a) + + inspect(a) == + for i in 0..N-1 | a.i repeat + return char i + error "Cannot take a character from an empty class." + extract_!(a) == + for i in 0..N-1 | a.i repeat + a.i := false + return char i + error "Cannot take a character from an empty class." + + map(f, a) == + b := new(N, false) + for i in 0..N-1 | a.i repeat b(ord f char i) := true + b + + temp: % := new(N, false)$Rep + + map_!(f, a) == + fill_!(temp, false) + for i in 0..N-1 | a.i repeat temp(ord f char i) := true + copyInto_!(a, temp, 0) + + parts a == + [char i for i in 0..N-1 | a.i] + *) \end{chunk} @@ -28326,7 +29774,9 @@ CliffordAlgebra(n, K, Q): T == Impl where ++ if x is not invertible. Impl ==> add + Qeelist := [Q unitVector(i::PositiveInteger) for i in 1..n] + dim := 2**n Rep := PrimitiveArray K @@ -28338,6 +29788,7 @@ CliffordAlgebra(n, K, Q): T == Impl where m: Integer characteristic() == characteristic()$K + dimension() == dim::CardinalNumber x = y == @@ -28346,14 +29797,21 @@ CliffordAlgebra(n, K, Q): T == Impl where true x + y == (z := New; for i in 0..dim-1 repeat z.i := x.i + y.i; z) + x - y == (z := New; for i in 0..dim-1 repeat z.i := x.i - y.i; z) + - x == (z := New; for i in 0..dim-1 repeat z.i := - x.i; z) + m * x == (z := New; for i in 0..dim-1 repeat z.i := m*x.i; z) + c * x == (z := New; for i in 0..dim-1 repeat z.i := c*x.i; z) 0 == New + 1 == (z := New; z.0 := 1; z) + coerce(m): % == (z := New; z.0 := m::K; z) + coerce(c): % == (z := New; z.0 := c; z) e b == @@ -28423,6 +29881,7 @@ CliffordAlgebra(n, K, Q): T == Impl where z := New z r.basel := r.coef z + coefficient(z, lb) == r := canonMonom(1, lb) r.coef = 0 => error "Cannot take coef of 0" @@ -28483,6 +29942,169 @@ CliffordAlgebra(n, K, Q): T == Impl where \begin{chunk}{COQ CLIF} (* domain CLIF *) (* + + Qeelist := [Q unitVector(i::PositiveInteger) for i in 1..n] + + dim := 2**n + + Rep := PrimitiveArray K + + New ==> new(dim, 0$K)$Rep + + x, y, z: % + c: K + m: Integer + + characteristic() == characteristic()$K + + dimension() == dim::CardinalNumber + + x = y == + for i in 0..dim-1 repeat + if x.i ^= y.i then return false + true + + x + y == (z := New; for i in 0..dim-1 repeat z.i := x.i + y.i; z) + + x - y == (z := New; for i in 0..dim-1 repeat z.i := x.i - y.i; z) + + - x == (z := New; for i in 0..dim-1 repeat z.i := - x.i; z) + + m * x == (z := New; for i in 0..dim-1 repeat z.i := m*x.i; z) + + c * x == (z := New; for i in 0..dim-1 repeat z.i := c*x.i; z) + + 0 == New + + 1 == (z := New; z.0 := 1; z) + + coerce(m): % == (z := New; z.0 := m::K; z) + + coerce(c): % == (z := New; z.0 := c; z) + + e b == + b::NNI > n => error "No such basis element" + iz := 2**((b-1)::NNI) + z := New; z.iz := 1; z + + -- The ei*ej products could instead be precomputed in + -- a (2**n)**2 multiplication table. + addMonomProd(c1: K, b1: NNI, c2: K, b2: NNI, z: %): % == + c := c1 * c2 + bz := b2 + for i in 0..n-1 | bit?(b1,i) repeat + -- Apply rule ei*ej = -ej*ei for i^=j + k := 0 + for j in i+1..n-1 | bit?(b1, j) repeat k := k+1 + for j in 0..i-1 | bit?(bz, j) repeat k := k+1 + if odd? k then c := -c + -- Apply rule ei**2 = Q(ei) + if bit?(bz,i) then + c := c * Qeelist.(i+1) + bz:= (bz - 2**i)::NNI + else + bz:= bz + 2**i + z.bz := z.bz + c + z + + x * y == + z := New + for ix in 0..dim-1 repeat + if x.ix ^= 0 then for iy in 0..dim-1 repeat + if y.iy ^= 0 then addMonomProd(x.ix,ix,y.iy,iy,z) + z + + canonMonom(c: K, lb: List PI): Record(coef: K, basel: NNI) == + -- 0. Check input + for b in lb repeat b > n => error "No such basis element" + + -- 1. Apply identity ei*ej = -ej*ei, i^=j. + -- The Rep assumes n is small so bubble sort is ok. + -- Using bubble sort keeps the exchange info obvious. + wasordered := false + exchanges := 0 + while not wasordered repeat + wasordered := true + for i in 1..#lb-1 repeat + if lb.i > lb.(i+1) then + t := lb.i; lb.i := lb.(i+1); lb.(i+1) := t + exchanges := exchanges + 1 + wasordered := false + if odd? exchanges then c := -c + + -- 2. Prepare the basis element + -- Apply identity ei*ei = Q(ei). + bz := 0 + for b in lb repeat + bn := (b-1)::NNI + if bit?(bz, bn) then + c := c * Qeelist bn + bz:= ( bz - 2**bn )::NNI + else + bz:= bz + 2**bn + [c, bz::NNI] + + monomial(c, lb) == + r := canonMonom(c, lb) + z := New + z r.basel := r.coef + z + + coefficient(z, lb) == + r := canonMonom(1, lb) + r.coef = 0 => error "Cannot take coef of 0" + z r.basel/r.coef + + Ex ==> OutputForm + + coerceMonom(c: K, b: NNI): Ex == + b = 0 => c::Ex + ml := [sub("e"::Ex, i::Ex) for i in 1..n | bit?(b,i-1)] + be := reduce("*", ml) + c = 1 => be + c::Ex * be + + coerce(x): Ex == + tl := [coerceMonom(x.i,i) for i in 0..dim-1 | x.i^=0] + null tl => "0"::Ex + reduce("+", tl) + + localPowerSets(j:NNI): List(List(PI)) == + l: List List PI := list [] + j = 0 => l + Sm := localPowerSets((j-1)::NNI) + Sn: List List PI := [] + for x in Sm repeat Sn := cons(cons(j pretend PI, x),Sn) + append(Sn, Sm) + + powerSets(j:NNI):List List PI == map(reverse, localPowerSets j) + + Pn:List List PI := powerSets(n) + + recip(x: %): Union(%, "failed") == + one:% := 1 + -- tmp:c := x*yC - 1$C + rhsEqs : List K := [] + lhsEqs: List List K := [] + lhsEqi: List K + for pi in Pn repeat + rhsEqs := cons(coefficient(one, pi), rhsEqs) + + lhsEqi := [] + for pj in Pn repeat + lhsEqi := cons(coefficient(x*monomial(1,pj),pi),lhsEqi) + lhsEqs := cons(reverse(lhsEqi),lhsEqs) + ans := particularSolution(matrix(lhsEqs),vector(rhsEqs)_ + )$LinearSystemMatrixPackage(K, Vector K, Vector K, Matrix K) + ans case "failed" => "failed" + ansP := parts(ans) + ansC:% := 0 + for pj in Pn repeat + cj:= first ansP + ansP := rest ansP + ansC := ansC + cj*monomial(1,pj) + ansC + *) \end{chunk} @@ -28630,13 +30252,21 @@ Color(): Exports == Implementation where [ans,1] x = y == (x.hue = y.hue) and (x.weight = y.weight) + red() == [1,1] + yellow() == [11::I,1] + green() == [14::I,1] + blue() == [22::I,1] + sample() == red() + hue c == c.hue + i:PositiveInteger * c:% == i::SF * c + numberOfHues() == totalHues color i == @@ -28653,6 +30283,62 @@ Color(): Exports == Implementation where \begin{chunk}{COQ COLOR} (* domain COLOR *) (* + totalHues ==> 27 --see (header.h file) for the current number + + Rep := Record(hue:I, weight:SF) + + + f:SF * c:% == + -- s * c returns the color c, whose weighted shade has been scaled by s + zero? f => c + -- 0 is the identitly function...or maybe an error is better? + [c.hue, f * c.weight] + + x + y == + x.hue = y.hue => [x.hue, x.weight + y.weight] + if y.weight > x.weight then -- let x be color with bigger weight + c := x + x := y + y := c + diff := x.hue - y.hue + if (xHueSmaller:= (diff < 0)) then diff := -diff + if (moreThanHalf:=(diff > totalHues quo 2)) then diff := totalHues-diff + offset : I := wholePart(round (diff::SF/(2::SF)**(x.weight/y.weight)) ) + if (xHueSmaller and ^moreThanHalf) or (^xHueSmaller and moreThanHalf) then + ans := x.hue + offset + else + ans := x.hue - offset + if (ans < 0) then ans := totalHues + ans + else if (ans > totalHues) then ans := ans - totalHues + [ans,1] + + x = y == (x.hue = y.hue) and (x.weight = y.weight) + + red() == [1,1] + + yellow() == [11::I,1] + + green() == [14::I,1] + + blue() == [22::I,1] + + sample() == red() + + hue c == c.hue + + i:PositiveInteger * c:% == i::SF * c + + numberOfHues() == totalHues + + color i == + if (i<0) or (i>totalHues) then + error concat("Color should be in the range 1..",totalHues::String) + [i::I, 1] + + coerce(c:%):OutputForm == + hconcat ["Hue: "::OutputForm, (c.hue)::OutputForm, + " Weight: "::OutputForm, (c.weight)::OutputForm] + *) \end{chunk} @@ -28743,9 +30429,13 @@ Commutator: Export == Implement where ++ mkcomm(i,j) is not documented Implement == add + P := Record(left:%,right:%) + Rep := Union(OSI,P) + x,y: % + i : I x = y == @@ -28757,6 +30447,7 @@ Commutator: Export == Implement where false mkcomm(i) == i::OSI + mkcomm(x,y) == construct(x,y)$P coerce(x: %): O == @@ -28769,6 +30460,32 @@ Commutator: Export == Implement where \begin{chunk}{COQ COMM} (* domain COMM *) (* + + P := Record(left:%,right:%) + + Rep := Union(OSI,P) + + x,y: % + + i : I + + x = y == + (x case OSI) and (y case OSI) => x::OSI = y::OSI + (x case P) and (y case P) => + xx:P := x::P + yy:P := y::P + (xx.right = yy.right) and (xx.left = yy.left) + false + + mkcomm(i) == i::OSI + + mkcomm(x,y) == construct(x,y)$P + + coerce(x: %): O == + x case OSI => x::OSI::O + xx := x::P + bracket([xx.left::O,xx.right::O])$O + *) \end{chunk} @@ -29397,9 +31114,11 @@ o )show Complex Complex(R:CommutativeRing): ComplexCategory(R) with if R has OpenMath then OpenMath == add + Rep := Record(real:R, imag:R) if R has OpenMath then + writeOMComplex(dev: OpenMathDevice, x: %): Void == OMputApp(dev) OMputSymbol(dev, "complex1", "complex__cartesian") @@ -29444,16 +31163,24 @@ Complex(R:CommutativeRing): ComplexCategory(R) with OMputEndObject(dev) 0 == [0, 0] + 1 == [1, 0] + zero? x == zero?(x.real) and zero?(x.imag) --- one? x == one?(x.real) and zero?(x.imag) + one? x == ((x.real) = 1) and zero?(x.imag) + coerce(r:R):% == [r, 0] + complex(r, i) == [r, i] + real x == x.real + imag x == x.imag + x + y == [x.real + y.real, x.imag + y.imag] -- by re-defining this here, we save 5 fn calls + x:% * y:% == [x.real * y.real - x.imag * y.imag, x.imag * y.real + y.imag * x.real] -- here we save nine! @@ -29469,6 +31196,83 @@ Complex(R:CommutativeRing): ComplexCategory(R) with \begin{chunk}{COQ COMPLEX} (* domain COMPLEX *) (* + + Rep := Record(real:R, imag:R) + + if R has OpenMath then + + writeOMComplex(dev: OpenMathDevice, x: %): Void == + OMputApp(dev) + OMputSymbol(dev, "complex1", "complex__cartesian") + OMwrite(dev, real x) + OMwrite(dev, imag x) + OMputEndApp(dev) + + OMwrite(x: %): String == + s: String := "" + sp := OM_-STRINGTOSTRINGPTR(s)$Lisp + dev: OpenMathDevice := OMopenString(sp pretend String, OMencodingXML) + OMputObject(dev) + writeOMComplex(dev, x) + OMputEndObject(dev) + OMclose(dev) + s := OM_-STRINGPTRTOSTRING(sp)$Lisp pretend String + s + + OMwrite(x: %, wholeObj: Boolean): String == + s: String := "" + sp := OM_-STRINGTOSTRINGPTR(s)$Lisp + dev: OpenMathDevice := OMopenString(sp pretend String, OMencodingXML) + if wholeObj then + OMputObject(dev) + writeOMComplex(dev, x) + if wholeObj then + OMputEndObject(dev) + OMclose(dev) + s := OM_-STRINGPTRTOSTRING(sp)$Lisp pretend String + s + + OMwrite(dev: OpenMathDevice, x: %): Void == + OMputObject(dev) + writeOMComplex(dev, x) + OMputEndObject(dev) + + OMwrite(dev: OpenMathDevice, x: %, wholeObj: Boolean): Void == + if wholeObj then + OMputObject(dev) + writeOMComplex(dev, x) + if wholeObj then + OMputEndObject(dev) + + 0 == [0, 0] + + 1 == [1, 0] + + zero? x == zero?(x.real) and zero?(x.imag) + + one? x == ((x.real) = 1) and zero?(x.imag) + + coerce(r:R):% == [r, 0] + + complex(r, i) == [r, i] + + real x == x.real + + imag x == x.imag + + x + y == [x.real + y.real, x.imag + y.imag] + -- by re-defining this here, we save 5 fn calls + + x:% * y:% == + [x.real * y.real - x.imag * y.imag, + x.imag * y.real + y.imag * x.real] -- here we save nine! + + + if R has IntegralDomain then + _exquo(x:%, y:%) == -- to correct bad defaulting problem + zero? y.imag => x exquo y.real + x * conjugate(y) exquo norm(y) + *) \end{chunk} @@ -29772,17 +31576,25 @@ ComplexDoubleFloatMatrix : MatrixCategory(Complex DoubleFloat, Qnew ==> MAKE_-CDOUBLE_-MATRIX$Lisp minRowIndex x == 0 + minColIndex x == 0 + nrows x == Qnrows(x) + ncols x == Qncols(x) + maxRowIndex x == Qnrows(x) - 1 + maxColIndex x == Qncols(x) - 1 qelt(m, i, j) == Qelt2(m, i, j) + qsetelt_!(m, i, j, r) == Qsetelt2(m, i, j, r) empty() == Qnew(0$Integer, 0$Integer) + qnew(rows, cols) == Qnew(rows, cols) + new(rows, cols, a) == res := Qnew(rows, cols) for i in 0..(rows - 1) repeat @@ -29795,6 +31607,41 @@ ComplexDoubleFloatMatrix : MatrixCategory(Complex DoubleFloat, \begin{chunk}{COQ CDFMAT} (* domain CDFMAT *) (* + + NNI ==> Integer + Qelt2 ==> CDAREF2$Lisp + Qsetelt2 ==> CDSETAREF2$Lisp + Qnrows ==> CDANROWS$Lisp + Qncols ==> CDANCOLS$Lisp + Qnew ==> MAKE_-CDOUBLE_-MATRIX$Lisp + + minRowIndex x == 0 + + minColIndex x == 0 + + nrows x == Qnrows(x) + + ncols x == Qncols(x) + + maxRowIndex x == Qnrows(x) - 1 + + maxColIndex x == Qncols(x) - 1 + + qelt(m, i, j) == Qelt2(m, i, j) + + qsetelt_!(m, i, j, r) == Qsetelt2(m, i, j, r) + + empty() == Qnew(0$Integer, 0$Integer) + + qnew(rows, cols) == Qnew(rows, cols) + + new(rows, cols, a) == + res := Qnew(rows, cols) + for i in 0..(rows - 1) repeat + for j in 0..(cols - 1) repeat + Qsetelt2(res, i, j, a) + res + *) \end{chunk} @@ -30096,25 +31943,38 @@ ComplexDoubleFloatVector : VectorCategory Complex DoubleFloat with == add Qelt1 ==> CDELT$Lisp + Qsetelt1 ==> CDSETELT$Lisp qelt(x, i) == Qelt1(x, i) + qsetelt_!(x, i, s) == Qsetelt1(x, i, s) + Qsize ==> CDLEN$Lisp + Qnew ==> MAKE_-CDOUBLE_-VECTOR$Lisp #x == Qsize x + minIndex x == 0 + empty() == Qnew(0$Lisp) + qnew(n) == Qnew(n) + new(n, x) == res := Qnew(n) fill_!(res, x) + qelt(x, i) == Qelt1(x, i) + elt(x:%, i:Integer) == Qelt1(x, i) + qsetelt_!(x, i, s) == Qsetelt1(x, i, s) + setelt(x : %, i : Integer, s : Complex DoubleFloat) == Qsetelt1(x, i, s) + fill_!(x, s) == for i in 0..((Qsize(x)) - 1) repeat Qsetelt1(x, i, s) x @@ -30124,6 +31984,44 @@ ComplexDoubleFloatVector : VectorCategory Complex DoubleFloat with \begin{chunk}{COQ CDFVEC} (* domain CDFVEC *) (* + + Qelt1 ==> CDELT$Lisp + + Qsetelt1 ==> CDSETELT$Lisp + + qelt(x, i) == Qelt1(x, i) + + qsetelt_!(x, i, s) == Qsetelt1(x, i, s) + + Qsize ==> CDLEN$Lisp + + Qnew ==> MAKE_-CDOUBLE_-VECTOR$Lisp + + #x == Qsize x + + minIndex x == 0 + + empty() == Qnew(0$Lisp) + + qnew(n) == Qnew(n) + + new(n, x) == + res := Qnew(n) + fill_!(res, x) + + qelt(x, i) == Qelt1(x, i) + + elt(x:%, i:Integer) == Qelt1(x, i) + + qsetelt_!(x, i, s) == Qsetelt1(x, i, s) + + setelt(x : %, i : Integer, s : Complex DoubleFloat) == + Qsetelt1(x, i, s) + + fill_!(x, s) == + for i in 0..((Qsize(x)) - 1) repeat Qsetelt1(x, i, s) + x + *) \end{chunk} @@ -30910,25 +32808,34 @@ ContinuedFraction(R): Exports == Implementation where Implementation ==> add - -- isOrdered ==> R is Integer isOrdered ==> R has OrderedRing and R has multiplicativeValuation + canReduce? ==> isOrdered or R has additiveValuation Rec ==> Record(num: R, den: R) + Str ==> Stream Rec + Rep := Record(value: Record(whole: R, fract: Str), reduced?: Boolean) import Str genFromSequence: Stream Q -> % + genReducedForm: (Q, Stream Q, MT) -> Stream Rec + genFractionA: (Stream R,Stream R) -> Stream Rec + genFractionB: (Stream R,Stream R) -> Stream Rec + genNumDen: (R,R, Stream Rec) -> Stream R genApproximants: (R,R,R,R,Stream Rec) -> Stream Q + genConvergents: (R,R,R,R,Stream Rec) -> Stream Q + iGenApproximants: (R,R,R,R,Stream Rec) -> Stream Q + iGenConvergents: (R,R,R,R,Stream Rec) -> Stream Q reducedForm c == @@ -30976,6 +32883,7 @@ ContinuedFraction(R): Exports == Implementation where d < 0 => error "Denominators must be greater than 0." concat([n,d]$Rec, delay genFractionA(rst nums,rst dens)) else + continuedFraction(wh,nums,dens) == [[wh,genFractionB(nums,dens)],false] genFractionB(nums,dens) == @@ -30988,6 +32896,7 @@ ContinuedFraction(R): Exports == Implementation where continuedFraction(wh, repeating [1], dens) coerce(n:Integer):% == [[n::R,empty()], true] + coerce(r:R):% == [[r, empty()], true] coerce(a: Q): % == @@ -31007,7 +32916,6 @@ ContinuedFraction(R): Exports == Implementation where characteristic() == characteristic()$Q - genFromSequence apps == lo := first apps; apps := rst apps hi := first apps; apps := rst apps @@ -31031,26 +32939,33 @@ ContinuedFraction(R): Exports == Implementation where wholePart c == c.value.whole + partialNumerators c == map(x1+->x1.num, c.value.fract)$StreamFunctions2(Rec,R) + partialDenominators c == map(x1+->x1.den, c.value.fract)$StreamFunctions2(Rec,R) + partialQuotients c == concat(c.value.whole, partialDenominators c) approximants c == empty? c.value.fract => repeating [c.value.whole::Q] genApproximants(1,0,c.value.whole,1,c.value.fract) + convergents c == empty? c.value.fract => concat(c.value.whole::Q, empty()) genConvergents (1,0,c.value.whole,1,c.value.fract) + numerators c == empty? c.value.fract => concat(c.value.whole, empty()) genNumDen(1,c.value.whole,c.value.fract) + denominators c == genNumDen(0,1,c.value.fract) extend(x,n) == (extend(x.value.fract,n); x) + complete(x) == (complete(x.value.fract); x) iGenApproximants(pm2,qm2,pm1,qm1,fr) == delay @@ -31078,6 +32993,7 @@ ContinuedFraction(R): Exports == Implementation where concat(m1,delay genNumDen(m1,m2*frst(fr).num + m1*frst(fr).den,rst fr)) gen ==> genFromSequence + apx ==> approximants c, d: % @@ -31086,16 +33002,25 @@ ContinuedFraction(R): Exports == Implementation where n: Integer 0 == (0$R) :: % + 1 == (1$R) :: % c + d == genFromSequence map((x,y) +-> x + y, apx c, apx d) + c - d == genFromSequence map((x,y) +-> x - y, apx c, rest apx d) + - c == genFromSequence map(x +-> - x, rest apx c) + c * d == genFromSequence map((x,y) +-> x * y, apx c, apx d) + a * d == genFromSequence map(x +-> a * x, apx d) + q * d == genFromSequence map(x +-> q * x, apx d) + n * d == genFromSequence map(x +-> n * x, apx d) + c / d == genFromSequence map((x,y) +-> x / y, apx c, rest apx d) + recip c ==(c = 0 => "failed"; genFromSequence map(x +-> 1/x, rest apx c)) @@ -31130,6 +33055,249 @@ ContinuedFraction(R): Exports == Implementation where \begin{chunk}{COQ CONTFRAC} (* domain CONTFRAC *) (* + + isOrdered ==> R has OrderedRing and R has multiplicativeValuation + + canReduce? ==> isOrdered or R has additiveValuation + + Rec ==> Record(num: R, den: R) + + Str ==> Stream Rec + + Rep := Record(value: Record(whole: R, fract: Str), reduced?: Boolean) + + import Str + + genFromSequence: Stream Q -> % + + genReducedForm: (Q, Stream Q, MT) -> Stream Rec + + genFractionA: (Stream R,Stream R) -> Stream Rec + + genFractionB: (Stream R,Stream R) -> Stream Rec + + genNumDen: (R,R, Stream Rec) -> Stream R + + genApproximants: (R,R,R,R,Stream Rec) -> Stream Q + + genConvergents: (R,R,R,R,Stream Rec) -> Stream Q + + iGenApproximants: (R,R,R,R,Stream Rec) -> Stream Q + + iGenConvergents: (R,R,R,R,Stream Rec) -> Stream Q + + reducedForm c == + c.reduced? => c + explicitlyFinite? c.value.fract => + continuedFraction last complete convergents c + canReduce? => genFromSequence approximants c + error "Reduced form not defined for this continued fraction." + + eucWhole(a: Q): R == numer a quo denom a + + eucWhole0(a: Q): R == + isOrdered => + n := numer a + d := denom a + q := n quo d + r := n - q*d + if r < 0 then q := q - 1 + q + eucWhole a + + x = y == + x := reducedForm x + y := reducedForm y + + x.value.whole ^= y.value.whole => false + + xl := x.value.fract; yl := y.value.fract + + while not empty? xl and not empty? yl repeat + frst.xl.den ^= frst.yl.den => return false + xl := rst xl; yl := rst yl + empty? xl and empty? yl + + continuedFraction q == q :: % + + if isOrdered then + continuedFraction(wh,nums,dens) == [[wh,genFractionA(nums,dens)],false] + + genFractionA(nums,dens) == + empty? nums or empty? dens => empty() + n := frst nums + d := frst dens + n < 0 => error "Numerators must be greater than 0." + d < 0 => error "Denominators must be greater than 0." + concat([n,d]$Rec, delay genFractionA(rst nums,rst dens)) + else + + continuedFraction(wh,nums,dens) == [[wh,genFractionB(nums,dens)],false] + + genFractionB(nums,dens) == + empty? nums or empty? dens => empty() + n := frst nums + d := frst dens + concat([n,d]$Rec, delay genFractionB(rst nums,rst dens)) + + reducedContinuedFraction(wh,dens) == + continuedFraction(wh, repeating [1], dens) + + coerce(n:Integer):% == [[n::R,empty()], true] + + coerce(r:R):% == [[r, empty()], true] + + coerce(a: Q): % == + wh := eucWhole0 a + fr := a - wh::Q + zero? fr => [[wh, empty()], true] + + l : List Rec := empty() + n := numer fr + d := denom fr + while not zero? d repeat + qr := divide(n,d) + l := concat([1,qr.quotient],l) + n := d + d := qr.remainder + [[wh, construct rest reverse_! l], true] + + characteristic() == characteristic()$Q + + genFromSequence apps == + lo := first apps; apps := rst apps + hi := first apps; apps := rst apps + while eucWhole0 lo ^= eucWhole0 hi repeat + lo := first apps; apps := rst apps + hi := first apps; apps := rst apps + wh := eucWhole0 lo + [[wh, genReducedForm(wh::Q, apps, moebius(1,0,0,1))], canReduce?] + + genReducedForm(wh0, apps, mt) == + lo: Q := first apps - wh0; apps := rst apps + hi: Q := first apps - wh0; apps := rst apps + lo = hi and zero? eval(mt, lo) => empty() + mt := recip mt + wlo := eucWhole eval(mt, lo) + whi := eucWhole eval(mt, hi) + while wlo ^= whi repeat + wlo := eucWhole eval(mt, first apps - wh0); apps := rst apps + whi := eucWhole eval(mt, first apps - wh0); apps := rst apps + concat([1,wlo], delay genReducedForm(wh0, apps, shift(mt, -wlo::Q))) + + wholePart c == + c.value.whole + + partialNumerators c == + map(x1+->x1.num, c.value.fract)$StreamFunctions2(Rec,R) + + partialDenominators c == + map(x1+->x1.den, c.value.fract)$StreamFunctions2(Rec,R) + + partialQuotients c == + concat(c.value.whole, partialDenominators c) + + approximants c == + empty? c.value.fract => repeating [c.value.whole::Q] + genApproximants(1,0,c.value.whole,1,c.value.fract) + + convergents c == + empty? c.value.fract => concat(c.value.whole::Q, empty()) + genConvergents (1,0,c.value.whole,1,c.value.fract) + + numerators c == + empty? c.value.fract => concat(c.value.whole, empty()) + genNumDen(1,c.value.whole,c.value.fract) + + denominators c == + genNumDen(0,1,c.value.fract) + + extend(x,n) == (extend(x.value.fract,n); x) + + complete(x) == (complete(x.value.fract); x) + + iGenApproximants(pm2,qm2,pm1,qm1,fr) == delay + nd := frst fr + pm := nd.num*pm2 + nd.den*pm1 + qm := nd.num*qm2 + nd.den*qm1 + genApproximants(pm1,qm1,pm,qm,rst fr) + + genApproximants(pm2,qm2,pm1,qm1,fr) == + empty? fr => repeating [pm1/qm1] + concat(pm1/qm1,iGenApproximants(pm2,qm2,pm1,qm1,fr)) + + iGenConvergents(pm2,qm2,pm1,qm1,fr) == delay + nd := frst fr + pm := nd.num*pm2 + nd.den*pm1 + qm := nd.num*qm2 + nd.den*qm1 + genConvergents(pm1,qm1,pm,qm,rst fr) + + genConvergents(pm2,qm2,pm1,qm1,fr) == + empty? fr => concat(pm1/qm1, empty()) + concat(pm1/qm1,iGenConvergents(pm2,qm2,pm1,qm1,fr)) + + genNumDen(m2,m1,fr) == + empty? fr => concat(m1,empty()) + concat(m1,delay genNumDen(m1,m2*frst(fr).num + m1*frst(fr).den,rst fr)) + + gen ==> genFromSequence + + apx ==> approximants + + c, d: % + a: R + q: Q + n: Integer + + 0 == (0$R) :: % + + 1 == (1$R) :: % + + c + d == genFromSequence map((x,y) +-> x + y, apx c, apx d) + + c - d == genFromSequence map((x,y) +-> x - y, apx c, rest apx d) + + - c == genFromSequence map(x +-> - x, rest apx c) + + c * d == genFromSequence map((x,y) +-> x * y, apx c, apx d) + + a * d == genFromSequence map(x +-> a * x, apx d) + + q * d == genFromSequence map(x +-> q * x, apx d) + + n * d == genFromSequence map(x +-> n * x, apx d) + + c / d == genFromSequence map((x,y) +-> x / y, apx c, rest apx d) + + recip c ==(c = 0 => "failed"; + genFromSequence map(x +-> 1/x, rest apx c)) + + showAll?: () -> Boolean + showAll?() == + NULL(_$streamsShowAll$Lisp)$Lisp => false + true + + zagRec(t:Rec):OUT == zag(t.num :: OUT,t.den :: OUT) + + coerce(c:%): OUT == + wh := c.value.whole + fr := c.value.fract + empty? fr => wh :: OUT + count : NonNegativeInteger := _$streamCount$Lisp + l : List OUT := empty() + for n in 1..count while not empty? fr repeat + l := concat(zagRec frst fr,l) + fr := rst fr + if showAll?() then + for n in (count + 1).. while explicitEntries? fr repeat + l := concat(zagRec frst fr,l) + fr := rst fr + if not explicitlyEmpty? fr then l := concat("..." :: OUT,l) + l := reverse_! l + e := reduce("+",l) + zero? wh => e + (wh :: OUT) + e + *) \end{chunk} @@ -31237,8 +33405,8 @@ Database(S): Exports == Implementation where _+: (%,%) -> % ++ db1+db2 returns the merge of databases db1 and db2 _-: (%,%) -> % - ++ db1-db2 returns the difference of databases db1 and db2 i.e. consisting - ++ of elements in db1 but not in db2 + ++ db1-db2 returns the difference of databases db1 and db2 i.e. + ++ consisting of elements in db1 but not in db2 coerce: List S -> % ++ coerce(l) makes a database out of a list display: % -> Void @@ -31249,19 +33417,30 @@ Database(S): Exports == Implementation where ++ fullDisplay(db,start,end ) prints full details of entries in the range ++ \axiom{start..end} in \axiom{db}. Implementation == List S add + s: Symbol + Rep := List S + coerce(u: List S):% == u@% + elt(data: %,s: Symbol) == [x.s for x in data] :: DataList(String) + elt(data: %,eq: QueryEquation) == field := variable eq val := value eq [x for x in data | stringMatches?(val,x.field)$Lisp] + x+y==removeDuplicates_! merge(x,y) + x-y==mergeDifference(copy(x::Rep),y::Rep)$MergeThing(S) + coerce(data): OutputForm == (#data):: OutputForm + display(data) == for x in data repeat display x + fullDisplay(data) == for x in data repeat fullDisplay x + fullDisplay(data,n,m) == for x in data for i in 1..m repeat if i >= n then fullDisplay x @@ -31270,6 +33449,33 @@ Database(S): Exports == Implementation where \begin{chunk}{COQ DBASE} (* domain DBASE *) (* + + s: Symbol + + Rep := List S + + coerce(u: List S):% == u@% + + elt(data: %,s: Symbol) == [x.s for x in data] :: DataList(String) + + elt(data: %,eq: QueryEquation) == + field := variable eq + val := value eq + [x for x in data | stringMatches?(val,x.field)$Lisp] + + x+y==removeDuplicates_! merge(x,y) + + x-y==mergeDifference(copy(x::Rep),y::Rep)$MergeThing(S) + + coerce(data): OutputForm == (#data):: OutputForm + + display(data) == for x in data repeat display x + + fullDisplay(data) == for x in data repeat fullDisplay x + + fullDisplay(data,n,m) == for x in data for i in 1..m repeat + if i >= n then fullDisplay x + *) \end{chunk} @@ -31563,12 +33769,19 @@ DataList(S:OrderedSet) : Exports == Implementation where elt: (%,"count") -> NonNegativeInteger ++ \axiom{l."count"} returns the number of elements in \axiom{l}. Implementation == List(S) add + elt(x,"unique") == removeDuplicates(x) + elt(x,"sort") == sort(x) + elt(x,"count") == #x + coerce(x:List S) == x pretend % + coerce(x:%):List S == x pretend (List S) + coerce(x:%): OutputForm == (x :: List S) :: OutputForm + datalist(x:List S) == x::% \end{chunk} @@ -31576,6 +33789,21 @@ DataList(S:OrderedSet) : Exports == Implementation where \begin{chunk}{COQ DLIST} (* domain DLIST *) (* + + elt(x,"unique") == removeDuplicates(x) + + elt(x,"sort") == sort(x) + + elt(x,"count") == #x + + coerce(x:List S) == x pretend % + + coerce(x:%):List S == x pretend (List S) + + coerce(x:%): OutputForm == (x :: List S) :: OutputForm + + datalist(x:List S) == x::% + *) \end{chunk} @@ -31974,7 +34202,9 @@ DecimalExpansion(): Exports == Implementation where ++ decimal(r) converts a rational number to a decimal expansion. Implementation ==> RadixExpansion(10) add + decimal r == r :: % + coerce(x:%): RadixExpansion(10) == x pretend RadixExpansion(10) \end{chunk} @@ -31982,6 +34212,12 @@ DecimalExpansion(): Exports == Implementation where \begin{chunk}{COQ DECIMAL} (* domain DECIMAL *) (* + RadixExpansion(10) add + + decimal r == r :: % + + coerce(x:%): RadixExpansion(10) == x pretend RadixExpansion(10) + *) \end{chunk} @@ -34539,13 +36775,6 @@ DenavitHartenbergMatrix(R): Exports == Implementation where identity() == matrix([[1,0,0,0],[0,1,0,0],[0,0,1,0],[0,0,0,1]]) --- inverse(x) == (inverse(x pretend (Matrix R))$Matrix(R)) pretend % --- dhinverse(x) == matrix( _ --- [[nx,ny,nz,-(px*nx+py*ny+pz*nz)],_ --- [ox,oy,oz,-(px*ox+py*oy+pz*oz)],_ --- [ax,ay,az,-(px*ax+py*ay+pz*az)],_ --- [ 0, 0, 0, 1]]) - d * p == v := p pretend Vector R v := concat(v, 1$R) @@ -34567,6 +36796,26 @@ DenavitHartenbergMatrix(R): Exports == Implementation where \begin{chunk}{COQ DHMATRIX} (* domain DHMATRIX *) (* + Matrix(R) add + + identity() == matrix([[1,0,0,0],[0,1,0,0],[0,0,1,0],[0,0,0,1]]) + + d * p == + v := p pretend Vector R + v := concat(v, 1$R) + v := d * v + point ([v.1, v.2, v.3]$List(R)) + +\getchunk{rotatex} + +\getchunk{rotatey} + +\getchunk{rotatez} + +\getchunk{scale} + +\getchunk{translate} + *) \end{chunk} @@ -35739,9 +37988,13 @@ Dequeue(S:SetCategory): DequeueAggregate S with ++X count(4,a) == Queue S add + Rep := Reference List S + bottom! d == extractBottom! d + dequeue d == ref copy d + extractBottom! d == if empty? d then error "empty dequeue" p := deref d @@ -35754,21 +38007,30 @@ Dequeue(S:SetCategory): DequeueAggregate S with r := first rest q q.rest := [] r + top! d == extractTop! d + extractTop! d == if empty? d then error "empty dequeue" e := top d setref(d,rest deref d) e + height d == # deref d + depth d == # deref d + insertTop!(e,d) == (setref(d,cons(e,deref d)); e) + lastTail==> LAST$Lisp + insertBottom!(e,d) == if empty? d then setref(d, list e) else lastTail.(deref d).rest := list e e + top d == if empty? d then error "empty dequeue" else first deref d + reverse! d == (setref(d,reverse deref d); d) \end{chunk} @@ -35776,6 +38038,52 @@ Dequeue(S:SetCategory): DequeueAggregate S with \begin{chunk}{COQ DEQUEUE} (* domain DEQUEUE *) (* + Queue S add + + Rep := Reference List S + + bottom! d == extractBottom! d + + dequeue d == ref copy d + + extractBottom! d == + if empty? d then error "empty dequeue" + p := deref d + n := maxIndex p + n = 1 => + r := first p + setref(d,[]) + r + q := rest(p,(n-2)::NonNegativeInteger) + r := first rest q + q.rest := [] + r + + top! d == extractTop! d + + extractTop! d == + if empty? d then error "empty dequeue" + e := top d + setref(d,rest deref d) + e + + height d == # deref d + + depth d == # deref d + + insertTop!(e,d) == (setref(d,cons(e,deref d)); e) + + lastTail==> LAST$Lisp + + insertBottom!(e,d) == + if empty? d then setref(d, list e) + else lastTail.(deref d).rest := list e + e + + top d == if empty? d then error "empty dequeue" else first deref d + + reverse! d == (setref(d,reverse deref d); d) + *) \end{chunk} @@ -39422,6 +41730,142 @@ DeRhamComplex(CoefRing,listIndVar:List Symbol): Export == Implement where \begin{chunk}{COQ DERHAM} (* domain DERHAM *) (* + ASY add + Rep := ASY + + dim := #listIndVar + + totalDifferential(f) == + divs:=[differentiate(f,listIndVar.i)*generator(i)$ASY for i in 1..dim] + reduce("+",divs) + + termDiff : (R, %) -> % + termDiff(r,e) == + totalDifferential(r) * e + + exteriorDifferential(x) == + x = 0 => 0 + termDiff(leadingCoefficient(x)$Rep,leadingBasisTerm x) + _ + exteriorDifferential(reductum x) + + lv := [concat("d",string(liv))$String::Symbol for liv in listIndVar] + + displayList:EAB -> O + displayList(x):O == + le: L I := exponents(x)$EAB + reduce(_*,[(lv.i)::O for i in 1..dim | ((le.i) = 1)])$L(O) + + makeTerm:(R,EAB) -> O + makeTerm(r,x) == + -- we know that r ^= 0 + x = Nul(dim)$EAB => r::O + (r = 1) => displayList(x) + r::O * displayList(x) + + terms : % -> List Record(k: EAB, c: R) + terms(a) == + -- it is the case that there are at least two terms in a + a pretend List Record(k: EAB, c: R) + + err1:="CoefRing has not IntegralDomain" + err2:="Metric tensor is not symmetric" + err3:="Degenerate metric" + err4:="Index out of range" + + -- coord space dimension + dim(f) == dim + + -- flip 0->1, 1->0 + flip(b:ExtAlgBasis):ExtAlgBasis == + bl := b pretend List(NNI) + [(i+1) rem 2 for i in bl] pretend ExtAlgBasis + + -- list the positions of a's (a=0,1) in x + pos(x:EAB, a:NNI):List(NNI) == + y:= x pretend List(NNI) + [j for j in 1..#y | y.j=a] + + -- compute dot of singletons + dot1(r:Record(k:EAB,c:R),s:Record(k:EAB,c:R),g:SMR):R == + not CoefRing has IntegralDomain => error(err1) + test(r.k ^= s.k) => 0::R + idx := pos(r.k,1) + idx = [] => r.c * s.c + reduce("*",[1/g(j,j) for j in idx]::List(R))*r.c*s.c + + -- compute dot of singleton terms, general symmetric g + dot2(r:REABR, s:REABR, g:SMR):R == + not CoefRing has IntegralDomain => error(err1) + pr := pos(r.k,1) -- list positions of 1 in r + ps := pos(s.k,1) -- list positions of 1 in s + test(#pr ^= #ps) => 0::R -- not same degree => 0 + pr = [] => r.c * s.c -- empty pr,ps => product of coefs + G := inverse(g)::SMR -- compute the inverse of the metric g + test(#pr = 1) => G(pr.1,ps.1)::R * r.c * s.c -- only one element + M:Matrix(R) -- the minor + M := matrix([[G(pr.i,ps.j)::R for j in 1..#ps] for i in 1..#pr]) + determinant(M)::R * r.c * s.c + + -- export + dot(x,y,g) == + not symmetric? g => error(err2) + tx:=terms(x) + ty:=terms(y) + tx = [] or ty = [] => 0::R + if diagonal? g then -- better performance + reduce("+",[dot2(tx.j,ty.j,g) for j in 1..#tx]) + else + reduce("+",[dot1(tx.j,ty.j,g) for j in 1..#tx]) + + -- export + hodgeStar(x,g) == + not CoefRing has IntegralDomain => error(err1) + not diagonal? g => error(err2) + v := sqrt(abs(determinant(g))) -- volume factor + v = 0 => error(err3) + t:=terms(x) + s:=[copy(r) for r in t] -- we need a copy of x + for j in 1..#t repeat + s.j.k := flip(s.j.k) + fs:=[s.j] pretend % + ft:=[t.j] pretend % + s.j.c := s.j.c * v * dot1(t.j,t.j,g)/leadingCoefficient(ft*fs) + s pretend % + + -- export + proj(x,p) == + p < 0 or p > dim => error(err4) + t := terms(x) + idx := [j for j in 1..#t | #pos(t.j.k,1)=p] + s := [copy(t.j) for j in idx::List(NNI)] + s pretend % + + interiorProduct(v,x,g) == + not CoefRing has IntegralDomain => error(err1) + f := reduce("+",[generator(i)$% for i in 1..dim]::List(%)) + t := terms(f) + for j in 1..dim repeat + t.(dim-j+1).c := g(j,j)*v(j) -- reverse order + f -- term manipulations are destructive + dg:R := determinant(g) + sg:R := dg/abs(dg) + if odd?(dim) then + m:R := sg + else + m:R := (-1)**degree(x)*sg + m * hodgeStar(f*hodgeStar(x,g),g) + + lieDerivative(v,x,g) == + a:= exteriorDifferential(interiorProduct(v,x,g)) + b:= interiorProduct(v,exteriorDifferential(x),g) + a+b + + coerce(a):O == + a = 0$Rep => 0$I::O + ta := terms a + null ta.rest => makeTerm(ta.first.c, ta.first.k) + reduce(_+,[makeTerm(t.c,t.k) for t in ta])$L(O) + *) \end{chunk} @@ -39630,6 +42074,52 @@ DesingTree(S: SetCategory): T==C where \begin{chunk}{COQ DSTREE} (* domain DSTREE *) (* + Rep ==> Record(value: S, args: List %) + + fullOut(t:%): OutputForm == + empty? children t => (value t) ::OutputForm + prefix((value t)::OutputForm, [fullOut(tr) for tr in children t]) + + fullOutputFlag:Boolean:=false() + + fullOutput(f)== fullOutputFlag:=f + + fullOutput == fullOutputFlag + + leaves(t)== + empty?(chdr:=children(t)) => list(value(t)) + concat([leaves(subt) for subt in chdr]) + + t1=t2 == value t1 = value t2 and children t1 = children t2 + + coerce(t:%):OutputForm== + ^fullOutput() => encode(t) :: OutputForm + fullOut(t) + + tree(s,ls) == ([s,ls]:Rep):% + + tree(s:S) == ([s,[]]:Rep):% + + tree(ls:List(S))== + empty?(ls) => + error "Cannot create a tree with an empty list" + f:=first(ls) + empty?(rs:=rest(ls)) => + tree(f) + tree(f,[tree(rs)]) + + value t == (t:Rep).value + + children t == ((t:Rep).args):List % + + setchildren_!(t,ls) == ((t:Rep).args:=ls;t pretend %) + + setvalue_!(t,s) == ((t:Rep).value:=s;s) + + encode(t)== + empty?(chtr:=children(t)) => empty()$String + concat([concat(["U",encode(arb),"."]) for arb in chtr]) + *) \end{chunk} @@ -39955,6 +42445,7 @@ DifferentialSparseMultivariatePolynomial(R, S, V): RetractableTo SMP) Implementation ==> P add + retractIfCan(p:$):Union(SMP, "failed") == zero? order p => map(x+->retract(x)@S :: SMP,y+->y::SMP, p)$PCL( @@ -39969,6 +42460,17 @@ DifferentialSparseMultivariatePolynomial(R, S, V): \begin{chunk}{COQ DSMP} (* domain DSMP *) (* + P add + + retractIfCan(p:$):Union(SMP, "failed") == + zero? order p => + map(x+->retract(x)@S :: SMP,y+->y::SMP, p)$PCL( + IndexedExponents V, V, R, $, SMP) + "failed" + + coerce(p:SMP):$ == + map(x+->x::V::$, y+->y::$, p)$PCL(IndexedExponents S, S, R, SMP, $) + *) \end{chunk} @@ -40301,6 +42803,83 @@ DirectProduct(dim:NonNegativeInteger, R:Type): \begin{chunk}{COQ DIRPROD} (* domain DIRPROD *) (* + Vector R add + + Rep := Vector R + + coerce(z:%):Vector(R) == copy(z)$Rep pretend Vector(R) + coerce(r:R):% == new(dim, r)$Rep + + parts x == VEC2LIST(x)$Lisp + + directProduct z == + size?(z, dim) => copy(z)$Rep + error "Not of the correct length" + + + if R has SetCategory then + same?: % -> Boolean + same? z == every?(x +-> x = z(minIndex z), z) + + x = y == _and/[qelt(x,i)$Rep = qelt(y,i)$Rep for i in 1..dim] + + retract(z:%):R == + same? z => z(minIndex z) + error "Not retractable" + + retractIfCan(z:%):Union(R, "failed") == + same? z => z(minIndex z) + "failed" + + + if R has AbelianSemiGroup then + u:% + v:% == map(_+ , u, v)$Rep + + if R has AbelianMonoid then + 0 == zero(dim)$Vector(R) pretend % + + if R has Monoid then + 1 == new(dim, 1)$Vector(R) pretend % + u:% * r:R == map(x +-> x * r, u) + r:R * u:% == map(x +-> r * x, u) + x:% * y:% == [x.i * y.i for i in 1..dim]$Vector(R) pretend % + + if R has CancellationAbelianMonoid then + subtractIfCan(u:%, v:%):Union(%,"failed") == + w := new(dim,0)$Vector(R) + for i in 1..dim repeat + (c:=subtractIfCan(qelt(u, i)$Rep, qelt(v,i)$Rep)) case "failed" => + return "failed" + qsetelt_!(w, i, c::R)$Rep + w pretend % + + if R has Ring then + + u:% * v:% == map(_* , u, v)$Rep + + recip z == + w := new(dim,0)$Vector(R) + for i in minIndex w .. maxIndex w repeat + (u := recip qelt(z, i)) case "failed" => return "failed" + qsetelt_!(w, i, u::R) + w pretend % + + unitVector i == + v:= new(dim,0)$Vector(R) + v.i := 1 + v pretend % + + if R has OrderedSet then + x < y == + for i in 1..dim repeat + qelt(x,i) < qelt(y,i) => return true + qelt(x,i) > qelt(y,i) => return false + false + + if R has OrderedAbelianMonoidSup then sup(x, y) == map(sup, x, y) + +--)bo $noSubsumption := false + *) \end{chunk} @@ -40548,11 +43127,14 @@ DirectProductMatrixModule(n, R, M, S): DPcategory == DPcapsule where M: SquareMatrixCategory(n,R,RowCol,RowCol) S: LeftModule(R) - DPcategory == Join(DirectProductCategory(n,S), LeftModule(R), LeftModule(M)) + DPcategory == Join(DirectProductCategory(n,S),LeftModule(R), LeftModule(M)) DPcapsule == DirectProduct(n, S) add + Rep := Vector(S) + r:R * x:$ == [r*x.i for i in 1..n] + m:M * x:$ == [ +/[m(i,j)*x.j for j in 1..n] for i in 1..n] \end{chunk} @@ -40560,6 +43142,14 @@ DirectProductMatrixModule(n, R, M, S): DPcategory == DPcapsule where \begin{chunk}{COQ DPMM} (* domain DPMM *) (* + DirectProduct(n, S) add + + Rep := Vector(S) + + r:R * x:$ == [r*x.i for i in 1..n] + + m:M * x:$ == [ +/[m(i,j)*x.j for j in 1..n] for i in 1..n] + *) \end{chunk} @@ -40817,6 +43407,18 @@ DirectProductModule(n, R, S): DPcategory == DPcapsule where \begin{chunk}{COQ DPMO} (* domain DPMO *) (* + n: NonNegativeInteger + R: Ring + S: LeftModule(R) + + DPcategory == Join(DirectProductCategory(n,S), LeftModule(R)) + -- with if S has Algebra(R) then Algebra(R) + -- + + DPcapsule == DirectProduct(n,S) add + Rep := Vector(S) + r:R * x:$ == [r * x.i for i in 1..n] + *) \end{chunk} @@ -41248,6 +43850,102 @@ DirichletRing(Coef: Ring): \begin{chunk}{COQ DIRRING} (* domain DIRRING *) (* + + Rep := Record(function: FUN) + + per(f: Rep): % == f pretend % + rep(a: %): Rep == a pretend Rep + + elt(a: %, n: PI): Coef == + f: FUN := (rep a).function + f n + + coerce(a: %): FUN == (rep a).function + + coerce(f: FUN): % == per [f] + + indices: Stream Integer + := integers(1)$StreamTaylorSeriesOperations(Integer) + + coerce(a: %): Stream Coef == + f: FUN := (rep a).function + map((n: Integer): Coef +-> f(n::PI), indices) + $StreamFunctions2(Integer, Coef) + + coerce(f: Stream Coef): % == + ((n: PI): Coef +-> f.(n::Integer))::% + + coerce(f: %): OutputForm == f::Stream Coef::OutputForm + + 1: % == + ((n: PI): Coef +-> (if one? n then 1$Coef else 0$Coef))::% + + 0: % == + ((n: PI): Coef +-> 0$Coef)::% + + zeta: % == + ((n: PI): Coef +-> 1$Coef)::% + + (f: %) + (g: %) == + ((n: PI): Coef +-> f(n)+g(n))::% + + - (f: %) == + ((n: PI): Coef +-> -f(n))::% + + (a: Integer) * (f: %) == + ((n: PI): Coef +-> a*f(n))::% + + (a: Coef) * (f: %) == + ((n: PI): Coef +-> a*f(n))::% + + import IntegerNumberTheoryFunctions + + (f: %) * (g: %) == + conv := (n: PI): Coef +-> _ + reduce((a: Coef, b: Coef): Coef +-> a + b, _ + [f(d::PI) * g((n quo d)::PI) for d in divisors(n::Integer)], 0) + $ListFunctions2(Coef, Coef) + conv::% + + unit?(a: %): Boolean == not (recip(a(1$PI))$Coef case "failed") + + qrecip: (%, Coef, PI) -> Coef + qrecip(f: %, f1inv: Coef, n: PI): Coef == + if one? n then f1inv + else + -f1inv * reduce(_+, [f(d::PI) * qrecip(f, f1inv, (n quo d)::PI) _ + for d in rest divisors(n)], 0) _ + $ListFunctions2(Coef, Coef) + + recip f == + if (f1inv := recip(f(1$PI))$Coef) case "failed" then "failed" + else + mp := (n: PI): Coef +-> qrecip(f, f1inv, n) + + mp::%::Union(%, "failed") + + multiplicative?(a, n) == + for i in 2..n repeat + fl := factors(factor i)$Factored(Integer) + rl := [a.(((f.factor)::PI)**((f.exponent)::PI)) for f in fl] + if a.(i::PI) ~= reduce((r:Coef, s:Coef):Coef +-> r*s, rl) + then + output(i::OutputForm)$OutputPackage + output(rl::OutputForm)$OutputPackage + return false + true + + additive?(a, n) == + for i in 2..n repeat + fl := factors(factor i)$Factored(Integer) + rl := [a.(((f.factor)::PI)**((f.exponent)::PI)) for f in fl] + if a.(i::PI) ~= reduce((r:Coef, s:Coef):Coef +-> r+s, rl) + then + output(i::OutputForm)$OutputPackage + output(rl::OutputForm)$OutputPackage + return false + true + *) \end{chunk} @@ -41990,6 +44688,130 @@ Divisor(S:SetCategoryWithDegree):Exports == Implementation where \begin{chunk}{COQ DIV} (* domain DIV *) (* + List PT add + + Rep := List PT + + incr(d)== + [ [ pt.gen , pt.exp + 1 ] for pt in d ] + + inOut: PT -> OutputForm + + inOut(pp)== + one?(pp.exp) => pp.gen :: OutputForm + bl:OutputForm:= " " ::OutputForm + (pp.exp :: OutputForm) * hconcat(bl,pp.gen :: OutputForm) + + coerce(d:%):OutputForm== + zero?(d) => ("0"::OutputForm) + ll:List OutputForm:=[inOut df for df in d] + reduce("+",ll) + + reductum(d)== + zero?(d) => d + dl:Rep:= d pretend Rep + dlr := rest dl + empty?(dlr) => 0 + dlr + + head(d)== + zero?(d) => error "Cannot take head of zero" + dl:Rep:= d pretend Rep + first dl + + coerce(s:S) == [[s,1]$PT]::% + + split(a) == + zero?(a) => [] + [[r]::% for r in a] + + coefficient(s,a)== + r:INT:=0 + for pt in terms(a) repeat + if pt.gen=s then + r:=pt.exp + r + + terms(a)==a::Rep + + 0==empty()$Rep + + supp(a)== + aa:=terms(collect(a)) + [p.gen for p in aa | ^zero?(p.exp)] + + suppOfZero(a)== + aa:=terms(collect(a)) + [p.gen for p in aa | (p.exp) > 0 ] + + suppOfPole(a)== + aa:=terms(collect(a)) + [p.gen for p in aa | p.exp < 0 ] + + divOfZero(a)== + aa:=terms(collect(a)) + [p for p in aa | (p.exp) > 0 ]::% + + divOfPole(a)== + aa:=terms(collect(a)) + [p for p in aa | p.exp < 0 ]::% + + zero?(a)== + ((collect(a)::Rep)=empty()$Rep)::BOOLEAN + + collect(d)== + a:=d::Rep + empty?(a) => 0 + t:Rep:=empty() + ff:PT:=first(a) + one?(#(a)) => + if zero?(ff.exp) then + t::% + else + a::% + inList?:Boolean:=false() + newC:INT + restred:=terms(collect((rest(a)::%))) + zero?(ff.exp) => + restred::% + for bb in restred repeat + b:=bb::PT + if b.gen=ff.gen then + newC:=b.exp+ff.exp + if ^zero?(newC) then + t:=concat(t,[b.gen,newC]$PT) + inList?:=true() + else + t:=concat(t,b) + if ^inList? then + t:=cons(ff,t) + t::% + + a:% + b:% == + collect(concat(a pretend Rep,b pretend Rep)) + + a:% - b:% == + a + (-1)*b + + -a:% == (-1)*a + + n:INT * a:% == + zero?(n) => 0 + t:Rep:=empty() + for p in a pretend Rep repeat + t:=concat(t,[ p.gen, n*p.exp]$PT) + t::% + + a:% <= b:% == + bma:= b - a + effective? bma => true + false + + effective?(a)== empty?(suppOfPole(a)) + + degree(d:%):Integer== + reduce("+",[(p.exp * degree(p.gen)) for p in d @ Rep],0$INT) + *) \end{chunk} @@ -42719,7 +45541,9 @@ DoubleFloat(): Join(FloatingPointSystem, DifferentialRing, OpenMath, ++X integerDecode a == add + format: String := "~G" + MER ==> Record(MANTISSA:Integer,EXPONENT:Integer) manexp: % -> MER @@ -42783,89 +45607,160 @@ DoubleFloat(): Join(FloatingPointSystem, DifferentialRing, OpenMath, [numer,exp,sign] base() == FLOAT_-RADIX(0$%)$Lisp + mantissa x == manexp(x).MANTISSA + exponent x == manexp(x).EXPONENT + precision() == FLOAT_-DIGITS(0$%)$Lisp + bits() == base() = 2 => precision() base() = 16 => 4*precision() wholePart(precision()*log2(base()::%))::PositiveInteger + max() == MOST_-POSITIVE_-DOUBLE_-FLOAT$Lisp + min() == MOST_-NEGATIVE_-DOUBLE_-FLOAT$Lisp + order(a) == precision() + exponent a - 1 + 0 == FLOAT(0$Lisp,MOST_-POSITIVE_-DOUBLE_-FLOAT$Lisp)$Lisp + 1 == FLOAT(1$Lisp,MOST_-POSITIVE_-DOUBLE_-FLOAT$Lisp)$Lisp -- rational approximation to e accurate to 23 digits + exp1() == FLOAT(534625820200,MOST_-POSITIVE_-DOUBLE_-FLOAT$Lisp)$Lisp / _ FLOAT(196677847971,MOST_-POSITIVE_-DOUBLE_-FLOAT$Lisp)$Lisp + pi() == FLOAT(PI$Lisp,MOST_-POSITIVE_-DOUBLE_-FLOAT$Lisp)$Lisp + coerce(x:%):OutputForm == x >= 0 => message(FORMAT(NIL$Lisp,format,x)$Lisp @ String) - (message(FORMAT(NIL$Lisp,format,-x)$Lisp @ String)) + convert(x:%):InputForm == convert(x pretend DoubleFloat)$InputForm + x < y == DFLESSTHAN(x,y)$Lisp + - x == DFUNARYMINUS(x)$Lisp + x + y == DFADD(x,y)$Lisp + x:% - y:% == DFSUBTRACT(x,y)$Lisp + x:% * y:% == DFMULTIPLY(x,y)$Lisp + i:Integer * x:% == DFINTEGERMULTIPLY(i,x)$Lisp + max(x,y) == DFMAX(x,y)$Lisp + min(x,y) == DFMIN(x,y)$Lisp + x = y == DFEQL(x,y)$Lisp + x:% / i:Integer == DFINTEGERDIVIDE(x,i)$Lisp + sqrt x == checkComplex DFSQRT(x)$Lisp + log10 x == checkComplex DFLOG(x,10)$Lisp + x:% ** i:Integer == DFINTEGEREXPT(x,i)$Lisp + x:% ** y:% == checkComplex DFEXPT(x,y)$Lisp + coerce(i:Integer):% == FLOAT(i,MOST_-POSITIVE_-DOUBLE_-FLOAT$Lisp)$Lisp + exp x == DFEXP(x)$Lisp + log x == checkComplex DFLOGE(x)$Lisp + log2 x == checkComplex DFLOG(x,2)$Lisp + sin x == DFSIN(x)$Lisp + cos x == DFCOS(x)$Lisp + tan x == DFTAN(x)$Lisp + cot x == COT(x)$Lisp + sec x == SEC(x)$Lisp + csc x == CSC(x)$Lisp + asin x == checkComplex DFASIN(x)$Lisp -- can be complex + acos x == checkComplex DFACOS(x)$Lisp -- can be complex + atan x == DFATAN(x)$Lisp + acsc x == checkComplex ACSC(x)$Lisp + acot x == ACOT(x)$Lisp + asec x == checkComplex ASEC(x)$Lisp + sinh x == SINH(x)$Lisp + cosh x == COSH(x)$Lisp + tanh x == TANH(x)$Lisp + csch x == CSCH(x)$Lisp + coth x == COTH(x)$Lisp + sech x == SECH(x)$Lisp + asinh x == DFASINH(x)$Lisp + acosh x == checkComplex DFACOSH(x)$Lisp -- can be complex + atanh x == checkComplex DFATANH(x)$Lisp -- can be complex + acsch x == ACSCH(x)$Lisp + acoth x == checkComplex ACOTH(x)$Lisp + asech x == checkComplex ASECH(x)$Lisp + x:% / y:% == DFDIVIDE(x,y)$Lisp + negative? x == DFMINUSP(x)$Lisp + zero? x == ZEROP(x)$Lisp + hash x == SXHASH(x)$Lisp + recip(x) == (zero? x => "failed"; 1 / x) + differentiate x == 0 SFSFUN ==> DoubleFloatSpecialFunctions() + sfx ==> x pretend DoubleFloat + sfy ==> y pretend DoubleFloat + airyAi x == airyAi(sfx)$SFSFUN pretend % + airyBi x == airyBi(sfx)$SFSFUN pretend % + besselI(x,y) == besselI(sfx,sfy)$SFSFUN pretend % + besselJ(x,y) == besselJ(sfx,sfy)$SFSFUN pretend % + besselK(x,y) == besselK(sfx,sfy)$SFSFUN pretend % + besselY(x,y) == besselY(sfx,sfy)$SFSFUN pretend % + Beta(x,y) == Beta(sfx,sfy)$SFSFUN pretend % + digamma x == digamma(sfx)$SFSFUN pretend % + Gamma x == Gamma(sfx)$SFSFUN pretend % --- not implemented in SFSFUN --- Gamma(x,y) == Gamma(sfx,sfy)$SFSFUN pretend % + polygamma(x,y) == if (n := retractIfCan(x@%)@Union(Integer, "failed")) case Integer _ and n >= 0 @@ -42873,9 +45768,13 @@ DoubleFloat(): Join(FloatingPointSystem, DifferentialRing, OpenMath, else error "polygamma: first argument should be a nonnegative integer" wholePart x == TRUNCATE(x)$Lisp + float(ma,ex,b) == ma*(b::%)**ex + convert(x:%):DoubleFloat == x pretend DoubleFloat + convert(x:%):Float == convert(x pretend DoubleFloat)$Float + rationalApproximation(x, d) == rationalApproximation(x, d, 10) atan(x,y) == @@ -42915,24 +45814,6 @@ DoubleFloat(): Join(FloatingPointSystem, DifferentialRing, OpenMath, two53:= base()**precision() [s*wholePart(two53 * me.man ),me.exp-precision()] --- rationalApproximation(y,d,b) == --- this is the quotient remainder algorithm (requires wholePart operation) --- x := y --- if b < 2 then error "base must be > 1" --- tol := (b::%)**d --- p0,p1,q0,q1 : Integer --- p0 := 0; p1 := 1; q0 := 1; q1 := 0 --- repeat --- a := wholePart x --- x := fractionPart x --- p2 := p0+a*p1 --- q2 := q0+a*q1 --- if x = 0 or tol*abs(q2*y-(p2::%)) < abs(q2*y) then --- return (p2/q2) --- (p0,p1) := (p1,p2) --- (q0,q1) := (q1,q2) --- x := 1/x - rationalApproximation(f,d,b) == -- this algorithm expresses f as n / d where d = BASE ** k -- then all arithmetic operations are done over the integers @@ -42958,9 +45839,7 @@ DoubleFloat(): Join(FloatingPointSystem, DifferentialRing, OpenMath, zero? r => error "0**0 is undefined" negative? r => error "division by 0" 0 --- zero? r or one? x => 1 zero? r or (x = 1) => 1 --- one? r => x (r = 1) => x n := numer r d := denom r @@ -42977,6 +45856,316 @@ DoubleFloat(): Join(FloatingPointSystem, DifferentialRing, OpenMath, \begin{chunk}{COQ DFLOAT} (* domain DFLOAT *) (* + + format: String := "~G" + + MER ==> Record(MANTISSA:Integer,EXPONENT:Integer) + + manexp: % -> MER + + doubleFloatFormat(s:String): String == + ss: String := format + format := s + ss + + OMwrite(x: %): String == + s: String := "" + sp := OM_-STRINGTOSTRINGPTR(s)$Lisp + dev: OpenMathDevice := OMopenString(sp @ String, OMencodingXML) + OMputObject(dev) + OMputFloat(dev, convert x) + OMputEndObject(dev) + OMclose(dev) + s := OM_-STRINGPTRTOSTRING(sp)$Lisp @ String + s + + OMwrite(x: %, wholeObj: Boolean): String == + s: String := "" + sp := OM_-STRINGTOSTRINGPTR(s)$Lisp + dev: OpenMathDevice := OMopenString(sp @ String, OMencodingXML) + if wholeObj then + OMputObject(dev) + OMputFloat(dev, convert x) + if wholeObj then + OMputEndObject(dev) + OMclose(dev) + s := OM_-STRINGPTRTOSTRING(sp)$Lisp @ String + s + + OMwrite(dev: OpenMathDevice, x: %): Void == + OMputObject(dev) + OMputFloat(dev, convert x) + OMputEndObject(dev) + + OMwrite(dev: OpenMathDevice, x: %, wholeObj: Boolean): Void == + if wholeObj then + OMputObject(dev) + OMputFloat(dev, convert x) + if wholeObj then + OMputEndObject(dev) + + checkComplex(x:%):% == C_-TO_-R(x)$Lisp + -- In AKCL we used to have to make the arguments to ASIN ACOS ACOSH ATANH + -- complex to get the correct behaviour. + --makeComplex(x: %):% == COMPLEX(x, 0$%)$Lisp + + machineFraction(df:%):Fraction(Integer) == + numer:Integer:=INTEGER_-DECODE_-FLOAT_-NUMERATOR(df)$Lisp + denom:Integer:=INTEGER_-DECODE_-FLOAT_-DENOMINATOR(df)$Lisp + sign:Integer:=INTEGER_-DECODE_-FLOAT_-SIGN(df)$Lisp + sign*numer/denom + + integerDecode(df:%):List(Integer) == + numer:Integer:=INTEGER_-DECODE_-FLOAT_-NUMERATOR(df)$Lisp + exp:Integer:=INTEGER_-DECODE_-FLOAT_-EXPONENT(df)$Lisp + sign:Integer:=INTEGER_-DECODE_-FLOAT_-SIGN(df)$Lisp + [numer,exp,sign] + + base() == FLOAT_-RADIX(0$%)$Lisp + + mantissa x == manexp(x).MANTISSA + + exponent x == manexp(x).EXPONENT + + precision() == FLOAT_-DIGITS(0$%)$Lisp + + bits() == + base() = 2 => precision() + base() = 16 => 4*precision() + wholePart(precision()*log2(base()::%))::PositiveInteger + + max() == MOST_-POSITIVE_-DOUBLE_-FLOAT$Lisp + + min() == MOST_-NEGATIVE_-DOUBLE_-FLOAT$Lisp + + order(a) == precision() + exponent a - 1 + + 0 == FLOAT(0$Lisp,MOST_-POSITIVE_-DOUBLE_-FLOAT$Lisp)$Lisp + + 1 == FLOAT(1$Lisp,MOST_-POSITIVE_-DOUBLE_-FLOAT$Lisp)$Lisp + -- rational approximation to e accurate to 23 digits + + exp1() == FLOAT(534625820200,MOST_-POSITIVE_-DOUBLE_-FLOAT$Lisp)$Lisp / _ + FLOAT(196677847971,MOST_-POSITIVE_-DOUBLE_-FLOAT$Lisp)$Lisp + + pi() == FLOAT(PI$Lisp,MOST_-POSITIVE_-DOUBLE_-FLOAT$Lisp)$Lisp + + coerce(x:%):OutputForm == + x >= 0 => message(FORMAT(NIL$Lisp,format,x)$Lisp @ String) + - (message(FORMAT(NIL$Lisp,format,-x)$Lisp @ String)) + + convert(x:%):InputForm == convert(x pretend DoubleFloat)$InputForm + + x < y == DFLESSTHAN(x,y)$Lisp + + - x == DFUNARYMINUS(x)$Lisp + + x + y == DFADD(x,y)$Lisp + + x:% - y:% == DFSUBTRACT(x,y)$Lisp + + x:% * y:% == DFMULTIPLY(x,y)$Lisp + + i:Integer * x:% == DFINTEGERMULTIPLY(i,x)$Lisp + + max(x,y) == DFMAX(x,y)$Lisp + + min(x,y) == DFMIN(x,y)$Lisp + + x = y == DFEQL(x,y)$Lisp + + x:% / i:Integer == DFINTEGERDIVIDE(x,i)$Lisp + + sqrt x == checkComplex DFSQRT(x)$Lisp + + log10 x == checkComplex DFLOG(x,10)$Lisp + + x:% ** i:Integer == DFINTEGEREXPT(x,i)$Lisp + + x:% ** y:% == checkComplex DFEXPT(x,y)$Lisp + + coerce(i:Integer):% == FLOAT(i,MOST_-POSITIVE_-DOUBLE_-FLOAT$Lisp)$Lisp + + exp x == DFEXP(x)$Lisp + + log x == checkComplex DFLOGE(x)$Lisp + + log2 x == checkComplex DFLOG(x,2)$Lisp + + sin x == DFSIN(x)$Lisp + + cos x == DFCOS(x)$Lisp + + tan x == DFTAN(x)$Lisp + + cot x == COT(x)$Lisp + + sec x == SEC(x)$Lisp + + csc x == CSC(x)$Lisp + + asin x == checkComplex DFASIN(x)$Lisp -- can be complex + + acos x == checkComplex DFACOS(x)$Lisp -- can be complex + + atan x == DFATAN(x)$Lisp + + acsc x == checkComplex ACSC(x)$Lisp + + acot x == ACOT(x)$Lisp + + asec x == checkComplex ASEC(x)$Lisp + + sinh x == SINH(x)$Lisp + + cosh x == COSH(x)$Lisp + + tanh x == TANH(x)$Lisp + + csch x == CSCH(x)$Lisp + + coth x == COTH(x)$Lisp + + sech x == SECH(x)$Lisp + + asinh x == DFASINH(x)$Lisp + + acosh x == checkComplex DFACOSH(x)$Lisp -- can be complex + + atanh x == checkComplex DFATANH(x)$Lisp -- can be complex + + acsch x == ACSCH(x)$Lisp + + acoth x == checkComplex ACOTH(x)$Lisp + + asech x == checkComplex ASECH(x)$Lisp + + x:% / y:% == DFDIVIDE(x,y)$Lisp + + negative? x == DFMINUSP(x)$Lisp + + zero? x == ZEROP(x)$Lisp + + hash x == SXHASH(x)$Lisp + + recip(x) == (zero? x => "failed"; 1 / x) + + differentiate x == 0 + + SFSFUN ==> DoubleFloatSpecialFunctions() + + sfx ==> x pretend DoubleFloat + + sfy ==> y pretend DoubleFloat + + airyAi x == airyAi(sfx)$SFSFUN pretend % + + airyBi x == airyBi(sfx)$SFSFUN pretend % + + besselI(x,y) == besselI(sfx,sfy)$SFSFUN pretend % + + besselJ(x,y) == besselJ(sfx,sfy)$SFSFUN pretend % + + besselK(x,y) == besselK(sfx,sfy)$SFSFUN pretend % + + besselY(x,y) == besselY(sfx,sfy)$SFSFUN pretend % + + Beta(x,y) == Beta(sfx,sfy)$SFSFUN pretend % + + digamma x == digamma(sfx)$SFSFUN pretend % + + Gamma x == Gamma(sfx)$SFSFUN pretend % + + polygamma(x,y) == + if (n := retractIfCan(x@%)@Union(Integer, "failed")) case Integer _ + and n >= 0 + then polygamma(n::Integer::NonNegativeInteger,sfy)$SFSFUN pretend % + else error "polygamma: first argument should be a nonnegative integer" + + wholePart x == TRUNCATE(x)$Lisp + + float(ma,ex,b) == ma*(b::%)**ex + + convert(x:%):DoubleFloat == x pretend DoubleFloat + + convert(x:%):Float == convert(x pretend DoubleFloat)$Float + + rationalApproximation(x, d) == rationalApproximation(x, d, 10) + + atan(x,y) == + x = 0 => + y > 0 => pi()/2 + y < 0 => -pi()/2 + 0 + -- Only count on first quadrant being on principal branch. + theta := atan abs(y/x) + if x < 0 then theta := pi() - theta + if y < 0 then theta := - theta + theta + + retract(x:%):Fraction(Integer) == + rationalApproximation(x, (precision() - 1)::NonNegativeInteger, base()) + + retractIfCan(x:%):Union(Fraction Integer, "failed") == + rationalApproximation(x, (precision() - 1)::NonNegativeInteger, base()) + + retract(x:%):Integer == + x = ((n := wholePart x)::%) => n + error "Not an integer" + + retractIfCan(x:%):Union(Integer, "failed") == + x = ((n := wholePart x)::%) => n + "failed" + + sign(x) == retract FLOAT_-SIGN(x,1)$Lisp + + abs x == FLOAT_-SIGN(1,x)$Lisp + + manexp(x) == + zero? x => [0,0] + s := sign x; x := abs x + if x > max()$% then return [s*mantissa(max())+1,exponent max()] + me:Record(man:%,exp:Integer) := MANEXP(x)$Lisp + two53:= base()**precision() + [s*wholePart(two53 * me.man ),me.exp-precision()] + + rationalApproximation(f,d,b) == + -- this algorithm expresses f as n / d where d = BASE ** k + -- then all arithmetic operations are done over the integers + (nu, ex) := manexp f + BASE := base() + ex >= 0 => (nu * BASE ** (ex::NonNegativeInteger))::Fraction(Integer) + de :Integer := BASE**((-ex)::NonNegativeInteger) + b < 2 => error "base must be > 1" + tol := b**d + s := nu; t := de + p0:Integer := 0; p1:Integer := 1; q0:Integer := 1; q1:Integer := 0 + repeat + (q,r) := divide(s, t) + p2 := q*p1+p0 + q2 := q*q1+q0 + r = 0 or tol*abs(nu*q2-de*p2) < de*abs(p2) => return(p2/q2) + (p0,p1) := (p1,p2) + (q0,q1) := (q1,q2) + (s,t) := (t,r) + + x:% ** r:Fraction Integer == + zero? x => + zero? r => error "0**0 is undefined" + negative? r => error "division by 0" + 0 + zero? r or (x = 1) => 1 + (r = 1) => x + n := numer r + d := denom r + negative? x => + odd? d => + odd? n => return -((-x)**r) + return ((-x)**r) + error "negative root" + d = 2 => sqrt(x) ** n + x ** (n::% / d::%) + *) \end{chunk} @@ -43283,24 +46472,37 @@ DoubleFloatMatrix : MatrixCategory(DoubleFloat, == add Qelt2 ==> DAREF2$Lisp + Qsetelt2 ==> DSETAREF2$Lisp + Qnrows ==> DANROWS$Lisp + Qncols ==> DANCOLS$Lisp + Qnew ==> MAKE_-DOUBLE_-MATRIX$Lisp + Qnew1 ==> MAKE_-DOUBLE_-MATRIX1$Lisp minRowIndex x == 0 + minColIndex x == 0 + nrows x == Qnrows(x) + ncols x == Qncols(x) + maxRowIndex x == Qnrows(x) - 1 + maxColIndex x == Qncols(x) - 1 qelt(m, i, j) == Qelt2(m, i, j) + qsetelt_!(m, i, j, r) == Qsetelt2(m, i, j, r) empty() == Qnew(0$Integer, 0$Integer) + qnew(rows, cols) == Qnew(rows, cols) + new(rows, cols, a) == Qnew1(rows, cols, a) \end{chunk} @@ -43308,6 +46510,41 @@ DoubleFloatMatrix : MatrixCategory(DoubleFloat, \begin{chunk}{COQ DFMAT} (* domain DFMAT *) (* + + Qelt2 ==> DAREF2$Lisp + + Qsetelt2 ==> DSETAREF2$Lisp + + Qnrows ==> DANROWS$Lisp + + Qncols ==> DANCOLS$Lisp + + Qnew ==> MAKE_-DOUBLE_-MATRIX$Lisp + + Qnew1 ==> MAKE_-DOUBLE_-MATRIX1$Lisp + + minRowIndex x == 0 + + minColIndex x == 0 + + nrows x == Qnrows(x) + + ncols x == Qncols(x) + + maxRowIndex x == Qnrows(x) - 1 + + maxColIndex x == Qncols(x) - 1 + + qelt(m, i, j) == Qelt2(m, i, j) + + qsetelt_!(m, i, j, r) == Qsetelt2(m, i, j, r) + + empty() == Qnew(0$Integer, 0$Integer) + + qnew(rows, cols) == Qnew(rows, cols) + + new(rows, cols, a) == Qnew1(rows, cols, a) + *) \end{chunk} @@ -43602,23 +46839,37 @@ DoubleFloatVector : VectorCategory DoubleFloat with == add Qelt1 ==> DELT$Lisp + Qsetelt1 ==> DSETELT$Lisp qelt(x, i) == Qelt1(x, i) + qsetelt_!(x, i, s) == Qsetelt1(x, i, s) + Qsize ==> DLEN$Lisp + Qnew ==> MAKE_-DOUBLE_-VECTOR$Lisp + Qnew1 ==> MAKE_-DOUBLE_-VECTOR1$Lisp #x == Qsize x + minIndex x == 0 + empty() == Qnew(0$Lisp) + qnew(n) == Qnew(n) + new(n, x) == Qnew1(n, x) + qelt(x, i) == Qelt1(x, i) + elt(x:%, i:Integer) == Qelt1(x, i) + qsetelt_!(x, i, s) == Qsetelt1(x, i, s) + setelt(x : %, i : Integer, s : DoubleFloat) == Qsetelt1(x, i, s) + fill_!(x, s) == for i in 0..((Qsize(x)) - 1) repeat Qsetelt1(x, i, s) x @@ -43628,6 +46879,43 @@ DoubleFloatVector : VectorCategory DoubleFloat with \begin{chunk}{COQ DFVEC} (* domain DFVEC *) (* + + Qelt1 ==> DELT$Lisp + + Qsetelt1 ==> DSETELT$Lisp + + qelt(x, i) == Qelt1(x, i) + + qsetelt_!(x, i, s) == Qsetelt1(x, i, s) + + Qsize ==> DLEN$Lisp + + Qnew ==> MAKE_-DOUBLE_-VECTOR$Lisp + + Qnew1 ==> MAKE_-DOUBLE_-VECTOR1$Lisp + + #x == Qsize x + + minIndex x == 0 + + empty() == Qnew(0$Lisp) + + qnew(n) == Qnew(n) + + new(n, x) == Qnew1(n, x) + + qelt(x, i) == Qelt1(x, i) + + elt(x:%, i:Integer) == Qelt1(x, i) + + qsetelt_!(x, i, s) == Qsetelt1(x, i, s) + + setelt(x : %, i : Integer, s : DoubleFloat) == Qsetelt1(x, i, s) + + fill_!(x, s) == + for i in 0..((Qsize(x)) - 1) repeat Qsetelt1(x, i, s) + x + *) \end{chunk} @@ -43885,30 +47173,45 @@ DrawOption(): Exports == Implementation where ["viewpoint"::Symbol, vp::Any] title s == ["title"::Symbol, s::Any] + style s == ["style"::Symbol, s::Any] + toScale b == ["toScale"::Symbol, b::Any] + clip(b:Boolean) == ["clipBoolean"::Symbol, b::Any] + adaptive b == ["adaptive"::Symbol, b::Any] pointColor(x:Float) == ["pointColorFloat"::Symbol, x::Any] + pointColor(c:PAL) == ["pointColorPalette"::Symbol, c::Any] + curveColor(x:Float) == ["curveColorFloat"::Symbol, x::Any] + curveColor(c:PAL) == ["curveColorPalette"::Symbol, c::Any] + colorFunction(f:SF -> SF) == ["colorFunction1"::Symbol, f::Any] + colorFunction(f:(SF,SF) -> SF) == ["colorFunction2"::Symbol, f::Any] + colorFunction(f:(SF,SF,SF) -> SF) == ["colorFunction3"::Symbol, f::Any] + clip(tup:List SEG) == length tup > 3 => error "clip: at most 3 segments may be specified" ["clipSegment"::Symbol, tup::Any] + coordinates f == ["coordinates"::Symbol, f::Any] + tubeRadius x == ["tubeRadius"::Symbol, x::Any] + range(tup:List Segment Float) == ((n := length tup) > 3) => error "range: at most 3 segments may be specified" n < 2 => error "range: at least 2 segments may be specified" ["rangeFloat"::Symbol, tup::Any] + range(tup:List Segment Fraction Integer) == ((n := lengthR tup) > 3) => error "range: at most 3 segments may be specified" @@ -43917,13 +47220,21 @@ DrawOption(): Exports == Implementation where ["rangeRat"::Symbol, tup::Any] ranges s == ["ranges"::Symbol, s::Any] + space s == ["space"::Symbol, s::Any] + var1Steps s == ["var1Steps"::Symbol, s::Any] + var2Steps s == ["var2Steps"::Symbol, s::Any] + tubePoints s == ["tubePoints"::Symbol, s::Any] + coord s == ["coord"::Symbol, s::Any] + unit s == ["unit"::Symbol, s::Any] + coerce(x:%):OutputForm == x.keyword::OutputForm = x.value::OutputForm + x:% = y:% == x.keyword = y.keyword and x.value = y.value option?(l, s) == @@ -43941,6 +47252,117 @@ DrawOption(): Exports == Implementation where \begin{chunk}{COQ DROPT} (* domain DROPT *) (* + import AnyFunctions1(String) + import AnyFunctions1(Segment Float) + import AnyFunctions1(VIEWPT) + import AnyFunctions1(List Segment Float) + import AnyFunctions1(List Segment Fraction Integer) + import AnyFunctions1(List Integer) + import AnyFunctions1(PositiveInteger) + import AnyFunctions1(Boolean) + import AnyFunctions1(RANGE) + import AnyFunctions1(UNIT) + import AnyFunctions1(Float) + import AnyFunctions1(POINT -> POINT) + import AnyFunctions1(SF -> SF) + import AnyFunctions1((SF,SF) -> SF) + import AnyFunctions1((SF,SF,SF) -> SF) + import AnyFunctions1(POINT) + import AnyFunctions1(PAL) + import AnyFunctions1(SPACE3) + + Rep := Record(keyword:Symbol, value:Any) + + length:List SEG -> NonNegativeInteger + -- these lists will become tuples in a later version + length tup == # tup + + lengthR:List Segment Fraction Integer -> NonNegativeInteger + -- these lists will become tuples in a later version + lengthR tup == # tup + + lengthI:List Integer -> NonNegativeInteger + -- these lists will become tuples in a later version + lengthI tup == # tup + + viewpoint vp == + ["viewpoint"::Symbol, vp::Any] + + title s == ["title"::Symbol, s::Any] + + style s == ["style"::Symbol, s::Any] + + toScale b == ["toScale"::Symbol, b::Any] + + clip(b:Boolean) == ["clipBoolean"::Symbol, b::Any] + + adaptive b == ["adaptive"::Symbol, b::Any] + + pointColor(x:Float) == ["pointColorFloat"::Symbol, x::Any] + + pointColor(c:PAL) == ["pointColorPalette"::Symbol, c::Any] + + curveColor(x:Float) == ["curveColorFloat"::Symbol, x::Any] + + curveColor(c:PAL) == ["curveColorPalette"::Symbol, c::Any] + + colorFunction(f:SF -> SF) == ["colorFunction1"::Symbol, f::Any] + + colorFunction(f:(SF,SF) -> SF) == ["colorFunction2"::Symbol, f::Any] + + colorFunction(f:(SF,SF,SF) -> SF) == ["colorFunction3"::Symbol, f::Any] + + clip(tup:List SEG) == + length tup > 3 => + error "clip: at most 3 segments may be specified" + ["clipSegment"::Symbol, tup::Any] + + coordinates f == ["coordinates"::Symbol, f::Any] + + tubeRadius x == ["tubeRadius"::Symbol, x::Any] + + range(tup:List Segment Float) == + ((n := length tup) > 3) => + error "range: at most 3 segments may be specified" + n < 2 => + error "range: at least 2 segments may be specified" + ["rangeFloat"::Symbol, tup::Any] + + range(tup:List Segment Fraction Integer) == + ((n := lengthR tup) > 3) => + error "range: at most 3 segments may be specified" + n < 2 => + error "range: at least 2 segments may be specified" + ["rangeRat"::Symbol, tup::Any] + + ranges s == ["ranges"::Symbol, s::Any] + + space s == ["space"::Symbol, s::Any] + + var1Steps s == ["var1Steps"::Symbol, s::Any] + + var2Steps s == ["var2Steps"::Symbol, s::Any] + + tubePoints s == ["tubePoints"::Symbol, s::Any] + + coord s == ["coord"::Symbol, s::Any] + + unit s == ["unit"::Symbol, s::Any] + + coerce(x:%):OutputForm == x.keyword::OutputForm = x.value::OutputForm + + x:% = y:% == x.keyword = y.keyword and x.value = y.value + + option?(l, s) == + for x in l repeat + x.keyword = s => return true + false + + option(l, s) == + for x in l repeat + x.keyword = s => return(x.value) + "failed" + *) \end{chunk} @@ -44071,6 +47493,43 @@ d01ajfAnnaType(): NumericalIntegrationCategory == Result add \begin{chunk}{COQ D01AJFA} (* domain D01AJFA *) (* + EF2 ==> ExpressionFunctions2 + EDF ==> Expression DoubleFloat + LDF ==> List DoubleFloat + SDF ==> Stream DoubleFloat + DF ==> DoubleFloat + FI ==> Fraction Integer + EFI ==> Expression Fraction Integer + SOCDF ==> Segment OrderedCompletion DoubleFloat + NIA ==> Record(var:Symbol,fn:EDF,range:SOCDF,abserr:DF,relerr:DF) + MDNIA ==> Record(fn:EDF,range:List SOCDF,abserr:DF,relerr:DF) + INT ==> Integer + BOP ==> BasicOperator + S ==> Symbol + ST ==> String + LST ==> List String + RT ==> RoutinesTable + Rep:=Result + import Rep, NagIntegrationPackage, d01AgentsPackage + + measure(R:RT,args:NIA) == + ext:Result := empty()$Result + pp:SDF := singularitiesOf(args) + not (empty?(pp)$SDF) => + [0.1,"d01ajf: There is a possible problem at the following point(s): " + commaSeparate(sdf2lst(pp)) ,ext] + [getMeasure(R,d01ajf :: S)$RT, + "The general routine d01ajf is our default",ext] + + numericalIntegration(args:NIA,hints:Result) == + ArgsFn := map(x+->convert(x)$DF,args.fn)$EF2(DF,Float) + b:Float := getButtonValue("d01ajf","functionEvaluations")$AttributeButtons + fEvals:INT := wholePart exp(1.1513*(1.0/(2.0*(1.0-b)))) + iw:INT := 75*fEvals + f : Union(fn:FileName,fp:Asp1(F)) := [retract(ArgsFn)$Asp1(F)] + d01ajf(getlo(args.range),gethi(args.range),args.abserr,_ + args.relerr,4*iw,iw,-1,f) + *) \end{chunk} @@ -44206,6 +47665,48 @@ d01akfAnnaType(): NumericalIntegrationCategory == Result add \begin{chunk}{COQ D01AKFA} (* domain D01AKFA *) (* + EF2 ==> ExpressionFunctions2 + EDF ==> Expression DoubleFloat + LDF ==> List DoubleFloat + SDF ==> Stream DoubleFloat + DF ==> DoubleFloat + FI ==> Fraction Integer + EFI ==> Expression Fraction Integer + SOCDF ==> Segment OrderedCompletion DoubleFloat + NIA ==> Record(var:Symbol,fn:EDF,range:SOCDF,abserr:DF,relerr:DF) + MDNIA ==> Record(fn:EDF,range:List SOCDF,abserr:DF,relerr:DF) + INT ==> Integer + BOP ==> BasicOperator + S ==> Symbol + ST ==> String + LST ==> List String + RT ==> RoutinesTable + Rep:=Result + import Rep, d01AgentsPackage, NagIntegrationPackage + + measure(R:RT,args:NIA) == + ext:Result := empty()$Result + pp:SDF := singularitiesOf(args) + not (empty?(pp)$SDF) => + [0.0,"d01akf: There is a possible problem at the following point(s): " + commaSeparate(sdf2lst(pp)) ,ext] + o:Float := functionIsOscillatory(args) + one := 1.0 + m:Float := (getMeasure(R,d01akf@S)$RT)*(one-one/(one+sqrt(o)))**2 + m > 0.8 => [m,"d01akf: The expression shows much oscillation",ext] + m > 0.6 => [m,"d01akf: The expression shows some oscillation",ext] + m > 0.5 => [m,"d01akf: The expression shows little oscillation",ext] + [m,"d01akf: The expression shows little or no oscillation",ext] + + numericalIntegration(args:NIA,hints:Result) == + ArgsFn := map(x+->convert(x)$DF,args.fn)$EF2(DF,Float) + b:Float := getButtonValue("d01akf","functionEvaluations")$AttributeButtons + fEvals:INT := wholePart exp(1.1513*(1.0/(2.0*(1.0-b)))) + iw:INT := 75*fEvals + f : Union(fn:FileName,fp:Asp1(F)) := [retract(ArgsFn)$Asp1(F)] + d01akf(getlo(args.range),gethi(args.range),args.abserr,_ + args.relerr,4*iw,iw,-1,f) + *) \end{chunk} @@ -44328,7 +47829,6 @@ d01alfAnnaType(): NumericalIntegrationCategory == Result add st:ST := "Recommended is d01alf with the singularities " commaSeparate(listOfZeros) m := --- one?(numberOfZeros) => 0.4 (numberOfZeros = 1) => 0.4 getMeasure(R,d01alf@S)$RT [m, st, ext] @@ -44353,6 +47853,59 @@ d01alfAnnaType(): NumericalIntegrationCategory == Result add \begin{chunk}{COQ D01ALFA} (* domain D01ALFA *) (* + EF2 ==> ExpressionFunctions2 + EDF ==> Expression DoubleFloat + LDF ==> List DoubleFloat + SDF ==> Stream DoubleFloat + DF ==> DoubleFloat + FI ==> Fraction Integer + EFI ==> Expression Fraction Integer + SOCDF ==> Segment OrderedCompletion DoubleFloat + NIA ==> Record(var:Symbol,fn:EDF,range:SOCDF,abserr:DF,relerr:DF) + MDNIA ==> Record(fn:EDF,range:List SOCDF,abserr:DF,relerr:DF) + INT ==> Integer + BOP ==> BasicOperator + S ==> Symbol + ST ==> String + LST ==> List String + RT ==> RoutinesTable + Rep:=Result + import Rep, d01AgentsPackage, NagIntegrationPackage + + measure(R:RT,args:NIA) == + ext:Result := empty()$Result + streamOfZeros:SDF := singularitiesOf(args) + listOfZeros:LST := removeDuplicates!(sdf2lst(streamOfZeros)) + numberOfZeros:INT := # listOfZeros + (numberOfZeros > 15)@Boolean => + [0.0,"d01alf: The list of singularities is too long", ext] + positive?(numberOfZeros) => + l:LDF := entries(complete(streamOfZeros)$SDF)$SDF + lany:Any := coerce(l)$AnyFunctions1(LDF) + ex:Record(key:S,entry:Any) := [d01alfextra@S,lany] + ext := insert!(ex,ext)$Result + st:ST := "Recommended is d01alf with the singularities " + commaSeparate(listOfZeros) + m := + (numberOfZeros = 1) => 0.4 + getMeasure(R,d01alf@S)$RT + [m, st, ext] + [0.0, "d01alf: A list of suitable singularities has not been found", ext] + + numericalIntegration(args:NIA,hints:Result) == + la:Any := coerce(search((d01alfextra@S),hints)$Result)@Any + listOfZeros:LDF := retract(la)$AnyFunctions1(LDF) + l:= removeDuplicates(listOfZeros)$LDF + n:Integer := (#(l))$List(DF) + M:Matrix DF := matrix([l])$(Matrix DF) + b:Float := getButtonValue("d01alf","functionEvaluations")$AttributeButtons + fEvals:INT := wholePart exp(1.1513*(1.0/(2.0*(1.0-b)))) + iw:INT := 75*fEvals + ArgsFn := map(x+->convert(x)$DF,args.fn)$EF2(DF,Float) + f : Union(fn:FileName,fp:Asp1(F)) := [retract(ArgsFn)$Asp1(F)] + d01alf(getlo(args.range),gethi(args.range),n,M,_ + args.abserr,args.relerr,2*n*iw,n*iw,-1,f) + *) \end{chunk} @@ -44497,6 +48050,56 @@ d01amfAnnaType(): NumericalIntegrationCategory == Result add \begin{chunk}{COQ D01AMFA} (* domain D01AMFA *) (* + EF2 ==> ExpressionFunctions2 + EDF ==> Expression DoubleFloat + LDF ==> List DoubleFloat + SDF ==> Stream DoubleFloat + DF ==> DoubleFloat + FI ==> Fraction Integer + EFI ==> Expression Fraction Integer + SOCDF ==> Segment OrderedCompletion DoubleFloat + NIA ==> Record(var:Symbol,fn:EDF,range:SOCDF,abserr:DF,relerr:DF) + MDNIA ==> Record(fn:EDF,range:List SOCDF,abserr:DF,relerr:DF) + INT ==> Integer + BOP ==> BasicOperator + S ==> Symbol + ST ==> String + LST ==> List String + RT ==> RoutinesTable + Rep:=Result + import Rep, d01AgentsPackage, NagIntegrationPackage + + measure(R:RT,args:NIA) == + ext:Result := empty()$Result + Range:=rangeIsFinite(args) + pp:SDF := singularitiesOf(args) + not (empty?(pp)$SDF) => + [0.0,"d01amf: There is a possible problem at the following point(s): " + commaSeparate(sdf2lst(pp)), ext] + [getMeasure(R,d01amf@S)$RT, "d01amf is a reasonable choice if the " + "integral is infinite or semi-infinite and d01transform cannot " + "do better than using general routines",ext] + + numericalIntegration(args:NIA,hints:Result) == + r:INT + bound:DF + ArgsFn := map(x+->convert(x)$DF,args.fn)$EF2(DF,Float) + b:Float := getButtonValue("d01amf","functionEvaluations")$AttributeButtons + fEvals:INT := wholePart exp(1.1513*(1.0/(2.0*(1.0-b)))) + iw:INT := 150*fEvals + f : Union(fn:FileName,fp:Asp1(F)) := [retract(ArgsFn)$Asp1(F)] + Range:=rangeIsFinite(args) + if (Range case upperInfinite) then + bound := getlo(args.range) + r := 1 + else if (Range case lowerInfinite) then + bound := gethi(args.range) + r := -1 + else + bound := 0$DF + r := 2 + d01amf(bound,r,args.abserr,args.relerr,4*iw,iw,-1,f) + *) \end{chunk} @@ -44643,6 +48246,58 @@ d01anfAnnaType(): NumericalIntegrationCategory == Result add \begin{chunk}{COQ D01ANFA} (* domain D01ANFA *) (* + EF2 ==> ExpressionFunctions2 + EDF ==> Expression DoubleFloat + LDF ==> List DoubleFloat + SDF ==> Stream DoubleFloat + DF ==> DoubleFloat + FI ==> Fraction Integer + EFI ==> Expression Fraction Integer + SOCDF ==> Segment OrderedCompletion DoubleFloat + NIA ==> Record(var:Symbol,fn:EDF,range:SOCDF,abserr:DF,relerr:DF) + MDNIA ==> Record(fn:EDF,range:List SOCDF,abserr:DF,relerr:DF) + INT ==> Integer + BOP ==> BasicOperator + S ==> Symbol + ST ==> String + LST ==> List String + RT ==> RoutinesTable + Rep:=Result + import Rep, d01WeightsPackage, d01AgentsPackage, NagIntegrationPackage + + measure(R:RT,args:NIA) == + ext:Result := empty()$Result + weight:Union(Record(op:BOP,w:DF),"failed") := + exprHasWeightCosWXorSinWX(args) + weight case "failed" => + [0.0,"d01anf: A suitable weight has not been found", ext] + weight case Record(op:BOP,w:DF) => + wany := coerce(weight)$AnyFunctions1(Record(op:BOP,w:DF)) + ex:Record(key:S,entry:Any) := [d01anfextra@S,wany] + ext := insert!(ex,ext)$Result + ws:ST := string(name(weight.op)$BOP)$S "(" df2st(weight.w) + string(args.var)$S ")" + [getMeasure(R,d01anf@S)$RT, + "d01anf: The expression has a suitable weight:- " ws, ext] + + numericalIntegration(args:NIA,hints:Result) == + a:INT + r:Any := coerce(search((d01anfextra@S),hints)$Result)@Any + rec:Record(op:BOP,w:DF) := retract(r)$AnyFunctions1(Record(op:BOP,w:DF)) + Var := args.var :: EDF + o:BOP := rec.op + den:EDF := o((rec.w*Var)$EDF) + Argsfn:EDF := args.fn/den + if (name(o) = cos@S)@Boolean then a := 1 + else a := 2 + b:Float := getButtonValue("d01anf","functionEvaluations")$AttributeButtons + fEvals:INT := wholePart exp(1.1513*(1.0/(2.0*(1.0-b)))) + iw:INT := 75*fEvals + ArgsFn := map(x+->convert(x)$DF,Argsfn)$EF2(DF,Float) + f : Union(fn:FileName,fp:Asp1(G)) := [retract(ArgsFn)$Asp1(G)] + d01anf(getlo(args.range),gethi(args.range),rec.w,a,_ + args.abserr,args.relerr,4*iw,iw,-1,f) + *) \end{chunk} @@ -44760,7 +48415,6 @@ d01apfAnnaType(): NumericalIntegrationCategory == Result add if (a.1 > -1) then c := a.1 if (a.2 > -1) then d := a.2 l:INT := exprHasLogarithmicWeights(args) --- (zero? c) and (zero? d) and (one? l) => (zero? c) and (zero? d) and (l = 1) => [0.0,"d01apf: A suitable singularity has not been found", ext] out:LDF := [c,d,l :: DF] @@ -44803,6 +48457,69 @@ d01apfAnnaType(): NumericalIntegrationCategory == Result add \begin{chunk}{COQ D01APFA} (* domain D01APFA *) (* + EF2 ==> ExpressionFunctions2 + EDF ==> Expression DoubleFloat + LDF ==> List DoubleFloat + SDF ==> Stream DoubleFloat + DF ==> DoubleFloat + FI ==> Fraction Integer + EFI ==> Expression Fraction Integer + SOCDF ==> Segment OrderedCompletion DoubleFloat + NIA ==> Record(var:Symbol,fn:EDF,range:SOCDF,abserr:DF,relerr:DF) + MDNIA ==> Record(fn:EDF,range:List SOCDF,abserr:DF,relerr:DF) + INT ==> Integer + BOP ==> BasicOperator + S ==> Symbol + ST ==> String + LST ==> List String + RT ==> RoutinesTable + Rep:=Result + import Rep, NagIntegrationPackage, d01AgentsPackage, d01WeightsPackage + + measure(R:RT,args:NIA) == + ext:Result := empty()$Result + d := (c := 0$DF) + if ((a := exprHasAlgebraicWeight(args)) case LDF) then + if (a.1 > -1) then c := a.1 + if (a.2 > -1) then d := a.2 + l:INT := exprHasLogarithmicWeights(args) + (zero? c) and (zero? d) and (l = 1) => + [0.0,"d01apf: A suitable singularity has not been found", ext] + out:LDF := [c,d,l :: DF] + outany:Any := coerce(out)$AnyFunctions1(LDF) + ex:Record(key:S,entry:Any) := [d01apfextra@S,outany] + ext := insert!(ex,ext)$Result + st:ST := "Recommended is d01apf with c = " df2st(c) ", d = " + df2st(d) " and l = " string(l)$ST + [getMeasure(R,d01apf@S)$RT, st, ext] + + numericalIntegration(args:NIA,hints:Result) == + + Var:EDF := coerce(args.var)$EDF + la:Any := coerce(search((d01apfextra@S),hints)$Result)@Any + list:LDF := retract(la)$AnyFunctions1(LDF) + Fac1:EDF := (Var - (getlo(args.range) :: EDF))$EDF + Fac2:EDF := ((gethi(args.range) :: EDF) - Var)$EDF + c := first(list)$LDF + d := second(list)$LDF + l := (retract(third(list)$LDF)@INT)$DF + thebiz:EDF := (Fac1**(c :: EDF))*(Fac2**(d :: EDF)) + if l > 1 then + if l = 2 then + thebiz := thebiz*log(Fac1) + else if l = 3 then + thebiz := thebiz*log(Fac2) + else + thebiz := thebiz*log(Fac1)*log(Fac2) + Fn := (args.fn/thebiz)$EDF + ArgsFn := map(x+->convert(x)$DF,Fn)$EF2(DF,Float) + b:Float := getButtonValue("d01apf","functionEvaluations")$AttributeButtons + fEvals:INT := wholePart exp(1.1513*(1.0/(2.0*(1.0-b)))) + iw:INT := 75*fEvals + f : Union(fn:FileName,fp:Asp1(G)) := [retract(ArgsFn)$Asp1(G)] + d01apf(getlo(args.range),gethi(args.range),c,d,l,_ + args.abserr,args.relerr,4*iw,iw,-1,f) + *) \end{chunk} @@ -44915,7 +48632,6 @@ d01aqfAnnaType(): NumericalIntegrationCategory == Result add measure(R:RT,args:NIA) == ext:Result := empty()$Result Den := denominator(args.fn) --- one? Den => (Den = 1) => [0.0,"d01aqf: A suitable weight function has not been found", ext] listOfZeros:LDF := problemPoints(args.fn,args.var,args.range) @@ -44956,6 +48672,63 @@ d01aqfAnnaType(): NumericalIntegrationCategory == Result add \begin{chunk}{COQ D01AQFA} (* domain D01AQFA *) (* + EF2 ==> ExpressionFunctions2 + EDF ==> Expression DoubleFloat + LDF ==> List DoubleFloat + SDF ==> Stream DoubleFloat + DF ==> DoubleFloat + FI ==> Fraction Integer + EFI ==> Expression Fraction Integer + SOCDF ==> Segment OrderedCompletion DoubleFloat + NIA ==> Record(var:Symbol,fn:EDF,range:SOCDF,abserr:DF,relerr:DF) + MDNIA ==> Record(fn:EDF,range:List SOCDF,abserr:DF,relerr:DF) + INT ==> Integer + BOP ==> BasicOperator + S ==> Symbol + ST ==> String + LST ==> List String + RT ==> RoutinesTable + Rep:=Result + import Rep, d01AgentsPackage, NagIntegrationPackage + + measure(R:RT,args:NIA) == + ext:Result := empty()$Result + Den := denominator(args.fn) + (Den = 1) => + [0.0,"d01aqf: A suitable weight function has not been found", ext] + listOfZeros:LDF := problemPoints(args.fn,args.var,args.range) + numberOfZeros := (#(listOfZeros))$LDF + zero?(numberOfZeros) => + [0.0,"d01aqf: A suitable weight function has not been found", ext] + numberOfZeros = 1 => + s:SDF := singularitiesOf(args) + more?(s,1)$SDF => + [0.0,"d01aqf: Too many singularities have been found", ext] + cFloat:Float := (convert(first(listOfZeros)$LDF)@Float)$DF + cString:ST := (convert(cFloat)@ST)$Float + lany:Any := coerce(listOfZeros)$AnyFunctions1(LDF) + ex:Record(key:S,entry:Any) := [d01aqfextra@S,lany] + ext := insert!(ex,ext)$Result + [getMeasure(R,d01aqf@S)$RT, "Recommended is d01aqf with the " + "hilbertian weight function of 1/(x-c) where c = " cString, ext] + [0.0,"d01aqf: More than one factor has been found and so does not " + "have a suitable weight function",ext] + + numericalIntegration(args:NIA,hints:Result) == + Args := copy args + ca:Any := coerce(search((d01aqfextra@S),hints)$Result)@Any + c:DF := first(retract(ca)$AnyFunctions1(LDF))$LDF + ci:FI := df2fi(c)$ExpertSystemToolsPackage + Var:EFI := Args.var :: EFI + Gx:EFI := (Var-(ci::EFI))*(edf2efi(Args.fn)$ExpertSystemToolsPackage) + ArgsFn := map(x+->convert(x)$FI,Gx)$EF2(FI,Float) + b:Float := getButtonValue("d01aqf","functionEvaluations")$AttributeButtons + fEvals:INT := wholePart exp(1.1513*(1.0/(2.0*(1.0-b)))) + iw:INT := 75*fEvals + f : Union(fn:FileName,fp:Asp1(G)) := [retract(ArgsFn)$Asp1(G)] + d01aqf(getlo(Args.range),gethi(Args.range),c,_ + Args.abserr,Args.relerr,4*iw,iw,-1,f) + *) \end{chunk} @@ -45110,6 +48883,63 @@ d01asfAnnaType(): NumericalIntegrationCategory == Result add \begin{chunk}{COQ D01ASFA} (* domain D01ASFA *) (* + EF2 ==> ExpressionFunctions2 + EDF ==> Expression DoubleFloat + LDF ==> List DoubleFloat + SDF ==> Stream DoubleFloat + DF ==> DoubleFloat + FI ==> Fraction Integer + EFI ==> Expression Fraction Integer + SOCDF ==> Segment OrderedCompletion DoubleFloat + NIA ==> Record(var:Symbol,fn:EDF,range:SOCDF,abserr:DF,relerr:DF) + MDNIA ==> Record(fn:EDF,range:List SOCDF,abserr:DF,relerr:DF) + INT ==> Integer + BOP ==> BasicOperator + S ==> Symbol + ST ==> String + LST ==> List String + RT ==> RoutinesTable + Rep:=Result + import Rep, d01WeightsPackage, d01AgentsPackage, NagIntegrationPackage + + measure(R:RT,args:NIA) == + ext:Result := empty()$Result + Range := rangeIsFinite(args) + not(Range case upperInfinite) => + [0.0,"d01asf is not a suitable routine for infinite integrals",ext] + weight: Union(Record(op:BOP,w:DF),"failed") := + exprHasWeightCosWXorSinWX(args) + weight case "failed" => + [0.0,"d01asf: A suitable weight has not been found", ext] + weight case Record(op:BOP,w:DF) => + wany := coerce(weight)$AnyFunctions1(Record(op:BOP,w:DF)) + ex:Record(key:S,entry:Any) := [d01asfextra@S,wany] + ext := insert!(ex,ext)$Result + ws:ST := string(name(weight.op)$BOP)$S "(" df2st(weight.w) + string(args.var)$S ")" + [getMeasure(R,d01asf@S)$RT, + "d01asf: A suitable weight has been found:- " ws, ext] + + numericalIntegration(args:NIA,hints:Result) == + i:INT + r:Any := coerce(search((d01asfextra@S),hints)$Result)@Any + rec:Record(op:BOP,w:DF) := retract(r)$AnyFunctions1(Record(op:BOP,w:DF)) + Var := args.var :: EDF + o:BOP := rec.op + den:EDF := o((rec.w*Var)$EDF) + Argsfn:EDF := args.fn/den + if (name(o) = cos@S)@Boolean then i := 1 + else i := 2 + b:Float := getButtonValue("d01asf","functionEvaluations")$AttributeButtons + fEvals:INT := wholePart exp(1.1513*(1.0/(2.0*(1.0-b)))) + iw:INT := 75*fEvals + ArgsFn := map(x +-> convert(x)$DF,Argsfn)$EF2(DF,Float) + f : Union(fn:FileName,fp:Asp1(G)) := [retract(ArgsFn)$Asp1(G)] + err := + positive?(args.abserr) => args.abserr + args.relerr + d01asf(getlo(args.range),rec.w,i,err,50,4*iw,2*iw,-1,f) + *) \end{chunk} @@ -45252,6 +49082,54 @@ d01fcfAnnaType(): NumericalIntegrationCategory == Result add \begin{chunk}{COQ D01FCFA} (* domain D01FCFA *) (* + EF2 ==> ExpressionFunctions2 + EDF ==> Expression DoubleFloat + LDF ==> List DoubleFloat + SDF ==> Stream DoubleFloat + DF ==> DoubleFloat + FI ==> Fraction Integer + EFI ==> Expression Fraction Integer + SOCDF ==> Segment OrderedCompletion DoubleFloat + NIA ==> Record(var:Symbol,fn:EDF,range:SOCDF,abserr:DF,relerr:DF) + MDNIA ==> Record(fn:EDF,range:List SOCDF,abserr:DF,relerr:DF) + INT ==> Integer + BOP ==> BasicOperator + S ==> Symbol + ST ==> String + LST ==> List String + RT ==> RoutinesTable + Rep:=Result + import Rep, d01AgentsPackage, NagIntegrationPackage + + measure(R:RT,args:MDNIA) == + ext:Result := empty()$Result + segs := args.range + vars := variables(args.fn)$EDF + for i in 1..# vars repeat + nia:NIA := [vars.i,args.fn,segs.i,args.abserr,args.relerr] + not rangeIsFinite(nia) case finite => return + [0.0,"d01fcf is not a suitable routine for infinite integrals",ext] + [getMeasure(R,d01fcf@S)$RT, "Recommended is d01fcf", ext] + + numericalIntegration(args:MDNIA,hints:Result) == + import Integer + segs := args.range + dim := # segs + err := args.relerr + low:Matrix DF := matrix([[getlo(segs.i) for i in 1..dim]])$(Matrix DF) + high:Matrix DF := matrix([[gethi(segs.i) for i in 1..dim]])$(Matrix DF) + b:Float := getButtonValue("d01fcf","functionEvaluations")$AttributeButtons + a:Float:= exp(1.1513*(1.0/(2.0*(1.0-b)))) + alpha:INT := 2**dim+2*dim**2+2*dim+1 + d:Float := max(1.e-3,nthRoot(convert(err)@Float,4))$Float + minpts:INT := (fEvals := wholePart(a))*wholePart(alpha::Float/d) + maxpts:INT := 5*minpts + lenwrk:INT := (dim+2)*(1+(33*fEvals)) + ArgsFn := map(x+->convert(x)$DF,args.fn)$EF2(DF,Float) + f : Union(fn:FileName,fp:Asp4(FUNCTN)) := [retract(ArgsFn)$Asp4(FUNCTN)] + out:Result := d01fcf(dim,low,high,maxpts,err,lenwrk,minpts,-1,f) + changeName(finval@Symbol,result@Symbol,out) + *) \end{chunk} @@ -45396,6 +49274,56 @@ d01gbfAnnaType(): NumericalIntegrationCategory == Result add \begin{chunk}{COQ D01GBFA} (* domain D01GBFA *) (* + EF2 ==> ExpressionFunctions2 + EDF ==> Expression DoubleFloat + LDF ==> List DoubleFloat + SDF ==> Stream DoubleFloat + DF ==> DoubleFloat + FI ==> Fraction Integer + EFI ==> Expression Fraction Integer + SOCDF ==> Segment OrderedCompletion DoubleFloat + NIA ==> Record(var:Symbol,fn:EDF,range:SOCDF,abserr:DF,relerr:DF) + MDNIA ==> Record(fn:EDF,range:List SOCDF,abserr:DF,relerr:DF) + INT ==> Integer + BOP ==> BasicOperator + S ==> Symbol + ST ==> String + LST ==> List String + RT ==> RoutinesTable + Rep:=Result + import Rep, d01AgentsPackage, NagIntegrationPackage + + measure(R:RT,args:MDNIA) == + ext:Result := empty()$Result + (rel := args.relerr) < 0.01 :: DF => + [0.1, "d01gbf: The relative error requirement is too small",ext] + segs := args.range + vars := variables(args.fn)$EDF + for i in 1..# vars repeat + nia:NIA := [vars.i,args.fn,segs.i,args.abserr,rel] + not rangeIsFinite(nia) case finite => return + [0.0,"d01gbf is not a suitable routine for infinite integrals",ext] + [getMeasure(R,d01gbf@S)$RT, "Recommended is d01gbf", ext] + + numericalIntegration(args:MDNIA,hints:Result) == + import Integer + segs := args.range + dim:INT := # segs + low:Matrix DF := matrix([[getlo(segs.i) for i in 1..dim]])$(Matrix DF) + high:Matrix DF := matrix([[gethi(segs.i) for i in 1..dim]])$(Matrix DF) + b:Float := getButtonValue("d01gbf","functionEvaluations")$AttributeButtons + a:Float:= exp(1.1513*(1.0/(2.0*(1.0-b)))) + maxcls:INT := 1500*(dim+1)*(fEvals:INT := wholePart(a)) + mincls:INT := 300*fEvals + c:Float := nthRoot((maxcls::Float)/4.0,dim)$Float + lenwrk:INT := 3*dim*(d:INT := wholePart(c))+10*dim + wrkstr:Matrix DF := matrix([[0$DF for i in 1..lenwrk]])$(Matrix DF) + ArgsFn := map(x+->convert(x)$DF,args.fn)$EF2(DF,Float) + f : Union(fn:FileName,fp:Asp4(FUNCTN)) := [retract(ArgsFn)$Asp4(FUNCTN)] + out:Result := _ + d01gbf(dim,low,high,maxcls,args.relerr,lenwrk,mincls,wrkstr,-1,f) + changeName(finest@Symbol,result@Symbol,out) + *) \end{chunk} @@ -45632,6 +49560,128 @@ d01TransformFunctionType():NumericalIntegrationCategory == Result add \begin{chunk}{COQ D01TRNS} (* domain D01TRNS *) (* + Rep:=Result + import d01AgentsPackage,Rep + + rec2any(re:Record(str:ST,fn:EDF,range:SOCDF)):Any == + coerce(re)$AnyFunctions1(Record(str:ST,fn:EDF,range:SOCDF)) + + changeName(ans:Result,name:ST):Result == + sy:S := coerce(name "Answer")$S + anyAns:Any := coerce(ans)$AnyFunctions1(Result) + construct([[sy,anyAns]])$Result + + getIntegral(args:NIA,hint:HINT) : Result == + Args := copy args + Args.fn := hint.fn + Args.range := hint.range + integrate(Args::NumericalIntegrationProblem)$AnnaNumericalIntegrationPackage + + transformFunction(args:NIA) : NIA == + Args := copy args + Var := Args.var :: EFI -- coerce Symbol to EFI + NewVar:EFI := inv(Var)$EFI -- invert it + VarEqn:EEFI:=equation(Var,NewVar)$EEFI -- turn it into an equation + Afn:EFI := edf2efi(Args.fn)$ExpertSystemToolsPackage + Afn := subst(Afn,VarEqn)$EFI -- substitute into function + Var2:EFI := Var**2 + Afn:= simplify(Afn/Var2)$TranscendentalManipulations(FI,EFI) + Args.fn:= map(x+->convert(x)$FI,Afn)$EF2(FI,DF) + Args + + doit(seg:SOCDF,args:NIA):MS == + Args := copy args + Args.range := seg + measure(Args::NumericalIntegrationProblem)$AnnaNumericalIntegrationPackage + + transform(c:Boolean,args:NIA):Measure == + if c then + l := coerce(recip(lo(args.range)))@OCDF + Seg:SOCDF := segment(0$OCDF,l) + else + h := coerce(recip(hi(args.range)))@OCDF + Seg:SOCDF := segment(h,0$OCDF) + Args := transformFunction(args) + m:MS := doit(Seg,Args) + out1:ST := + "The recommendation is to transform the function and use " m.name + out2:List(HINT) := [[m.name,Args.fn,Seg,m.extra]] + out2Any:Any := coerce(out2)$AnyFunctions1(List(HINT)) + ex:Record(key:S,entry:Any) := [d01transformextra@S,out2Any] + extr:Result := construct([ex])$Result + [m.measure,out1,extr] + + split(c:PI,args:NIA):Measure == + Args := copy args + Args.relerr := Args.relerr/2 + Args.abserr := Args.abserr/2 + if (c = 1)@Boolean then + seg1:SOCDF := segment(-1$OCDF,1$OCDF) + else if (c = 2)@Boolean then + seg1 := segment(lo(Args.range),1$OCDF) + else + seg1 := segment(-1$OCDF,hi(Args.range)) + m1:MS := doit(seg1,Args) + Args := transformFunction Args + if (c = 2)@Boolean then + seg2:SOCDF := segment(0$OCDF,1$OCDF) + else if (c = 3)@Boolean then + seg2 := segment(-1$OCDF,0$OCDF) + else seg2 := seg1 + m2:MS := doit(seg2,Args) + m1m:F := m1.measure + m2m:F := m2.measure + m:F := m1m*m2m/((m1m*m2m)+(1.0-m1m)*(1.0-m2m)) + out1:ST := "The recommendation is to transform the function and use " + m1.name " and " m2.name + out2:List(HINT) := + [[m1.name,args.fn,seg1,m1.extra],[m2.name,Args.fn,seg2,m2.extra]] + out2Any:Any := coerce(out2)$AnyFunctions1(List(HINT)) + ex:Record(key:S,entry:Any) := [d01transformextra@S,out2Any] + extr:Result := construct([ex])$Result + [m,out1,extr] + + measure(R:RoutinesTable,args:NIA) == + Range:=rangeIsFinite(args) + Range case bothInfinite => split(1,args) + Range case upperInfinite => + positive?(lo(args.range))$OCDF => + transform(true,args) + split(2,args) + Range case lowerInfinite => + negative?(hi(args.range))$OCDF => + transform(false,args) + split(3,args) + + numericalIntegration(args:NIA,hints:Result) == + mainResult:DF := mainAbserr:DF := 0$DF + ans:Result := empty()$Result + hla:Any := coerce(search((d01transformextra@S),hints)$Result)@Any + hintList := retract(hla)$AnyFunctions1(List(HINT)) + methodName:ST := empty()$ST + repeat + if (empty?(hintList)$(List(HINT))) + then leave + item := first(hintList)$List(HINT) + a:Result := getIntegral(args,item) + anyRes := coerce(search((result@S),a)$Result)@Any + midResult := retract(anyRes)$AnyFunctions1(DF) + anyErr := coerce(search((abserr pretend S),a)$Result)@Any + midAbserr := retract(anyErr)$AnyFunctions1(DF) + mainResult := mainResult+midResult + mainAbserr := mainAbserr+midAbserr + if (methodName = item.str)@Boolean then + methodName := concat([item.str,"1"])$ST + else + methodName := item.str + ans := concat(ans,changeName(a,methodName))$ExpertSystemToolsPackage + hintList := rest(hintList)$(List(HINT)) + anyResult := coerce(mainResult)$AnyFunctions1(DF) + anyAbserr := coerce(mainAbserr)$AnyFunctions1(DF) + recResult:Record(key:S,entry:Any):=[result@S,anyResult] + recAbserr:Record(key:S,entry:Any):=[abserr pretend S,anyAbserr] + insert!(recAbserr,insert!(recResult,ans))$Result + *) \end{chunk} @@ -45799,6 +49849,79 @@ d02bbfAnnaType():OrdinaryDifferentialEquationsSolverCategory == Result add \begin{chunk}{COQ D02BBFA} (* domain D02BBFA *) (* + -- Runge Kutta + + EDF ==> Expression DoubleFloat + LDF ==> List DoubleFloat + MDF ==> Matrix DoubleFloat + DF ==> DoubleFloat + F ==> Float + FI ==> Fraction Integer + EFI ==> Expression Fraction Integer + SOCDF ==> Segment OrderedCompletion DoubleFloat + VEDF ==> Vector Expression DoubleFloat + VEF ==> Vector Expression Float + EF ==> Expression Float + VDF ==> Vector DoubleFloat + VMF ==> Vector MachineFloat + MF ==> MachineFloat + ODEA ==> Record(xinit:DF,xend:DF,fn:VEDF,yinit:LDF,intvals:LDF,_ + g:EDF,abserr:DF,relerr:DF) + RSS ==> Record(stiffnessFactor:F,stabilityFactor:F) + INT ==> Integer + EF2 ==> ExpressionFunctions2 + + import d02AgentsPackage, NagOrdinaryDifferentialEquationsPackage + import AttributeButtons + + accuracyCF(ode:ODEA):F == + b := getButtonValue("d02bbf","accuracy")$AttributeButtons + accuracyIntensityValue := combineFeatureCompatibility(b,accuracyIF(ode)) + accuracyIntensityValue > 0.999 => 0$F + 0.8*exp(-((10*accuracyIntensityValue)**3)$F/266)$F + + stiffnessCF(stiffnessIntensityValue:F):F == + b := getButtonValue("d02bbf","stiffness")$AttributeButtons + 0.5*exp(-(2*combineFeatureCompatibility(b,stiffnessIntensityValue))**2)$F + + stabilityCF(stabilityIntensityValue:F):F == + b := getButtonValue("d02bbf","stability")$AttributeButtons + 0.5 * cos(combineFeatureCompatibility(b,stabilityIntensityValue))$F + + expenseOfEvaluationCF(ode:ODEA):F == + b := getButtonValue("d02bbf","expense")$AttributeButtons + expenseOfEvaluationIntensityValue := + combineFeatureCompatibility(b,expenseOfEvaluationIF(ode)) + 0.35+0.2*exp(-(2.0*expenseOfEvaluationIntensityValue)**3)$F + + measure(R:RoutinesTable,args:ODEA) == + m := getMeasure(R,d02bbf :: Symbol)$RoutinesTable + ssf := stiffnessAndStabilityOfODEIF args + m := combineFeatureCompatibility(m,[accuracyCF(args), + stiffnessCF(ssf.stiffnessFactor), + expenseOfEvaluationCF(args), + stabilityCF(ssf.stabilityFactor)]) + [m,"Runge-Kutta Merson method"] + + ODESolve(ode:ODEA) == + i:LDF := ode.intvals + M := inc(# i)$INT + irelab := 0$INT + if positive?(a := ode.abserr) then + inc(irelab)$INT + if positive?(r := ode.relerr) then + inc(irelab)$INT + if positive?(a+r) then + tol:DF := a + r + else + tol := float(1,-4,10)$DF + asp7:Union(fn:FileName,fp:Asp7(FCN)) := + [retract(vedf2vef(ode.fn)$ExpertSystemToolsPackage)$Asp7(FCN)] + asp8:Union(fn:FileName,fp:Asp8(OUTPUT)) := + [coerce(ldf2vmf(i)$ExpertSystemToolsPackage)$Asp8(OUTPUT)] + d02bbf(ode.xend,M,# ode.fn,irelab,ode.xinit,matrix([ode.yinit])$MDF, + tol,-1,asp7,asp8) + *) \end{chunk} @@ -45963,6 +50086,76 @@ d02bhfAnnaType():OrdinaryDifferentialEquationsSolverCategory == Result add \begin{chunk}{COQ D02BHFA} (* domain D02BHFA *) (* + -- Runge Kutta + EDF ==> Expression DoubleFloat + LDF ==> List DoubleFloat + MDF ==> Matrix DoubleFloat + DF ==> DoubleFloat + F ==> Float + FI ==> Fraction Integer + EFI ==> Expression Fraction Integer + SOCDF ==> Segment OrderedCompletion DoubleFloat + VEDF ==> Vector Expression DoubleFloat + VEF ==> Vector Expression Float + EF ==> Expression Float + VDF ==> Vector DoubleFloat + VMF ==> Vector MachineFloat + MF ==> MachineFloat + ODEA ==> Record(xinit:DF,xend:DF,fn:VEDF,yinit:LDF,intvals:LDF,_ + g:EDF,abserr:DF,relerr:DF) + RSS ==> Record(stiffnessFactor:F,stabilityFactor:F) + INT ==> Integer + EF2 ==> ExpressionFunctions2 + + import d02AgentsPackage, NagOrdinaryDifferentialEquationsPackage + import AttributeButtons + + accuracyCF(ode:ODEA):F == + b := getButtonValue("d02bhf","accuracy")$AttributeButtons + accuracyIntensityValue := combineFeatureCompatibility(b,accuracyIF(ode)) + accuracyIntensityValue > 0.999 => 0$F + 0.8*exp(-((10*accuracyIntensityValue)**3)$F/266)$F + + stiffnessCF(stiffnessIntensityValue:F):F == + b := getButtonValue("d02bhf","stiffness")$AttributeButtons + 0.5*exp(-(2*combineFeatureCompatibility(b,stiffnessIntensityValue))**2)$F + + stabilityCF(stabilityIntensityValue:F):F == + b := getButtonValue("d02bhf","stability")$AttributeButtons + 0.5 * cos(combineFeatureCompatibility(b,stabilityIntensityValue))$F + + expenseOfEvaluationCF(ode:ODEA):F == + b := getButtonValue("d02bhf","expense")$AttributeButtons + expenseOfEvaluationIntensityValue := + combineFeatureCompatibility(b,expenseOfEvaluationIF(ode)) + 0.35+0.2*exp(-(2.0*expenseOfEvaluationIntensityValue)**3)$F + + measure(R:RoutinesTable,args:ODEA) == + m := getMeasure(R,d02bhf :: Symbol)$RoutinesTable + ssf := stiffnessAndStabilityOfODEIF args + m := combineFeatureCompatibility(m,[accuracyCF(args), + stiffnessCF(ssf.stiffnessFactor), + expenseOfEvaluationCF(args), + stabilityCF(ssf.stabilityFactor)]) + [m,"Runge-Kutta Merson method"] + + ODESolve(ode:ODEA) == + irelab := 0$INT + if positive?(a := ode.abserr) then + inc(irelab)$INT + if positive?(r := ode.relerr) then + inc(irelab)$INT + if positive?(a+r) then + tol := max(a,r)$DF + else + tol:DF := float(1,-4,10)$DF + asp7:Union(fn:FileName,fp:Asp7(FCN)) := + [retract(e:VEF := vedf2vef(ode.fn)$ExpertSystemToolsPackage)$Asp7(FCN)] + asp9:Union(fn:FileName,fp:Asp9(G)) := + [retract(edf2ef(ode.g)$ExpertSystemToolsPackage)$Asp9(G)] + d02bhf(ode.xend,# e,irelab,0$DF,ode.xinit,matrix([ode.yinit])$MDF, + tol,-1,asp9,asp7) + *) \end{chunk} @@ -46120,6 +50313,69 @@ d02cjfAnnaType():OrdinaryDifferentialEquationsSolverCategory == Result add \begin{chunk}{COQ D02CJFA} (* domain D02CJFA *) (* + -- Adams + EDF ==> Expression DoubleFloat + LDF ==> List DoubleFloat + MDF ==> Matrix DoubleFloat + DF ==> DoubleFloat + F ==> Float + FI ==> Fraction Integer + EFI ==> Expression Fraction Integer + SOCDF ==> Segment OrderedCompletion DoubleFloat + VEDF ==> Vector Expression DoubleFloat + VEF ==> Vector Expression Float + EF ==> Expression Float + VDF ==> Vector DoubleFloat + VMF ==> Vector MachineFloat + MF ==> MachineFloat + ODEA ==> Record(xinit:DF,xend:DF,fn:VEDF,yinit:LDF,intvals:LDF,_ + g:EDF,abserr:DF,relerr:DF) + RSS ==> Record(stiffnessFactor:F,stabilityFactor:F) + INT ==> Integer + EF2 ==> ExpressionFunctions2 + + import d02AgentsPackage, NagOrdinaryDifferentialEquationsPackage + + accuracyCF(ode:ODEA):F == + b := getButtonValue("d02cjf","accuracy")$AttributeButtons + accuracyIntensityValue := combineFeatureCompatibility(b,accuracyIF(ode)) + accuracyIntensityValue > 0.9999 => 0$F + 0.6*(cos(accuracyIntensityValue*(pi()$F)/2)$F)**0.755 + + stiffnessCF(ode:ODEA):F == + b := getButtonValue("d02cjf","stiffness")$AttributeButtons + ssf := stiffnessAndStabilityOfODEIF ode + stiffnessIntensityValue := + combineFeatureCompatibility(b,ssf.stiffnessFactor) + 0.5*exp(-(1.1*stiffnessIntensityValue)**3)$F + + measure(R:RoutinesTable,args:ODEA) == + m := getMeasure(R,d02cjf :: Symbol)$RoutinesTable + m := combineFeatureCompatibility(m,[accuracyCF(args), stiffnessCF(args)]) + [m,"Adams method"] + + ODESolve(ode:ODEA) == + i:LDF := ode.intvals + if empty?(i) then + i := [ode.xend] + M := inc(# i)$INT + if positive?((a := ode.abserr)*(r := ode.relerr))$DF then + ire:String := "D" + else + if positive?(a) then + ire:String := "A" + else + ire:String := "R" + tol := max(a,r)$DF + asp7:Union(fn:FileName,fp:Asp7(FCN)) := + [retract(e:VEF := vedf2vef(ode.fn)$ExpertSystemToolsPackage)$Asp7(FCN)] + asp8:Union(fn:FileName,fp:Asp8(OUTPUT)) := + [coerce(ldf2vmf(i)$ExpertSystemToolsPackage)$Asp8(OUTPUT)] + asp9:Union(fn:FileName,fp:Asp9(G)) := + [retract(edf2ef(ode.g)$ExpertSystemToolsPackage)$Asp9(G)] + d02cjf(ode.xend,M,# e,tol,ire,ode.xinit,matrix([ode.yinit])$MDF, + -1,asp9,asp7,asp8) + *) \end{chunk} @@ -46302,6 +50558,94 @@ d02ejfAnnaType():OrdinaryDifferentialEquationsSolverCategory == Result add \begin{chunk}{COQ D02EJFA} (* domain D02EJFA *) (* + -- BDF "Stiff" + EDF ==> Expression DoubleFloat + LDF ==> List DoubleFloat + MDF ==> Matrix DoubleFloat + DF ==> DoubleFloat + F ==> Float + FI ==> Fraction Integer + EFI ==> Expression Fraction Integer + SOCDF ==> Segment OrderedCompletion DoubleFloat + VEDF ==> Vector Expression DoubleFloat + VEF ==> Vector Expression Float + EF ==> Expression Float + VDF ==> Vector DoubleFloat + VMF ==> Vector MachineFloat + MF ==> MachineFloat + ODEA ==> Record(xinit:DF,xend:DF,fn:VEDF,yinit:LDF,intvals:LDF,_ + g:EDF,abserr:DF,relerr:DF) + RSS ==> Record(stiffnessFactor:F,stabilityFactor:F) + INT ==> Integer + EF2 ==> ExpressionFunctions2 + + import d02AgentsPackage, NagOrdinaryDifferentialEquationsPackage + + accuracyCF(ode:ODEA):F == + b := getButtonValue("d02ejf","accuracy")$AttributeButtons + accuracyIntensityValue := combineFeatureCompatibility(b,accuracyIF(ode)) + accuracyIntensityValue > 0.999 => 0$F + 0.5*exp(-((10*accuracyIntensityValue)**3)$F/250)$F + + intermediateResultsCF(ode:ODEA):F == + intermediateResultsIntensityValue := intermediateResultsIF(ode) + i := 0.5 * exp(-(intermediateResultsIntensityValue/1.649)**3)$F + a := accuracyCF(ode) + i+(0.5-i)*(0.5-a) + + stabilityCF(ode:ODEA):F == + b := getButtonValue("d02ejf","stability")$AttributeButtons + ssf := stiffnessAndStabilityOfODEIF ode + stabilityIntensityValue := + combineFeatureCompatibility(b,ssf.stabilityFactor) + 0.68 - 0.5 * exp(-(stabilityIntensityValue)**3)$F + + expenseOfEvaluationCF(ode:ODEA):F == + b := getButtonValue("d02ejf","expense")$AttributeButtons + expenseOfEvaluationIntensityValue := + combineFeatureCompatibility(b,expenseOfEvaluationIF(ode)) + 0.5 * exp(-(1.7*expenseOfEvaluationIntensityValue)**3)$F + + systemSizeCF(args:ODEA):F == + (1$F - systemSizeIF(args))/2.0 + + measure(R:RoutinesTable,args:ODEA) == + arg := copy args + m := getMeasure(R,d02ejf :: Symbol)$RoutinesTable + m := combineFeatureCompatibility(m,[intermediateResultsCF(arg), + accuracyCF(arg), + systemSizeCF(arg), + expenseOfEvaluationCF(arg), + stabilityCF(arg)]) + [m,"BDF method for Stiff Systems"] + + ODESolve(ode:ODEA) == + i:LDF := ode.intvals + m := inc(# i)$INT + if positive?((a := ode.abserr)*(r := ode.relerr))$DF then + ire:String := "D" + else + if positive?(a) then + ire:String := "A" + else + ire:String := "R" + if positive?(a+r)$DF then + tol := max(a,r)$DF + else + tol := float(1,-4,10)$DF + asp7:Union(fn:FileName,fp:Asp7(FCN)) := + [retract(e:VEF := vedf2vef(ode.fn)$ExpertSystemToolsPackage)$Asp7(FCN)] + asp31:Union(fn:FileName,fp:Asp31(PEDERV)) := + [retract(e)$Asp31(PEDERV)] + asp8:Union(fn:FileName,fp:Asp8(OUTPUT)) := + [coerce(ldf2vmf(i)$ExpertSystemToolsPackage)$Asp8(OUTPUT)] + asp9:Union(fn:FileName,fp:Asp9(G)) := + [retract(edf2ef(ode.g)$ExpertSystemToolsPackage)$Asp9(G)] + n:INT := # ode.yinit + iw:INT := (12+n)*n+50 + ans := d02ejf(ode.xend,m,n,ire,iw,ode.xinit,matrix([ode.yinit])$MDF, + tol,-1,asp9,asp7,asp31,asp8) + *) \end{chunk} @@ -46451,6 +50795,65 @@ d03eefAnnaType():PartialDifferentialEquationsSolverCategory == Result add \begin{chunk}{COQ D03EEFA} (* domain D03EEFA *) (* + -- 2D Elliptic PDE + LEDF ==> List Expression DoubleFloat + EDF ==> Expression DoubleFloat + LDF ==> List DoubleFloat + MDF ==> Matrix DoubleFloat + DF ==> DoubleFloat + F ==> Float + FI ==> Fraction Integer + VEF ==> Vector Expression Float + EF ==> Expression Float + MEF ==> Matrix Expression Float + NNI ==> NonNegativeInteger + INT ==> Integer + PDEC ==> Record(start:DF, finish:DF, grid:NNI, boundaryType:INT, + dStart:MDF, dFinish:MDF) + PDEB ==> Record(pde:LEDF, constraints:List PDEC, + f:List LEDF, st:String, tol:DF) + + import d03AgentsPackage, NagPartialDifferentialEquationsPackage + import ExpertSystemToolsPackage + + measure(R:RoutinesTable,args:PDEB) == + (# (args.constraints) > 2)@Boolean => + [0$F,"d03eef/d03edf is unsuitable for PDEs of order more than 2"] + elliptic?(args) => + m := getMeasure(R,d03eef :: Symbol)$RoutinesTable + [m,"d03eef/d03edf is suitable"] + [0$F,"d03eef/d03edf is unsuitable for hyperbolic or parabolic PDEs"] + + PDESolve(args:PDEB) == + xcon := first(args.constraints) + ycon := second(args.constraints) + nx := xcon.grid + ny := ycon.grid + p := args.pde + x1 := xcon.start + x2 := xcon.finish + y1 := ycon.start + y2 := ycon.finish + lda := ((4*(nx+1)*(ny+1)+2) quo 3)$INT + scheme:String := + central?((x2-x1)/2,(y2-y1)/2,args.pde) => "C" + "U" + asp73:Union(fn:FileName,fp:Asp73(PDEF)) := + [retract(vector([edf2ef u for u in p])$VEF)$Asp73(PDEF)] + asp74:Union(fn:FileName,fp:Asp74(BNDY)) := + [retract(matrix([[edf2ef v for v in w] for w in args.f])$MEF)$Asp74(BNDY)] + fde := d03eef(x1,x2,y1,y2,nx,ny,lda,scheme,-1,asp73,asp74) + ub := new(1,nx*ny,0$DF)$MDF + A := search(a::Symbol,fde)$Result + A case "failed" => empty()$Result + AA := A::Any + fdea := retract(AA)$AnyFunctions1(MDF) + r := search(rhs::Symbol,fde)$Result + r case "failed" => empty()$Result + rh := r::Any + fderhs := retract(rh)$AnyFunctions1(MDF) + d03edf(nx,ny,lda,15,args.tol,0,fdea,fderhs,ub,-1) + *) \end{chunk} @@ -46561,6 +50964,32 @@ d03fafAnnaType():PartialDifferentialEquationsSolverCategory == Result add \begin{chunk}{COQ D03FAFAs} (* domain D03FAFAs *) (* + -- 3D Helmholtz PDE + LEDF ==> List Expression DoubleFloat + EDF ==> Expression DoubleFloat + LDF ==> List DoubleFloat + MDF ==> Matrix DoubleFloat + DF ==> DoubleFloat + F ==> Float + FI ==> Fraction Integer + VEF ==> Vector Expression Float + EF ==> Expression Float + MEF ==> Matrix Expression Float + NNI ==> NonNegativeInteger + INT ==> Integer + PDEC ==> Record(start:DF, finish:DF, grid:NNI, boundaryType:INT, + dStart:MDF, dFinish:MDF) + PDEB ==> Record(pde:LEDF, constraints:List PDEC, + f:List LEDF, st:String, tol:DF) + + import d03AgentsPackage, NagPartialDifferentialEquationsPackage + import ExpertSystemToolsPackage + + measure(R:RoutinesTable,args:PDEB) == + (# (args.constraints) < 3)@Boolean => + [0$F,"d03faf is unsuitable for PDEs of order other than 3"] + [0$F,"d03faf isn't finished"] + *) \end{chunk} @@ -46828,7 +51257,6 @@ ElementaryFunctionsUnivariateLaurentSeries(Coef,UTS,ULS):_ nthRootUTS:(UTS,I) -> Union(UTS,"failed") nthRootUTS(uts,n) == -- assumed: n > 1, uts has non-zero constant term --- one? coefficient(uts,0) => uts ** inv(n::RN) coefficient(uts,0) = 1 => uts ** inv(n::RN) RATPOWERS => uts ** inv(n::RN) "failed" @@ -46849,7 +51277,6 @@ ElementaryFunctionsUnivariateLaurentSeries(Coef,UTS,ULS):_ if Coef has Field then (uls:ULS) ** (r:RN) == num := numer r; den := denom r --- one? den => uls ** num den = 1 => uls ** num deg := degree uls if zero? (coef := coefficient(uls,deg)) then @@ -46870,19 +51297,33 @@ ElementaryFunctionsUnivariateLaurentSeries(Coef,UTS,ULS):_ fcn(uts :: UTS) :: ULS expIfCan uls == applyIfCan(exp,uls) + sinIfCan uls == applyIfCan(sin,uls) + cosIfCan uls == applyIfCan(cos,uls) + asinIfCan uls == applyIfCan(asin,uls) + acosIfCan uls == applyIfCan(acos,uls) + asecIfCan uls == applyIfCan(asec,uls) + acscIfCan uls == applyIfCan(acsc,uls) + sinhIfCan uls == applyIfCan(sinh,uls) + coshIfCan uls == applyIfCan(cosh,uls) + asinhIfCan uls == applyIfCan(asinh,uls) + acoshIfCan uls == applyIfCan(acosh,uls) + atanhIfCan uls == applyIfCan(atanh,uls) + acothIfCan uls == applyIfCan(acoth,uls) + asechIfCan uls == applyIfCan(asech,uls) + acschIfCan uls == applyIfCan(acsch,uls) logIfCan uls == @@ -46994,28 +51435,51 @@ ElementaryFunctionsUnivariateLaurentSeries(Coef,UTS,ULS):_ ans :: ULS exp uls == applyOrError(expIfCan,"exp",uls) + log uls == applyOrError(logIfCan,"log",uls) + sin uls == applyOrError(sinIfCan,"sin",uls) + cos uls == applyOrError(cosIfCan,"cos",uls) + tan uls == applyOrError(tanIfCan,"tan",uls) + cot uls == applyOrError(cotIfCan,"cot",uls) + sec uls == applyOrError(secIfCan,"sec",uls) + csc uls == applyOrError(cscIfCan,"csc",uls) + asin uls == applyOrError(asinIfCan,"asin",uls) + acos uls == applyOrError(acosIfCan,"acos",uls) + asec uls == applyOrError(asecIfCan,"asec",uls) + acsc uls == applyOrError(acscIfCan,"acsc",uls) + sinh uls == applyOrError(sinhIfCan,"sinh",uls) + cosh uls == applyOrError(coshIfCan,"cosh",uls) + tanh uls == applyOrError(tanhIfCan,"tanh",uls) + coth uls == applyOrError(cothIfCan,"coth",uls) + sech uls == applyOrError(sechIfCan,"sech",uls) + csch uls == applyOrError(cschIfCan,"csch",uls) + asinh uls == applyOrError(asinhIfCan,"asinh",uls) + acosh uls == applyOrError(acoshIfCan,"acosh",uls) + atanh uls == applyOrError(atanhIfCan,"atanh",uls) + acoth uls == applyOrError(acothIfCan,"acoth",uls) + asech uls == applyOrError(asechIfCan,"asech",uls) + acsch uls == applyOrError(acschIfCan,"acsch",uls) atan uls == @@ -47066,6 +51530,284 @@ ElementaryFunctionsUnivariateLaurentSeries(Coef,UTS,ULS):_ \begin{chunk}{COQ EFULS} (* domain EFULS *) (* + +--% roots + + RATPOWERS : Boolean := Coef has "**":(Coef,RN) -> Coef + TRANSFCN : Boolean := Coef has TranscendentalFunctionCategory + RATS : Boolean := Coef has retractIfCan: Coef -> Union(RN,"failed") + + nthRootUTS:(UTS,I) -> Union(UTS,"failed") + nthRootUTS(uts,n) == + -- assumed: n > 1, uts has non-zero constant term + coefficient(uts,0) = 1 => uts ** inv(n::RN) + RATPOWERS => uts ** inv(n::RN) + "failed" + + nthRootIfCan(uls,nn) == + (n := nn :: I) < 1 => error "nthRootIfCan: n must be positive" + n = 1 => uls + deg := degree uls + if zero? (coef := coefficient(uls,deg)) then + uls := removeZeroes(1000,uls); deg := degree uls + zero? (coef := coefficient(uls,deg)) => + error "root of series with many leading zero coefficients" + (k := deg exquo n) case "failed" => "failed" + uts := taylor(uls * monomial(1,-deg)) + (root := nthRootUTS(uts,n)) case "failed" => "failed" + monomial(1,k :: I) * (root :: UTS :: ULS) + + if Coef has Field then + (uls:ULS) ** (r:RN) == + num := numer r; den := denom r + den = 1 => uls ** num + deg := degree uls + if zero? (coef := coefficient(uls,deg)) then + uls := removeZeroes(1000,uls); deg := degree uls + zero? (coef := coefficient(uls,deg)) => + error "power of series with many leading zero coefficients" + (k := deg exquo den) case "failed" => + error "**: rational power does not exist" + uts := taylor(uls * monomial(1,-deg)) ** r + monomial(1,(k :: I) * num) * (uts :: ULS) + +--% transcendental functions + + applyIfCan: (UTS -> UTS,ULS) -> Union(ULS,"failed") + applyIfCan(fcn,uls) == + uts := taylorIfCan uls + uts case "failed" => "failed" + fcn(uts :: UTS) :: ULS + + expIfCan uls == applyIfCan(exp,uls) + + sinIfCan uls == applyIfCan(sin,uls) + + cosIfCan uls == applyIfCan(cos,uls) + + asinIfCan uls == applyIfCan(asin,uls) + + acosIfCan uls == applyIfCan(acos,uls) + + asecIfCan uls == applyIfCan(asec,uls) + + acscIfCan uls == applyIfCan(acsc,uls) + + sinhIfCan uls == applyIfCan(sinh,uls) + + coshIfCan uls == applyIfCan(cosh,uls) + + asinhIfCan uls == applyIfCan(asinh,uls) + + acoshIfCan uls == applyIfCan(acosh,uls) + + atanhIfCan uls == applyIfCan(atanh,uls) + + acothIfCan uls == applyIfCan(acoth,uls) + + asechIfCan uls == applyIfCan(asech,uls) + + acschIfCan uls == applyIfCan(acsch,uls) + + logIfCan uls == + uts := taylorIfCan uls + uts case "failed" => "failed" + zero? coefficient(ts := uts :: UTS,0) => "failed" + log(ts) :: ULS + + tanIfCan uls == + -- don't call 'tan' on a UTS (tan(uls) may have a singularity) + uts := taylorIfCan uls + uts case "failed" => "failed" + sc := sincos(coefficients(uts :: UTS))$STTF + (cosInv := recip(series(sc.cos) :: ULS)) case "failed" => "failed" + (series(sc.sin) :: ULS) * (cosInv :: ULS) + + cotIfCan uls == + -- don't call 'cot' on a UTS (cot(uls) may have a singularity) + uts := taylorIfCan uls + uts case "failed" => "failed" + sc := sincos(coefficients(uts :: UTS))$STTF + (sinInv := recip(series(sc.sin) :: ULS)) case "failed" => "failed" + (series(sc.cos) :: ULS) * (sinInv :: ULS) + + secIfCan uls == + cos := cosIfCan uls + cos case "failed" => "failed" + (cosInv := recip(cos :: ULS)) case "failed" => "failed" + cosInv :: ULS + + cscIfCan uls == + sin := sinIfCan uls + sin case "failed" => "failed" + (sinInv := recip(sin :: ULS)) case "failed" => "failed" + sinInv :: ULS + + atanIfCan uls == + coef := coefficient(uls,0) + (ord := order(uls,0)) = 0 and coef * coef = -1 => "failed" + cc : Coef := + ord < 0 => + TRANSFCN => + RATS => + lc := coefficient(uls,ord) + (rat := retractIfCan(lc)@Union(RN,"failed")) case "failed" => + (1/2) * pi() + (rat :: RN) > 0 => (1/2) * pi() + (-1/2) * pi() + (1/2) * pi() + return "failed" + coef = 0 => 0 + TRANSFCN => atan coef + return "failed" + (z := recip(1 + uls*uls)) case "failed" => "failed" + (cc :: ULS) + integrate(differentiate(uls) * (z :: ULS)) + + acotIfCan uls == + coef := coefficient(uls,0) + (ord := order(uls,0)) = 0 and coef * coef = -1 => "failed" + cc : Coef := + ord < 0 => + RATS => + lc := coefficient(uls,ord) + (rat := retractIfCan(lc)@Union(RN,"failed")) case "failed" => 0 + (rat :: RN) > 0 => 0 + TRANSFCN => pi() + return "failed" + 0 + TRANSFCN => acot coef + return "failed" + (z := recip(1 + uls*uls)) case "failed" => "failed" + (cc :: ULS) - integrate(differentiate(uls) * (z :: ULS)) + + tanhIfCan uls == + -- don't call 'tanh' on a UTS (tanh(uls) may have a singularity) + uts := taylorIfCan uls + uts case "failed" => "failed" + sc := sinhcosh(coefficients(uts :: UTS))$STTF + (coshInv := recip(series(sc.cosh) :: ULS)) case "failed" => + "failed" + (series(sc.sinh) :: ULS) * (coshInv :: ULS) + + cothIfCan uls == + -- don't call 'coth' on a UTS (coth(uls) may have a singularity) + uts := taylorIfCan uls + uts case "failed" => "failed" + sc := sinhcosh(coefficients(uts :: UTS))$STTF + (sinhInv := recip(series(sc.sinh) :: ULS)) case "failed" => + "failed" + (series(sc.cosh) :: ULS) * (sinhInv :: ULS) + + sechIfCan uls == + cosh := coshIfCan uls + cosh case "failed" => "failed" + (coshInv := recip(cosh :: ULS)) case "failed" => "failed" + coshInv :: ULS + + cschIfCan uls == + sinh := sinhIfCan uls + sinh case "failed" => "failed" + (sinhInv := recip(sinh :: ULS)) case "failed" => "failed" + sinhInv :: ULS + + applyOrError:(ULS -> Union(ULS,"failed"),S,ULS) -> ULS + applyOrError(fcn,name,uls) == + ans := fcn uls + ans case "failed" => + error concat(name," of function with singularity") + ans :: ULS + + exp uls == applyOrError(expIfCan,"exp",uls) + + log uls == applyOrError(logIfCan,"log",uls) + + sin uls == applyOrError(sinIfCan,"sin",uls) + + cos uls == applyOrError(cosIfCan,"cos",uls) + + tan uls == applyOrError(tanIfCan,"tan",uls) + + cot uls == applyOrError(cotIfCan,"cot",uls) + + sec uls == applyOrError(secIfCan,"sec",uls) + + csc uls == applyOrError(cscIfCan,"csc",uls) + + asin uls == applyOrError(asinIfCan,"asin",uls) + + acos uls == applyOrError(acosIfCan,"acos",uls) + + asec uls == applyOrError(asecIfCan,"asec",uls) + + acsc uls == applyOrError(acscIfCan,"acsc",uls) + + sinh uls == applyOrError(sinhIfCan,"sinh",uls) + + cosh uls == applyOrError(coshIfCan,"cosh",uls) + + tanh uls == applyOrError(tanhIfCan,"tanh",uls) + + coth uls == applyOrError(cothIfCan,"coth",uls) + + sech uls == applyOrError(sechIfCan,"sech",uls) + + csch uls == applyOrError(cschIfCan,"csch",uls) + + asinh uls == applyOrError(asinhIfCan,"asinh",uls) + + acosh uls == applyOrError(acoshIfCan,"acosh",uls) + + atanh uls == applyOrError(atanhIfCan,"atanh",uls) + + acoth uls == applyOrError(acothIfCan,"acoth",uls) + + asech uls == applyOrError(asechIfCan,"asech",uls) + + acsch uls == applyOrError(acschIfCan,"acsch",uls) + + atan uls == + -- code is duplicated so that correct error messages will be returned + coef := coefficient(uls,0) + (ord := order(uls,0)) = 0 and coef * coef = -1 => + error "atan: series expansion has logarithmic term" + cc : Coef := + ord < 0 => + TRANSFCN => + RATS => + lc := coefficient(uls,ord) + (rat := retractIfCan(lc)@Union(RN,"failed")) case "failed" => + (1/2) * pi() + (rat :: RN) > 0 => (1/2) * pi() + (-1/2) * pi() + (1/2) * pi() + error "atan: series expansion involves transcendental constants" + coef = 0 => 0 + TRANSFCN => atan coef + error "atan: series expansion involves transcendental constants" + (z := recip(1 + uls*uls)) case "failed" => + error "atan: leading coefficient not invertible" + (cc :: ULS) + integrate(differentiate(uls) * (z :: ULS)) + + acot uls == + -- code is duplicated so that correct error messages will be returned + coef := coefficient(uls,0) + (ord := order(uls,0)) = 0 and coef * coef = -1 => + error "acot: series expansion has logarithmic term" + cc : Coef := + ord < 0 => + RATS => + lc := coefficient(uls,ord) + (rat := retractIfCan(lc)@Union(RN,"failed")) case "failed" => 0 + (rat :: RN) > 0 => 0 + TRANSFCN => pi() + error "acot: series expansion involves transcendental constants" + 0 + TRANSFCN => acot coef + error "acot: series expansion involves transcendental constants" + (z := recip(1 + uls*uls)) case "failed" => + error "acot: leading coefficient not invertible" + (cc :: ULS) - integrate(differentiate(uls) * (z :: ULS)) + *) \end{chunk} @@ -47327,7 +52069,6 @@ ElementaryFunctionsUnivariatePuiseuxSeries(Coef,ULS,UPXS,EFULS):_ --% roots nthRootIfCan(upxs,n) == --- one? n => upxs n = 1 => upxs r := rationalPower upxs; uls := laurentRep upxs deg := degree uls @@ -47342,7 +52083,6 @@ ElementaryFunctionsUnivariatePuiseuxSeries(Coef,ULS,UPXS,EFULS):_ if Coef has Field then (upxs:UPXS) ** (q:RN) == num := numer q; den := denom q --- one? den => upxs ** num den = 1 => upxs ** num r := rationalPower upxs; uls := laurentRep upxs deg := degree uls @@ -47362,26 +52102,47 @@ ElementaryFunctionsUnivariatePuiseuxSeries(Coef,ULS,UPXS,EFULS):_ puiseux(rationalPower upxs,uls :: ULS) expIfCan upxs == applyIfCan(expIfCan,upxs) + logIfCan upxs == applyIfCan(logIfCan,upxs) + sinIfCan upxs == applyIfCan(sinIfCan,upxs) + cosIfCan upxs == applyIfCan(cosIfCan,upxs) + tanIfCan upxs == applyIfCan(tanIfCan,upxs) + cotIfCan upxs == applyIfCan(cotIfCan,upxs) + secIfCan upxs == applyIfCan(secIfCan,upxs) + cscIfCan upxs == applyIfCan(cscIfCan,upxs) + atanIfCan upxs == applyIfCan(atanIfCan,upxs) + acotIfCan upxs == applyIfCan(acotIfCan,upxs) + sinhIfCan upxs == applyIfCan(sinhIfCan,upxs) + coshIfCan upxs == applyIfCan(coshIfCan,upxs) + tanhIfCan upxs == applyIfCan(tanhIfCan,upxs) + cothIfCan upxs == applyIfCan(cothIfCan,upxs) + sechIfCan upxs == applyIfCan(sechIfCan,upxs) + cschIfCan upxs == applyIfCan(cschIfCan,upxs) + asinhIfCan upxs == applyIfCan(asinhIfCan,upxs) + acoshIfCan upxs == applyIfCan(acoshIfCan,upxs) + atanhIfCan upxs == applyIfCan(atanhIfCan,upxs) + acothIfCan upxs == applyIfCan(acothIfCan,upxs) + asechIfCan upxs == applyIfCan(asechIfCan,upxs) + acschIfCan upxs == applyIfCan(acschIfCan,upxs) asinIfCan upxs == @@ -47452,30 +52213,55 @@ ElementaryFunctionsUnivariatePuiseuxSeries(Coef,ULS,UPXS,EFULS):_ ans :: UPXS exp upxs == applyOrError(expIfCan,"exp",upxs) + log upxs == applyOrError(logIfCan,"log",upxs) + sin upxs == applyOrError(sinIfCan,"sin",upxs) + cos upxs == applyOrError(cosIfCan,"cos",upxs) + tan upxs == applyOrError(tanIfCan,"tan",upxs) + cot upxs == applyOrError(cotIfCan,"cot",upxs) + sec upxs == applyOrError(secIfCan,"sec",upxs) + csc upxs == applyOrError(cscIfCan,"csc",upxs) + asin upxs == applyOrError(asinIfCan,"asin",upxs) + acos upxs == applyOrError(acosIfCan,"acos",upxs) + atan upxs == applyOrError(atanIfCan,"atan",upxs) + acot upxs == applyOrError(acotIfCan,"acot",upxs) + asec upxs == applyOrError(asecIfCan,"asec",upxs) + acsc upxs == applyOrError(acscIfCan,"acsc",upxs) + sinh upxs == applyOrError(sinhIfCan,"sinh",upxs) + cosh upxs == applyOrError(coshIfCan,"cosh",upxs) + tanh upxs == applyOrError(tanhIfCan,"tanh",upxs) + coth upxs == applyOrError(cothIfCan,"coth",upxs) + sech upxs == applyOrError(sechIfCan,"sech",upxs) + csch upxs == applyOrError(cschIfCan,"csch",upxs) + asinh upxs == applyOrError(asinhIfCan,"asinh",upxs) + acosh upxs == applyOrError(acoshIfCan,"acosh",upxs) + atanh upxs == applyOrError(atanhIfCan,"atanh",upxs) + acoth upxs == applyOrError(acothIfCan,"acoth",upxs) + asech upxs == applyOrError(asechIfCan,"asech",upxs) + acsch upxs == applyOrError(acschIfCan,"acsch",upxs) \end{chunk} @@ -47483,6 +52269,207 @@ ElementaryFunctionsUnivariatePuiseuxSeries(Coef,ULS,UPXS,EFULS):_ \begin{chunk}{COQ EFUPXS} (* domain EFUPXS *) (* + + TRANSFCN : Boolean := Coef has TranscendentalFunctionCategory + +--% roots + + nthRootIfCan(upxs,n) == + n = 1 => upxs + r := rationalPower upxs; uls := laurentRep upxs + deg := degree uls + if zero?(coef := coefficient(uls,deg)) then + deg := order(uls,deg + 1000) + zero?(coef := coefficient(uls,deg)) => + error "root of series with many leading zero coefficients" + uls := uls * monomial(1,-deg)$ULS + (ulsRoot := nthRootIfCan(uls,n)) case "failed" => "failed" + puiseux(r,ulsRoot :: ULS) * monomial(1,deg * r * inv(n :: RN)) + + if Coef has Field then + (upxs:UPXS) ** (q:RN) == + num := numer q; den := denom q + den = 1 => upxs ** num + r := rationalPower upxs; uls := laurentRep upxs + deg := degree uls + if zero?(coef := coefficient(uls,deg)) then + deg := order(uls,deg + 1000) + zero?(coef := coefficient(uls,deg)) => + error "power of series with many leading zero coefficients" + ulsPow := (uls * monomial(1,-deg)$ULS) ** q + puiseux(r,ulsPow) * monomial(1,deg*q*r) + +--% transcendental functions + + applyIfCan: (ULS -> Union(ULS,"failed"),UPXS) -> Union(UPXS,"failed") + applyIfCan(fcn,upxs) == + uls := fcn laurentRep upxs + uls case "failed" => "failed" + puiseux(rationalPower upxs,uls :: ULS) + + expIfCan upxs == applyIfCan(expIfCan,upxs) + + logIfCan upxs == applyIfCan(logIfCan,upxs) + + sinIfCan upxs == applyIfCan(sinIfCan,upxs) + + cosIfCan upxs == applyIfCan(cosIfCan,upxs) + + tanIfCan upxs == applyIfCan(tanIfCan,upxs) + + cotIfCan upxs == applyIfCan(cotIfCan,upxs) + + secIfCan upxs == applyIfCan(secIfCan,upxs) + + cscIfCan upxs == applyIfCan(cscIfCan,upxs) + + atanIfCan upxs == applyIfCan(atanIfCan,upxs) + + acotIfCan upxs == applyIfCan(acotIfCan,upxs) + + sinhIfCan upxs == applyIfCan(sinhIfCan,upxs) + + coshIfCan upxs == applyIfCan(coshIfCan,upxs) + + tanhIfCan upxs == applyIfCan(tanhIfCan,upxs) + + cothIfCan upxs == applyIfCan(cothIfCan,upxs) + + sechIfCan upxs == applyIfCan(sechIfCan,upxs) + + cschIfCan upxs == applyIfCan(cschIfCan,upxs) + + asinhIfCan upxs == applyIfCan(asinhIfCan,upxs) + + acoshIfCan upxs == applyIfCan(acoshIfCan,upxs) + + atanhIfCan upxs == applyIfCan(atanhIfCan,upxs) + + acothIfCan upxs == applyIfCan(acothIfCan,upxs) + + asechIfCan upxs == applyIfCan(asechIfCan,upxs) + + acschIfCan upxs == applyIfCan(acschIfCan,upxs) + + asinIfCan upxs == + order(upxs,0) < 0 => "failed" + (coef := coefficient(upxs,0)) = 0 => + integrate((1 - upxs*upxs)**(-1/2) * (differentiate upxs)) + TRANSFCN => + cc := asin(coef) :: UPXS + cc + integrate((1 - upxs*upxs)**(-1/2) * (differentiate upxs)) + "failed" + + acosIfCan upxs == + order(upxs,0) < 0 => "failed" + TRANSFCN => + cc := acos(coefficient(upxs,0)) :: UPXS + cc + integrate(-(1 - upxs*upxs)**(-1/2) * (differentiate upxs)) + "failed" + + asecIfCan upxs == + order(upxs,0) < 0 => "failed" + TRANSFCN => + cc := asec(coefficient(upxs,0)) :: UPXS + f := (upxs*upxs - 1)**(-1/2) * (differentiate upxs) + (rec := recip upxs) case "failed" => "failed" + cc + integrate(f * (rec :: UPXS)) + "failed" + + acscIfCan upxs == + order(upxs,0) < 0 => "failed" + TRANSFCN => + cc := acsc(coefficient(upxs,0)) :: UPXS + f := -(upxs*upxs - 1)**(-1/2) * (differentiate upxs) + (rec := recip upxs) case "failed" => "failed" + cc + integrate(f * (rec :: UPXS)) + "failed" + + asinhIfCan upxs == + order(upxs,0) < 0 => "failed" + TRANSFCN or (coefficient(upxs,0) = 0) => + log(upxs + (1 + upxs*upxs)**(1/2)) + "failed" + + acoshIfCan upxs == + TRANSFCN => + order(upxs,0) < 0 => "failed" + log(upxs + (upxs*upxs - 1)**(1/2)) + "failed" + + asechIfCan upxs == + TRANSFCN => + order(upxs,0) < 0 => "failed" + (rec := recip upxs) case "failed" => "failed" + log((1 + (1 - upxs*upxs)*(1/2)) * (rec :: UPXS)) + "failed" + + acschIfCan upxs == + TRANSFCN => + order(upxs,0) < 0 => "failed" + (rec := recip upxs) case "failed" => "failed" + log((1 + (1 + upxs*upxs)*(1/2)) * (rec :: UPXS)) + "failed" + + applyOrError:(UPXS -> Union(UPXS,"failed"),String,UPXS) -> UPXS + applyOrError(fcn,name,upxs) == + ans := fcn upxs + ans case "failed" => + error concat(name," of function with singularity") + ans :: UPXS + + exp upxs == applyOrError(expIfCan,"exp",upxs) + + log upxs == applyOrError(logIfCan,"log",upxs) + + sin upxs == applyOrError(sinIfCan,"sin",upxs) + + cos upxs == applyOrError(cosIfCan,"cos",upxs) + + tan upxs == applyOrError(tanIfCan,"tan",upxs) + + cot upxs == applyOrError(cotIfCan,"cot",upxs) + + sec upxs == applyOrError(secIfCan,"sec",upxs) + + csc upxs == applyOrError(cscIfCan,"csc",upxs) + + asin upxs == applyOrError(asinIfCan,"asin",upxs) + + acos upxs == applyOrError(acosIfCan,"acos",upxs) + + atan upxs == applyOrError(atanIfCan,"atan",upxs) + + acot upxs == applyOrError(acotIfCan,"acot",upxs) + + asec upxs == applyOrError(asecIfCan,"asec",upxs) + + acsc upxs == applyOrError(acscIfCan,"acsc",upxs) + + sinh upxs == applyOrError(sinhIfCan,"sinh",upxs) + + cosh upxs == applyOrError(coshIfCan,"cosh",upxs) + + tanh upxs == applyOrError(tanhIfCan,"tanh",upxs) + + coth upxs == applyOrError(cothIfCan,"coth",upxs) + + sech upxs == applyOrError(sechIfCan,"sech",upxs) + + csch upxs == applyOrError(cschIfCan,"csch",upxs) + + asinh upxs == applyOrError(asinhIfCan,"asinh",upxs) + + acosh upxs == applyOrError(acoshIfCan,"acosh",upxs) + + atanh upxs == applyOrError(atanhIfCan,"atanh",upxs) + + acoth upxs == applyOrError(acothIfCan,"acoth",upxs) + + asech upxs == applyOrError(asechIfCan,"asech",upxs) + + acsch upxs == applyOrError(acschIfCan,"acsch",upxs) + *) \end{chunk} @@ -47838,7 +52825,8 @@ Equation(S: Type): public == private where eval: ($, $) -> $ ++ eval(eqn, x=f) replaces x by f in equation eqn. eval: ($, List $) -> $ - ++ eval(eqn, [x1=v1, ... xn=vn]) replaces xi by vi in equation eqn. + ++ eval(eqn, [x1=v1, ... xn=vn]) + ++ replaces xi by vi in equation eqn. if S has AbelianSemiGroup then AbelianSemiGroup "+": (S, $) -> $ @@ -47857,8 +52845,8 @@ Equation(S: Type): public == private where ++ x-eqn produces a new equation by subtracting both sides of ++ equation eqn from x. "-": ($, S) -> $ - ++ eqn-x produces a new equation by subtracting x from both sides of - ++ equation eqn. + ++ eqn-x produces a new equation by subtracting x from both sides + ++ of the equation eqn. if S has SemiGroup then SemiGroup "*": (S, $) -> $ @@ -47906,19 +52894,29 @@ Equation(S: Type): public == private where private ==> add Rep := Record(lhs: S, rhs: S) + eq1,eq2: $ + s : S + if S has IntegralDomain then + factorAndSplit eq == (S has factor : S -> Factored S) => eq0 := rightZero eq [equation(rcf.factor,0) for rcf in factors factor lhs eq0] [eq] + l:S = r:S == [l, r] + equation(l, r) == [l, r] -- hack! See comment above. + lhs eqn == eqn.lhs + rhs eqn == eqn.rhs + swap eqn == [rhs eqn, lhs eqn] + map(fn, eqn) == equation(fn(eqn.lhs), fn(eqn.rhs)) if S has InnerEvalable(Symbol,S) then @@ -47926,61 +52924,101 @@ Equation(S: Type): public == private where ls:List Symbol x:S lx:List S + eval(eqn,s,x) == eval(eqn.lhs,s,x) = eval(eqn.rhs,s,x) + eval(eqn,ls,lx) == eval(eqn.lhs,ls,lx) = eval(eqn.rhs,ls,lx) + if S has Evalable(S) then + eval(eqn1:$, eqn2:$):$ == eval(eqn1.lhs, eqn2 pretend Equation S) = eval(eqn1.rhs, eqn2 pretend Equation S) + eval(eqn1:$, leqn2:List $):$ == eval(eqn1.lhs, leqn2 pretend List Equation S) = eval(eqn1.rhs, leqn2 pretend List Equation S) + if S has SetCategory then + eq1 = eq2 == (eq1.lhs = eq2.lhs)@Boolean and (eq1.rhs = eq2.rhs)@Boolean + coerce(eqn:$):Ex == eqn.lhs::Ex = eqn.rhs::Ex + coerce(eqn:$):Boolean == eqn.lhs = eqn.rhs + if S has AbelianSemiGroup then + eq1 + eq2 == eq1.lhs + eq2.lhs = eq1.rhs + eq2.rhs + s + eq2 == [s,s] + eq2 + eq1 + s == eq1 + [s,s] + if S has AbelianGroup then + - eq == (- lhs eq) = (-rhs eq) + s - eq2 == [s,s] - eq2 + eq1 - s == eq1 - [s,s] + leftZero eq == 0 = rhs eq - lhs eq + rightZero eq == lhs eq - rhs eq = 0 + 0 == equation(0$S,0$S) + eq1 - eq2 == eq1.lhs - eq2.lhs = eq1.rhs - eq2.rhs + if S has SemiGroup then + eq1:$ * eq2:$ == eq1.lhs * eq2.lhs = eq1.rhs * eq2.rhs + l:S * eqn:$ == l * eqn.lhs = l * eqn.rhs + l:S * eqn:$ == l * eqn.lhs = l * eqn.rhs + eqn:$ * l:S == eqn.lhs * l = eqn.rhs * l -- We have to be a bit careful here: raising to a +ve integer is OK -- (since it's the equivalent of repeated multiplication) -- but other powers may cause contradictions -- Watch what else you add here! JHD 2/Aug 1990 + if S has Monoid then + 1 == equation(1$S,1$S) + recip eq == (lh := recip lhs eq) case "failed" => "failed" (rh := recip rhs eq) case "failed" => "failed" [lh :: S, rh :: S] + leftOne eq == (re := recip lhs eq) case "failed" => "failed" 1 = rhs eq * re + rightOne eq == (re := recip rhs eq) case "failed" => "failed" lhs eq * re = 1 + if S has Group then + inv eq == [inv lhs eq, inv rhs eq] + leftOne eq == 1 = rhs eq * inv rhs eq + rightOne eq == lhs eq * inv rhs eq = 1 + if S has Ring then + characteristic() == characteristic()$S + i:Integer * eq:$ == (i::S) * eq + if S has IntegralDomain then + factorAndSplit eq == (S has factor : S -> Factored S) => eq0 := rightZero eq @@ -47990,16 +53028,25 @@ Equation(S: Type): public == private where MF ==> MultivariateFactorize(Symbol, IndexedExponents Symbol, _ Integer, Polynomial Integer) p : Polynomial Integer := (lhs eq0) pretend Polynomial Integer - [equation((rcf.factor) pretend S,0) for rcf in factors factor(p)$MF] + [equation((rcf.factor) pretend S,0) _ + for rcf in factors factor(p)$MF] [eq] + if S has PartialDifferentialRing(Symbol) then + differentiate(eq:$, sym:Symbol):$ == [differentiate(lhs eq, sym), differentiate(rhs eq, sym)] + if S has Field then + dimension() == 2 :: CardinalNumber + eq1:$ / eq2:$ == eq1.lhs / eq2.lhs = eq1.rhs / eq2.rhs + inv eq == [inv lhs eq, inv rhs eq] + if S has ExpressionSpace then + subst(eq1,eq2) == eq3 := eq2 pretend Equation S [subst(lhs eq1,eq3),subst(rhs eq1,eq3)] @@ -48009,6 +53056,164 @@ Equation(S: Type): public == private where \begin{chunk}{COQ EQ} (* domain EQ *) (* + Rep := Record(lhs: S, rhs: S) + + eq1,eq2: $ + + s : S + + if S has IntegralDomain then + + factorAndSplit eq == + (S has factor : S -> Factored S) => + eq0 := rightZero eq + [equation(rcf.factor,0) for rcf in factors factor lhs eq0] + [eq] + + l:S = r:S == [l, r] + + equation(l, r) == [l, r] -- hack! See comment above. + + lhs eqn == eqn.lhs + + rhs eqn == eqn.rhs + + swap eqn == [rhs eqn, lhs eqn] + + map(fn, eqn) == equation(fn(eqn.lhs), fn(eqn.rhs)) + + if S has InnerEvalable(Symbol,S) then + s:Symbol + ls:List Symbol + x:S + lx:List S + + eval(eqn,s,x) == eval(eqn.lhs,s,x) = eval(eqn.rhs,s,x) + + eval(eqn,ls,lx) == eval(eqn.lhs,ls,lx) = eval(eqn.rhs,ls,lx) + + if S has Evalable(S) then + + eval(eqn1:$, eqn2:$):$ == + eval(eqn1.lhs, eqn2 pretend Equation S) = + eval(eqn1.rhs, eqn2 pretend Equation S) + + eval(eqn1:$, leqn2:List $):$ == + eval(eqn1.lhs, leqn2 pretend List Equation S) = + eval(eqn1.rhs, leqn2 pretend List Equation S) + + if S has SetCategory then + + eq1 = eq2 == (eq1.lhs = eq2.lhs)@Boolean and + (eq1.rhs = eq2.rhs)@Boolean + + coerce(eqn:$):Ex == eqn.lhs::Ex = eqn.rhs::Ex + + coerce(eqn:$):Boolean == eqn.lhs = eqn.rhs + + if S has AbelianSemiGroup then + + eq1 + eq2 == eq1.lhs + eq2.lhs = eq1.rhs + eq2.rhs + + s + eq2 == [s,s] + eq2 + + eq1 + s == eq1 + [s,s] + + if S has AbelianGroup then + + - eq == (- lhs eq) = (-rhs eq) + + s - eq2 == [s,s] - eq2 + + eq1 - s == eq1 - [s,s] + + leftZero eq == 0 = rhs eq - lhs eq + + rightZero eq == lhs eq - rhs eq = 0 + + 0 == equation(0$S,0$S) + + eq1 - eq2 == eq1.lhs - eq2.lhs = eq1.rhs - eq2.rhs + + if S has SemiGroup then + + eq1:$ * eq2:$ == eq1.lhs * eq2.lhs = eq1.rhs * eq2.rhs + + l:S * eqn:$ == l * eqn.lhs = l * eqn.rhs + + l:S * eqn:$ == l * eqn.lhs = l * eqn.rhs + + eqn:$ * l:S == eqn.lhs * l = eqn.rhs * l + -- We have to be a bit careful here: raising to a +ve integer is OK + -- (since it's the equivalent of repeated multiplication) + -- but other powers may cause contradictions + -- Watch what else you add here! JHD 2/Aug 1990 + + if S has Monoid then + + 1 == equation(1$S,1$S) + + recip eq == + (lh := recip lhs eq) case "failed" => "failed" + (rh := recip rhs eq) case "failed" => "failed" + [lh :: S, rh :: S] + + leftOne eq == + (re := recip lhs eq) case "failed" => "failed" + 1 = rhs eq * re + + rightOne eq == + (re := recip rhs eq) case "failed" => "failed" + lhs eq * re = 1 + + if S has Group then + + inv eq == [inv lhs eq, inv rhs eq] + + leftOne eq == 1 = rhs eq * inv rhs eq + + rightOne eq == lhs eq * inv rhs eq = 1 + + if S has Ring then + + characteristic() == characteristic()$S + + i:Integer * eq:$ == (i::S) * eq + + if S has IntegralDomain then + + factorAndSplit eq == + (S has factor : S -> Factored S) => + eq0 := rightZero eq + [equation(rcf.factor,0) for rcf in factors factor lhs eq0] + (S has Polynomial Integer) => + eq0 := rightZero eq + MF ==> MultivariateFactorize(Symbol, IndexedExponents Symbol, _ + Integer, Polynomial Integer) + p : Polynomial Integer := (lhs eq0) pretend Polynomial Integer + [equation((rcf.factor) pretend S,0) _ + for rcf in factors factor(p)$MF] + [eq] + + if S has PartialDifferentialRing(Symbol) then + + differentiate(eq:$, sym:Symbol):$ == + [differentiate(lhs eq, sym), differentiate(rhs eq, sym)] + + if S has Field then + + dimension() == 2 :: CardinalNumber + + eq1:$ / eq2:$ == eq1.lhs / eq2.lhs = eq1.rhs / eq2.rhs + + inv eq == [inv lhs eq, inv rhs eq] + + if S has ExpressionSpace then + + subst(eq1,eq2) == + eq3 := eq2 pretend Equation S + [subst(lhs eq1,eq3),subst(rhs eq1,eq3)] + *) \end{chunk} @@ -48472,6 +53677,7 @@ EuclideanModularRing(S,R,Mod,reduction:(R,Mod) -> R, --representation Rep:= Record(val:R,modulo:Mod) + --declarations x,y,z: % @@ -48481,7 +53687,6 @@ EuclideanModularRing(S,R,Mod,reduction:(R,Mod) -> R, xm:=t::Mod yv:=y.val invlcy:R --- if one? leadingCoefficient yv then invlcy:=1 if (leadingCoefficient yv = 1) then invlcy:=1 else invlcy:=(inv reduce((leadingCoefficient yv)::R,xm)).val @@ -48490,13 +53695,13 @@ EuclideanModularRing(S,R,Mod,reduction:(R,Mod) -> R, [reduce(invlcy*r.quotient,xm),reduce(r.remainder,xm)] if R has fmecg:(R,NonNegativeInteger,S,R)->R + then x rem y == t:=merge(x.modulo,y.modulo) t case "failed" => error "incompatible moduli" xm:=t::Mod yv:=y.val invlcy:R --- if not one? leadingCoefficient yv then if not (leadingCoefficient yv = 1) then invlcy:=(inv reduce((leadingCoefficient yv)::R,xm)).val yv:=reduction(invlcy*yv,xm) @@ -48507,13 +53712,13 @@ EuclideanModularRing(S,R,Mod,reduction:(R,Mod) -> R, leadingCoefficient xv,yv),xm) xv = 0 => return [xv,xm]$Rep [xv,xm]$Rep + else x rem y == t:=merge(x.modulo,y.modulo) t case "failed" => error "incompatible moduli" xm:=t::Mod yv:=y.val invlcy:R --- if not one? leadingCoefficient yv then if not (leadingCoefficient yv = 1) then invlcy:=(inv reduce((leadingCoefficient yv)::R,xm)).val yv:=reduction(invlcy*yv,xm) @@ -48525,13 +53730,11 @@ EuclideanModularRing(S,R,Mod,reduction:(R,Mod) -> R, unitCanonical x == zero? x => x degree(x.val) = 0 => 1 --- one? leadingCoefficient(x.val) => x (leadingCoefficient(x.val) = 1) => x invlcx:%:=inv reduce((leadingCoefficient(x.val))::R,x.modulo) invlcx * x unitNormal x == --- zero?(x) or one?(leadingCoefficient(x.val)) => [1, x, 1] zero?(x) or ((leadingCoefficient(x.val)) = 1) => [1, x, 1] lcx := reduce((leadingCoefficient(x.val))::R,x.modulo) invlcx:=inv lcx @@ -48545,6 +53748,75 @@ EuclideanModularRing(S,R,Mod,reduction:(R,Mod) -> R, \begin{chunk}{COQ EMR} (* domain EMR *) (* + + --representation + Rep:= Record(val:R,modulo:Mod) + + --declarations + x,y,z: % + + divide(x,y) == + t:=merge(x.modulo,y.modulo) + t case "failed" => error "incompatible moduli" + xm:=t::Mod + yv:=y.val + invlcy:R + if (leadingCoefficient yv = 1) then invlcy:=1 + else + invlcy:=(inv reduce((leadingCoefficient yv)::R,xm)).val + yv:=reduction(invlcy*yv,xm) + r:=monicDivide(x.val,yv) + [reduce(invlcy*r.quotient,xm),reduce(r.remainder,xm)] + + if R has fmecg:(R,NonNegativeInteger,S,R)->R + + then x rem y == + t:=merge(x.modulo,y.modulo) + t case "failed" => error "incompatible moduli" + xm:=t::Mod + yv:=y.val + invlcy:R + if not (leadingCoefficient yv = 1) then + invlcy:=(inv reduce((leadingCoefficient yv)::R,xm)).val + yv:=reduction(invlcy*yv,xm) + dy:=degree yv + xv:=x.val + while (d:=degree xv - dy)>=0 repeat + xv:=reduction(fmecg(xv,d::NonNegativeInteger, + leadingCoefficient xv,yv),xm) + xv = 0 => return [xv,xm]$Rep + [xv,xm]$Rep + + else x rem y == + t:=merge(x.modulo,y.modulo) + t case "failed" => error "incompatible moduli" + xm:=t::Mod + yv:=y.val + invlcy:R + if not (leadingCoefficient yv = 1) then + invlcy:=(inv reduce((leadingCoefficient yv)::R,xm)).val + yv:=reduction(invlcy*yv,xm) + r:=monicDivide(x.val,yv) + reduce(r.remainder,xm) + + euclideanSize x == degree x.val + + unitCanonical x == + zero? x => x + degree(x.val) = 0 => 1 + (leadingCoefficient(x.val) = 1) => x + invlcx:%:=inv reduce((leadingCoefficient(x.val))::R,x.modulo) + invlcx * x + + unitNormal x == + zero?(x) or ((leadingCoefficient(x.val)) = 1) => [1, x, 1] + lcx := reduce((leadingCoefficient(x.val))::R,x.modulo) + invlcx:=inv lcx + degree(x.val) = 0 => [lcx, 1, invlcx] + [lcx, invlcx * x, invlcx] + + elt(x : %,s : R) : R == reduction(elt(x.val,s),x.modulo) + *) \end{chunk} @@ -48702,7 +53974,9 @@ o )show Exit ++ one half of a type-balanced \spad{if}. Exit: SetCategory == add + coerce(n:%) == error "Cannot use an Exit value." + n1 = n2 == error "Cannot use an Exit value." \end{chunk} @@ -48710,6 +53984,11 @@ Exit: SetCategory == add \begin{chunk}{COQ EXIT} (* domain EXIT *) (* + + coerce(n:%) == error "Cannot use an Exit value." + + n1 = n2 == error "Cannot use an Exit value." + *) \end{chunk} @@ -49004,10 +54283,15 @@ ExponentialExpansion(R,FE,var,cen): Exports == Implementation where ++ an \spadtype{ExponentialExpansion}. Implementation ==> Fraction(UPXSSING) add + coeff : Term -> UPXS + exponent : Term -> EXPUPXS + upxssingIfCan : % -> Union(UPXSSING,"failed") + seriesQuotientLimit: (UPXS,UPXS) -> Union(OFE,"failed") + seriesQuotientInfinity: (UPXS,UPXS) -> Union(OFE,"failed") Rep := Fraction UPXSSING @@ -49015,13 +54299,13 @@ ExponentialExpansion(R,FE,var,cen): Exports == Implementation where ZEROCOUNT : RN := 1000/1 coeff term == term.%coef + exponent term == term.%expon --!! why is this necessary? --!! code can run forever in retractIfCan if original assignment --!! for 'ff' is used upxssingIfCan f == --- one? denom f => numer f (denom f = 1) => numer f "failed" @@ -49110,6 +54394,113 @@ ExponentialExpansion(R,FE,var,cen): Exports == Implementation where \begin{chunk}{COQ EXPEXPAN} (* domain EXPEXPAN *) (* + Fraction(UPXSSING) add + + coeff : Term -> UPXS + + exponent : Term -> EXPUPXS + + upxssingIfCan : % -> Union(UPXSSING,"failed") + + seriesQuotientLimit: (UPXS,UPXS) -> Union(OFE,"failed") + + seriesQuotientInfinity: (UPXS,UPXS) -> Union(OFE,"failed") + + Rep := Fraction UPXSSING + + ZEROCOUNT : RN := 1000/1 + + coeff term == term.%coef + + exponent term == term.%expon + + --!! why is this necessary? + --!! code can run forever in retractIfCan if original assignment + --!! for 'ff' is used + upxssingIfCan f == + (denom f = 1) => numer f + "failed" + + retractIfCan(f:%):Union(UPXS,"failed") == + --ff := (retractIfCan$Rep)(f)@Union(UPXSSING,"failed") + --ff case "failed" => "failed" + (ff := upxssingIfCan f) case "failed" => "failed" + (fff := retractIfCan(ff::UPXSSING)@Union(UPXS,"failed")) case "failed" => + "failed" + fff :: UPXS + + f:UPXSSING / g:UPXSSING == + (rec := recip g) case "failed" => f /$Rep g + f * (rec :: UPXSSING) :: % + + f:% / g:% == + (rec := recip numer g) case "failed" => f /$Rep g + (rec :: UPXSSING) * (denom g) * f + + coerce(f:UPXS) == f :: UPXSSING :: % + + seriesQuotientLimit(num,den) == + -- limit of the quotient of two series + series := num / den + (ord := order(series,1)) > 0 => 0 + coef := coefficient(series,ord) + member?(var,variables coef) => "failed" + ord = 0 => coef :: OFE + (sig := sign(coef)$SIGNEF) case "failed" => return "failed" + (sig :: Integer) = 1 => plusInfinity() + minusInfinity() + + seriesQuotientInfinity(num,den) == + -- infinite limit: plus or minus? + -- look at leading coefficients of series to tell + (numOrd := order(num,ZEROCOUNT)) = ZEROCOUNT => "failed" + (denOrd := order(den,ZEROCOUNT)) = ZEROCOUNT => "failed" + cc := coefficient(num,numOrd)/coefficient(den,denOrd) + member?(var,variables cc) => "failed" + (sig := sign(cc)$SIGNEF) case "failed" => return "failed" + (sig :: Integer) = 1 => plusInfinity() + minusInfinity() + + limitPlus f == + zero? f => 0 + (den := denom f) = 1 => limitPlus numer f + (numerTerm := dominantTerm(num := numer f)) case "failed" => "failed" + numType := (numTerm := numerTerm :: TypedTerm).%type + (denomTerm := dominantTerm den) case "failed" => "failed" + denType := (denTerm := denomTerm :: TypedTerm).%type + numExpon := exponent numTerm.%term; denExpon := exponent denTerm.%term + numCoef := coeff numTerm.%term; denCoef := coeff denTerm.%term + -- numerator tends to zero exponentially + (numType = "zero") => + -- denominator tends to zero exponentially + (denType = "zero") => + (exponDiff := numExpon - denExpon) = 0 => + seriesQuotientLimit(numCoef,denCoef) + expCoef := coefficient(exponDiff,order exponDiff) + (sig := sign(expCoef)$SIGNEF) case "failed" => return "failed" + (sig :: Integer) = -1 => 0 + seriesQuotientInfinity(numCoef,denCoef) + 0 -- otherwise limit is zero + -- numerator is a Puiseux series + (numType = "series") => + -- denominator tends to zero exponentially + (denType = "zero") => + seriesQuotientInfinity(numCoef,denCoef) + -- denominator is a series + (denType = "series") => seriesQuotientLimit(numCoef,denCoef) + 0 + -- remaining case: numerator tends to infinity exponentially + -- denominator tends to infinity exponentially + (denType = "infinity") => + (exponDiff := numExpon - denExpon) = 0 => + seriesQuotientLimit(numCoef,denCoef) + expCoef := coefficient(exponDiff,order exponDiff) + (sig := sign(expCoef)$SIGNEF) case "failed" => return "failed" + (sig :: Integer) = -1 => 0 + seriesQuotientInfinity(numCoef,denCoef) + -- denominator tends to zero exponentially or is a series + seriesQuotientInfinity(numCoef,denCoef) + *) \end{chunk} @@ -49949,9 +55340,11 @@ Expression(R:OrderedSet): Exports == Implementation where if R has RetractableTo Integer then RetractableTo AN Implementation ==> add + import KernelFunctions2(R, %) retNotUnit : % -> R + retNotUnitIfCan: % -> Union(R, "failed") belong? op == true @@ -49965,26 +55358,43 @@ Expression(R:OrderedSet): Exports == Implementation where constantIfCan(r::K) if R has IntegralDomain then + reduc : (%, List Kernel %) -> % + commonk : (%, %) -> List K + commonk0 : (List K, List K) -> List K + toprat : % -> % + algkernels: List K -> List K + evl : (MP, K, SparseUnivariatePolynomial %) -> Fraction MP + evl0 : (MP, K) -> SparseUnivariatePolynomial Fraction MP Rep := Fraction MP + 0 == 0$Rep + 1 == 1$Rep --- one? x == one?(x)$Rep + one? x == (x = 1)$Rep + zero? x == zero?(x)$Rep + - x:% == -$Rep x + n:Integer * x:% == n *$Rep x + coerce(n:Integer) == coerce(n)$Rep@Rep::% + x:% * y:% == reduc(x *$Rep y, commonk(x, y)) + x:% + y:% == reduc(x +$Rep y, commonk(x, y)) + (x:% - y:%):% == reduc(x -$Rep y, commonk(x, y)) + x:% / y:% == reduc(x /$Rep y, commonk(x, y)) number?(x:%):Boolean == @@ -50023,13 +55433,21 @@ Expression(R:OrderedSet): Exports == Implementation where simplifyPower(denominator x,n pretend Integer) x:% < y:% == x <$Rep y + x:% = y:% == x =$Rep y + numer x == numer(x)$Rep + denom x == denom(x)$Rep + coerce(p:MP):% == coerce(p)$Rep + reduce x == reduc(x, algkernels kernels x) + commonk(x, y) == commonk0(algkernels kernels x, algkernels kernels y) + algkernels l == select_!(x +-> has?(operator x, ALGOP), l) + toprat f == ratDenom(f,algkernels kernels f)$AlgebraicManipulations(R, %) x:MP / y:MP == @@ -50056,67 +55474,123 @@ Expression(R:OrderedSet): Exports == Implementation where ans rootOf(x:SparseUnivariatePolynomial %, v:Symbol) == rootOf(x,v)$AF + pi() == pi()$EF + exp x == exp(x)$EF + log x == log(x)$EF + sin x == sin(x)$EF + cos x == cos(x)$EF + tan x == tan(x)$EF + cot x == cot(x)$EF + sec x == sec(x)$EF + csc x == csc(x)$EF + asin x == asin(x)$EF + acos x == acos(x)$EF + atan x == atan(x)$EF + acot x == acot(x)$EF + asec x == asec(x)$EF + acsc x == acsc(x)$EF + sinh x == sinh(x)$EF + cosh x == cosh(x)$EF + tanh x == tanh(x)$EF + coth x == coth(x)$EF + sech x == sech(x)$EF + csch x == csch(x)$EF + asinh x == asinh(x)$EF + acosh x == acosh(x)$EF + atanh x == atanh(x)$EF + acoth x == acoth(x)$EF + asech x == asech(x)$EF + acsch x == acsch(x)$EF abs x == abs(x)$FSF + Gamma x == Gamma(x)$FSF + Gamma(a, x) == Gamma(a, x)$FSF + Beta(x,y) == Beta(x,y)$FSF + digamma x == digamma(x)$FSF + polygamma(k,x) == polygamma(k,x)$FSF + besselJ(v,x) == besselJ(v,x)$FSF + besselY(v,x) == besselY(v,x)$FSF + besselI(v,x) == besselI(v,x)$FSF + besselK(v,x) == besselK(v,x)$FSF + airyAi x == airyAi(x)$FSF + airyBi x == airyBi(x)$FSF x:% ** y:% == x **$CF y + factorial x == factorial(x)$CF + binomial(n, m) == binomial(n, m)$CF + permutation(n, m) == permutation(n, m)$CF + factorials x == factorials(x)$CF + factorials(x, n) == factorials(x, n)$CF + summation(x:%, n:Symbol) == summation(x, n)$CF + summation(x:%, s:SegmentBinding %) == summation(x, s)$CF + product(x:%, n:Symbol) == product(x, n)$CF + product(x:%, s:SegmentBinding %) == product(x, s)$CF erf x == erf(x)$LF + Ei x == Ei(x)$LF + Si x == Si(x)$LF + Ci x == Ci(x)$LF + li x == li(x)$LF + dilog x == dilog(x)$LF + fresnelS x == fresnelS(x)$LF + fresnelC x == fresnelC(x)$LF + integral(x:%, n:Symbol) == integral(x, n)$LF + integral(x:%, s:SegmentBinding %) == integral(x, s)$LF operator op == @@ -50147,9 +55621,10 @@ Expression(R:OrderedSet): Exports == Implementation where evl(p, k, m) == degree(p, k) < degree m => p::Fraction(MP) (((evl0(p, k) pretend SparseUnivariatePolynomial($)) rem m) - pretend SparseUnivariatePolynomial Fraction MP) (k::MP::Fraction(MP)) + pretend SparseUnivariatePolynomial Fraction MP) (k::MP::Fraction(MP)) if R has GcdDomain then + noalg?: SUP % -> Boolean noalg? p == @@ -50179,21 +55654,32 @@ Expression(R:OrderedSet): Exports == Implementation where coerce(x:AN):% == (monomial(x, 0$IndexedExponents(K))$MP)::% if (R has RetractableTo Integer) then + x:% ** r:Q == x **$AF r + minPoly k == minPoly(k)$AF + definingPolynomial x == definingPolynomial(x)$AF + retract(x:%):Q == retract(x)$Rep + retractIfCan(x:%):Union(Q, "failed") == retractIfCan(x)$Rep if not(R is AN) then + k2expr : KAN -> % + smp2expr: SparseMultivariatePolynomial(Integer, KAN) -> % + R2AN : R -> Union(AN, "failed") + k2an : K -> Union(AN, "failed") + smp2an : MP -> Union(AN, "failed") coerce(x:AN):% == smp2expr(numer x) / smp2expr(denom x) + k2expr k == map(x+->x::%, k)$ExpressionSpaceFunctions2(AN, %) smp2expr p == @@ -50225,17 +55711,22 @@ Expression(R:OrderedSet): Exports == Implementation where (t := k2an k) case "failed" => "failed" ans:AN := 0 while not ground? up repeat - (c:=smp2an leadingCoefficient up) case "failed" => return "failed" + (c:=smp2an leadingCoefficient up) case "failed" _ + => return "failed" ans := ans + (c::AN) * (t::AN) ** (degree up) up := reductum up (c := smp2an leadingCoefficient up) case "failed" => "failed" ans + c::AN if R has ConvertibleTo InputForm then + convert(x:%):InputForm == convert(x)$Rep + import MakeUnaryCompiledFunction(%, %, %) + eval(f:%, op: BasicOperator, g:%, x:Symbol):% == eval(f,[op],[g],x) + eval(f:%, ls:List BasicOperator, lg:List %, x:Symbol) == -- handle subsrcipted symbols by renaming -> eval -> renaming back llsym:List List Symbol:=[variables g for g in lg] @@ -50243,22 +55734,28 @@ Expression(R:OrderedSet): Exports == Implementation where lsd:List Symbol:=select (scripted?,lsym) empty? lsd=> eval(f,ls,[compiledFunction(g, x) for g in lg]) ns:List Symbol:=[new()$Symbol for i in lsd] - lforwardSubs:List Equation % := [(i::%)= (j::%) for i in lsd for j in ns] - lbackwardSubs:List Equation % := [(j::%)= (i::%) for i in lsd for j in ns] + lforwardSubs:List Equation % := _ + [(i::%)= (j::%) for i in lsd for j in ns] + lbackwardSubs:List Equation % := _ + [(j::%)= (i::%) for i in lsd for j in ns] nlg:List % :=[subst(g,lforwardSubs) for g in lg] res:% :=eval(f, ls, [compiledFunction(g, x) for g in nlg]) subst(res,lbackwardSubs) + if R has PatternMatchable Integer then + patternMatch(x:%, p:Pattern Integer, l:PatternMatchResult(Integer, %)) == patternMatch(x, p, l)$PatternMatchFunctionSpace(Integer, R, %) if R has PatternMatchable Float then + patternMatch(x:%, p:Pattern Float, l:PatternMatchResult(Float, %)) == patternMatch(x, p, l)$PatternMatchFunctionSpace(Float, R, %) else -- R is not an integral domain + operator op == belong?(op)$FSD => operator(op)$FSD belong?(op)$ESD => operator(op)$ESD @@ -50267,16 +55764,27 @@ Expression(R:OrderedSet): Exports == Implementation where operator(name op, n::NonNegativeInteger) if R has Ring then + Rep := MP + 0 == 0$Rep + 1 == 1$Rep + - x:% == -$Rep x + n:Integer *x:% == n *$Rep x + x:% * y:% == x *$Rep y + x:% + y:% == x +$Rep y + x:% = y:% == x =$Rep y + x:% < y:% == x <$Rep y + numer x == x@Rep + coerce(p:MP):% == p reducedSystem(m:Matrix %):Matrix(R) == @@ -50287,9 +55795,11 @@ Expression(R:OrderedSet): Exports == Implementation where reducedSystem(m, v)$Rep if R has ConvertibleTo InputForm then + convert(x:%):InputForm == convert(x)$Rep if R has PatternMatchable Integer then + kintmatch: (K,Pattern Integer,PatternMatchResult(Integer,Rep)) -> PatternMatchResult(Integer, Rep) @@ -50308,6 +55818,7 @@ Expression(R:OrderedSet): Exports == Implementation where pretend PatternMatchResult(Integer, %) if R has PatternMatchable Float then + kfltmatch: (K, Pattern Float, PatternMatchResult(Float, Rep)) -> PatternMatchResult(Float, Rep) @@ -50326,23 +55837,35 @@ Expression(R:OrderedSet): Exports == Implementation where pretend PatternMatchResult(Float, %) else -- R is not even a ring + if R has AbelianMonoid then + import ListToMap(K, %) kereval : (K, List K, List %) -> % + subeval : (K, List K, List %) -> % Rep := FreeAbelianGroup K 0 == 0$Rep + x:% + y:% == x +$Rep y + x:% = y:% == x =$Rep y + x:% < y:% == x <$Rep y + coerce(k:K):% == coerce(k)$Rep + kernels x == [f.gen for f in terms x] + coerce(x:R):% == (zero? x => 0; constantKernel(x)::%) + retract(x:%):R == (zero? x => 0; retNotUnit x) + coerce(x:%):OutputForm == coerce(x)$Rep + kereval(k, lk, lv) == match(lk, lv, k, (x2:K):% +-> map(x1 +-> eval(x1, lk, lv), x2)) @@ -50372,36 +55895,26 @@ Expression(R:OrderedSet): Exports == Implementation where if R has AbelianGroup then -(x:%) == -$Rep x --- else -- R is not an AbelianMonoid --- if R has SemiGroup then --- Rep := FreeGroup K --- 1 == 1$Rep --- x:% * y:% == x *$Rep y --- x:% = y:% == x =$Rep y --- coerce(k:K):% == k::Rep --- kernels x == [f.gen for f in factors x] --- coerce(x:R):% == (one? x => 1; constantKernel x) --- retract(x:%):R == (one? x => 1; retNotUnit x) --- coerce(x:%):OutputForm == coerce(x)$Rep - --- retractIfCan(x:%):Union(R, "failed") == --- one? x => 1 --- retNotUnitIfCan x - --- if R has Group then inv(x:%):% == inv(x)$Rep - else -- R is nothing + import ListToMap(K, %) Rep := K x:% < y:% == x <$Rep y + x:% = y:% == x =$Rep y + coerce(k:K):% == k + kernels x == [x pretend K] + coerce(x:R):% == constantKernel x + retract(x:%):R == retNotUnit x + retractIfCan(x:%):Union(R, "failed") == retNotUnitIfCan x + coerce(x:%):OutputForm == coerce(x)$Rep eval(x:%, lk:List K, lv:List %) == @@ -50416,25 +55929,600 @@ Expression(R:OrderedSet): Exports == Implementation where if R has ConvertibleTo InputForm then convert(x:%):InputForm == convert(x)$Rep --- if R has PatternMatchable Integer then --- convert(x:%):Pattern(Integer) == convert(x)$Rep --- --- patternMatch(x:%, p:Pattern Integer, --- l:PatternMatchResult(Integer, %)) == --- patternMatch(x pretend K,p,l)$PatternMatchKernel(Integer, %) --- --- if R has PatternMatchable Float then --- convert(x:%):Pattern(Float) == convert(x)$Rep --- --- patternMatch(x:%, p:Pattern Float, --- l:PatternMatchResult(Float, %)) == --- patternMatch(x pretend K, p, l)$PatternMatchKernel(Float, %) - \end{chunk} \begin{chunk}{COQ EXPR} (* domain EXPR *) (* + + import KernelFunctions2(R, %) + + retNotUnit : % -> R + + retNotUnitIfCan: % -> Union(R, "failed") + + belong? op == true + + retNotUnit x == + (u := constantIfCan(k := retract(x)@K)) case R => u::R + error "Not retractable" + + retNotUnitIfCan x == + (r := retractIfCan(x)@Union(K,"failed")) case "failed" => "failed" + constantIfCan(r::K) + + if R has IntegralDomain then + + reduc : (%, List Kernel %) -> % + + commonk : (%, %) -> List K + + commonk0 : (List K, List K) -> List K + + toprat : % -> % + + algkernels: List K -> List K + + evl : (MP, K, SparseUnivariatePolynomial %) -> Fraction MP + + evl0 : (MP, K) -> SparseUnivariatePolynomial Fraction MP + + Rep := Fraction MP + + 0 == 0$Rep + + 1 == 1$Rep + + one? x == (x = 1)$Rep + + zero? x == zero?(x)$Rep + + - x:% == -$Rep x + + n:Integer * x:% == n *$Rep x + + coerce(n:Integer) == coerce(n)$Rep@Rep::% + + x:% * y:% == reduc(x *$Rep y, commonk(x, y)) + + x:% + y:% == reduc(x +$Rep y, commonk(x, y)) + + (x:% - y:%):% == reduc(x -$Rep y, commonk(x, y)) + + x:% / y:% == reduc(x /$Rep y, commonk(x, y)) + + number?(x:%):Boolean == + if R has RetractableTo(Integer) then + ground?(x) or ((retractIfCan(x)@Union(Q,"failed")) case Q) + else + ground?(x) + + simplifyPower(x:%,n:Integer):% == + k : List K := kernels x + is?(x,POWER) => + -- Look for a power of a number in case we can do a simplification + args : List % := argument first k + not(#args = 2) => error "Too many arguments to **" + number?(args.1) => + reduc((args.1) **$Rep n, algkernels kernels (args.1))**(args.2) + (first args)**(n*second(args)) + reduc(x **$Rep n, algkernels k) + + x:% ** n:NonNegativeInteger == + n = 0 => 1$% + n = 1 => x + simplifyPower(numerator x,n pretend Integer) / + simplifyPower(denominator x,n pretend Integer) + + x:% ** n:Integer == + n = 0 => 1$% + n = 1 => x + n = -1 => 1/x + simplifyPower(numerator x,n) / + simplifyPower(denominator x,n) + + x:% ** n:PositiveInteger == + n = 1 => x + simplifyPower(numerator x,n pretend Integer) / + simplifyPower(denominator x,n pretend Integer) + + x:% < y:% == x <$Rep y + + x:% = y:% == x =$Rep y + + numer x == numer(x)$Rep + + denom x == denom(x)$Rep + + coerce(p:MP):% == coerce(p)$Rep + + reduce x == reduc(x, algkernels kernels x) + + commonk(x, y) == commonk0(algkernels kernels x, algkernels kernels y) + + algkernels l == select_!(x +-> has?(operator x, ALGOP), l) + + toprat f == ratDenom(f,algkernels kernels f)$AlgebraicManipulations(R, %) + + x:MP / y:MP == + reduc(x /$Rep y,commonk0(algkernels variables x,algkernels variables y)) + +-- since we use the reduction from FRAC SMP which asssumes that the +-- variables are independent, we must remove algebraic from the denominators + reducedSystem(m:Matrix %):Matrix(R) == + mm:Matrix(MP) := reducedSystem(map(toprat, m))$Rep + reducedSystem(mm)$MP + +-- since we use the reduction from FRAC SMP which asssumes that the +-- variables are independent, we must remove algebraic from the denominators + reducedSystem(m:Matrix %, v:Vector %): + Record(mat:Matrix R, vec:Vector R) == + r:Record(mat:Matrix MP, vec:Vector MP) := + reducedSystem(map(toprat, m), map(toprat, v))$Rep + reducedSystem(r.mat, r.vec)$MP + +-- The result MUST be left sorted deepest first MB 3/90 + commonk0(x, y) == + ans := empty()$List(K) + for k in reverse_! x repeat if member?(k, y) then ans := concat(k, ans) + ans + + rootOf(x:SparseUnivariatePolynomial %, v:Symbol) == rootOf(x,v)$AF + + pi() == pi()$EF + + exp x == exp(x)$EF + + log x == log(x)$EF + + sin x == sin(x)$EF + + cos x == cos(x)$EF + + tan x == tan(x)$EF + + cot x == cot(x)$EF + + sec x == sec(x)$EF + + csc x == csc(x)$EF + + asin x == asin(x)$EF + + acos x == acos(x)$EF + + atan x == atan(x)$EF + + acot x == acot(x)$EF + + asec x == asec(x)$EF + + acsc x == acsc(x)$EF + + sinh x == sinh(x)$EF + + cosh x == cosh(x)$EF + + tanh x == tanh(x)$EF + + coth x == coth(x)$EF + + sech x == sech(x)$EF + + csch x == csch(x)$EF + + asinh x == asinh(x)$EF + + acosh x == acosh(x)$EF + + atanh x == atanh(x)$EF + + acoth x == acoth(x)$EF + + asech x == asech(x)$EF + + acsch x == acsch(x)$EF + + abs x == abs(x)$FSF + + Gamma x == Gamma(x)$FSF + + Gamma(a, x) == Gamma(a, x)$FSF + + Beta(x,y) == Beta(x,y)$FSF + + digamma x == digamma(x)$FSF + + polygamma(k,x) == polygamma(k,x)$FSF + + besselJ(v,x) == besselJ(v,x)$FSF + + besselY(v,x) == besselY(v,x)$FSF + + besselI(v,x) == besselI(v,x)$FSF + + besselK(v,x) == besselK(v,x)$FSF + + airyAi x == airyAi(x)$FSF + + airyBi x == airyBi(x)$FSF + + x:% ** y:% == x **$CF y + + factorial x == factorial(x)$CF + + binomial(n, m) == binomial(n, m)$CF + + permutation(n, m) == permutation(n, m)$CF + + factorials x == factorials(x)$CF + + factorials(x, n) == factorials(x, n)$CF + + summation(x:%, n:Symbol) == summation(x, n)$CF + + summation(x:%, s:SegmentBinding %) == summation(x, s)$CF + + product(x:%, n:Symbol) == product(x, n)$CF + + product(x:%, s:SegmentBinding %) == product(x, s)$CF + + erf x == erf(x)$LF + + Ei x == Ei(x)$LF + + Si x == Si(x)$LF + + Ci x == Ci(x)$LF + + li x == li(x)$LF + + dilog x == dilog(x)$LF + + fresnelS x == fresnelS(x)$LF + + fresnelC x == fresnelC(x)$LF + + integral(x:%, n:Symbol) == integral(x, n)$LF + + integral(x:%, s:SegmentBinding %) == integral(x, s)$LF + + operator op == + belong?(op)$AF => operator(op)$AF + belong?(op)$EF => operator(op)$EF + belong?(op)$CF => operator(op)$CF + belong?(op)$LF => operator(op)$LF + belong?(op)$FSF => operator(op)$FSF + belong?(op)$FSD => operator(op)$FSD + belong?(op)$ESD => operator(op)$ESD + nullary? op and has?(op, SYMBOL) => operator(kernel(name op)$K) + (n := arity op) case "failed" => operator name op + operator(name op, n::NonNegativeInteger) + + reduc(x, l) == + for k in l repeat + p := minPoly k + x := evl(numer x, k, p) /$Rep evl(denom x, k, p) + x + + evl0(p, k) == + numer univariate(p::Fraction(MP), + k)$PolynomialCategoryQuotientFunctions(IndexedExponents K, + K,R,MP,Fraction MP) + + -- uses some operations from Rep instead of % in order not to + -- reduce recursively during those operations. + evl(p, k, m) == + degree(p, k) < degree m => p::Fraction(MP) + (((evl0(p, k) pretend SparseUnivariatePolynomial($)) rem m) + pretend SparseUnivariatePolynomial Fraction MP) (k::MP::Fraction(MP)) + + if R has GcdDomain then + + noalg?: SUP % -> Boolean + + noalg? p == + while p ^= 0 repeat + not empty? algkernels kernels leadingCoefficient p => return false + p := reductum p + true + + gcdPolynomial(p:SUP %, q:SUP %) == + noalg? p and noalg? q => gcdPolynomial(p, q)$Rep + gcdPolynomial(p, q)$GcdDomain_&(%) + + factorPolynomial(x:SUP %) : Factored SUP % == + uf:= factor(x pretend SUP(Rep))$SupFractionFactorizer( + IndexedExponents K,K,R,MP) + uf pretend Factored SUP % + + squareFreePolynomial(x:SUP %) : Factored SUP % == + uf:= squareFree(x pretend SUP(Rep))$SupFractionFactorizer( + IndexedExponents K,K,R,MP) + uf pretend Factored SUP % + + if R is AN then + -- this is to force the coercion R -> EXPR R to be used + -- instead of the coercioon AN -> EXPR R which loops. + -- simpler looking code will fail! MB 10/91 + coerce(x:AN):% == (monomial(x, 0$IndexedExponents(K))$MP)::% + + if (R has RetractableTo Integer) then + + x:% ** r:Q == x **$AF r + + minPoly k == minPoly(k)$AF + + definingPolynomial x == definingPolynomial(x)$AF + + retract(x:%):Q == retract(x)$Rep + + retractIfCan(x:%):Union(Q, "failed") == retractIfCan(x)$Rep + + if not(R is AN) then + + k2expr : KAN -> % + + smp2expr: SparseMultivariatePolynomial(Integer, KAN) -> % + + R2AN : R -> Union(AN, "failed") + + k2an : K -> Union(AN, "failed") + + smp2an : MP -> Union(AN, "failed") + + + coerce(x:AN):% == smp2expr(numer x) / smp2expr(denom x) + + k2expr k == map(x+->x::%, k)$ExpressionSpaceFunctions2(AN, %) + + smp2expr p == + map(k2expr,x+->x::%,p)_ + $PolynomialCategoryLifting(IndexedExponents KAN, + KAN, Integer, SparseMultivariatePolynomial(Integer, KAN), %) + + retractIfCan(x:%):Union(AN, "failed") == + ((n:= smp2an numer x) case AN) and ((d:= smp2an denom x) case AN) + => (n::AN) / (d::AN) + "failed" + + R2AN r == + (u := retractIfCan(r::%)@Union(Q, "failed")) case Q => u::Q::AN + "failed" + + k2an k == + not(belong?(op := operator k)$AN) => "failed" + arg:List(AN) := empty() + for x in argument k repeat + if (a := retractIfCan(x)@Union(AN, "failed")) case "failed" then + return "failed" + else arg := concat(a::AN, arg) + (operator(op)$AN) reverse_!(arg) + + smp2an p == + (x1 := mainVariable p) case "failed" => R2AN leadingCoefficient p + up := univariate(p, k := x1::K) + (t := k2an k) case "failed" => "failed" + ans:AN := 0 + while not ground? up repeat + (c:=smp2an leadingCoefficient up) case "failed" _ + => return "failed" + ans := ans + (c::AN) * (t::AN) ** (degree up) + up := reductum up + (c := smp2an leadingCoefficient up) case "failed" => "failed" + ans + c::AN + + if R has ConvertibleTo InputForm then + + convert(x:%):InputForm == convert(x)$Rep + + import MakeUnaryCompiledFunction(%, %, %) + + eval(f:%, op: BasicOperator, g:%, x:Symbol):% == + eval(f,[op],[g],x) + + eval(f:%, ls:List BasicOperator, lg:List %, x:Symbol) == + -- handle subsrcipted symbols by renaming -> eval -> renaming back + llsym:List List Symbol:=[variables g for g in lg] + lsym:List Symbol:= removeDuplicates concat llsym + lsd:List Symbol:=select (scripted?,lsym) + empty? lsd=> eval(f,ls,[compiledFunction(g, x) for g in lg]) + ns:List Symbol:=[new()$Symbol for i in lsd] + lforwardSubs:List Equation % := _ + [(i::%)= (j::%) for i in lsd for j in ns] + lbackwardSubs:List Equation % := _ + [(j::%)= (i::%) for i in lsd for j in ns] + nlg:List % :=[subst(g,lforwardSubs) for g in lg] + res:% :=eval(f, ls, [compiledFunction(g, x) for g in nlg]) + subst(res,lbackwardSubs) + + if R has PatternMatchable Integer then + + patternMatch(x:%, p:Pattern Integer, + l:PatternMatchResult(Integer, %)) == + patternMatch(x, p, l)$PatternMatchFunctionSpace(Integer, R, %) + + if R has PatternMatchable Float then + + patternMatch(x:%, p:Pattern Float, + l:PatternMatchResult(Float, %)) == + patternMatch(x, p, l)$PatternMatchFunctionSpace(Float, R, %) + + else -- R is not an integral domain + + operator op == + belong?(op)$FSD => operator(op)$FSD + belong?(op)$ESD => operator(op)$ESD + nullary? op and has?(op, SYMBOL) => operator(kernel(name op)$K) + (n := arity op) case "failed" => operator name op + operator(name op, n::NonNegativeInteger) + + if R has Ring then + + Rep := MP + + 0 == 0$Rep + + 1 == 1$Rep + + - x:% == -$Rep x + + n:Integer *x:% == n *$Rep x + + x:% * y:% == x *$Rep y + + x:% + y:% == x +$Rep y + + x:% = y:% == x =$Rep y + + x:% < y:% == x <$Rep y + + numer x == x@Rep + + coerce(p:MP):% == p + + reducedSystem(m:Matrix %):Matrix(R) == + reducedSystem(m)$Rep + + reducedSystem(m:Matrix %, v:Vector %): + Record(mat:Matrix R, vec:Vector R) == + reducedSystem(m, v)$Rep + + if R has ConvertibleTo InputForm then + + convert(x:%):InputForm == convert(x)$Rep + + if R has PatternMatchable Integer then + + kintmatch: (K,Pattern Integer,PatternMatchResult(Integer,Rep)) + -> PatternMatchResult(Integer, Rep) + + kintmatch(k, p, l) == + patternMatch(k, p, l pretend PatternMatchResult(Integer, %) + )$PatternMatchKernel(Integer, %) + pretend PatternMatchResult(Integer, Rep) + + patternMatch(x:%, p:Pattern Integer, + l:PatternMatchResult(Integer, %)) == + patternMatch(x@Rep, p, + l pretend PatternMatchResult(Integer, Rep), + kintmatch + )$PatternMatchPolynomialCategory(Integer, + IndexedExponents K, K, R, Rep) + pretend PatternMatchResult(Integer, %) + + if R has PatternMatchable Float then + + kfltmatch: (K, Pattern Float, PatternMatchResult(Float, Rep)) + -> PatternMatchResult(Float, Rep) + + kfltmatch(k, p, l) == + patternMatch(k, p, l pretend PatternMatchResult(Float, %) + )$PatternMatchKernel(Float, %) + pretend PatternMatchResult(Float, Rep) + + patternMatch(x:%, p:Pattern Float, + l:PatternMatchResult(Float, %)) == + patternMatch(x@Rep, p, + l pretend PatternMatchResult(Float, Rep), + kfltmatch + )$PatternMatchPolynomialCategory(Float, + IndexedExponents K, K, R, Rep) + pretend PatternMatchResult(Float, %) + + else -- R is not even a ring + + if R has AbelianMonoid then + + import ListToMap(K, %) + + kereval : (K, List K, List %) -> % + + subeval : (K, List K, List %) -> % + + Rep := FreeAbelianGroup K + + 0 == 0$Rep + + x:% + y:% == x +$Rep y + + x:% = y:% == x =$Rep y + + x:% < y:% == x <$Rep y + + coerce(k:K):% == coerce(k)$Rep + + kernels x == [f.gen for f in terms x] + + coerce(x:R):% == (zero? x => 0; constantKernel(x)::%) + + retract(x:%):R == (zero? x => 0; retNotUnit x) + + coerce(x:%):OutputForm == coerce(x)$Rep + + kereval(k, lk, lv) == + match(lk, lv, k, (x2:K):% +-> map(x1 +-> eval(x1, lk, lv), x2)) + + subeval(k, lk, lv) == + match(lk, lv, k, + (x:K):% +-> + kernel(operator x, [subst(a, lk, lv) for a in argument x])) + + isPlus x == + empty?(l := terms x) or empty? rest l => "failed" + [t.exp *$Rep t.gen for t in l]$List(%) + + isMult x == + empty?(l := terms x) or not empty? rest l => "failed" + t := first l + [t.exp, t.gen] + + eval(x:%, lk:List K, lv:List %) == + _+/[t.exp * kereval(t.gen, lk, lv) for t in terms x] + + subst(x:%, lk:List K, lv:List %) == + _+/[t.exp * subeval(t.gen, lk, lv) for t in terms x] + + retractIfCan(x:%):Union(R, "failed") == + zero? x => 0 + retNotUnitIfCan x + + if R has AbelianGroup then -(x:%) == -$Rep x + + else -- R is nothing + + import ListToMap(K, %) + + Rep := K + + x:% < y:% == x <$Rep y + + x:% = y:% == x =$Rep y + + coerce(k:K):% == k + + kernels x == [x pretend K] + + coerce(x:R):% == constantKernel x + + retract(x:%):R == retNotUnit x + + retractIfCan(x:%):Union(R, "failed") == retNotUnitIfCan x + + coerce(x:%):OutputForm == coerce(x)$Rep + + eval(x:%, lk:List K, lv:List %) == + match(lk, lv, x pretend K, + (x1:K):% +-> map(x2 +-> eval(x2, lk, lv), x1)) + + subst(x, lk, lv) == + match(lk, lv, x pretend K, + (x1:K):% +-> + kernel(operator x1, [subst(a, lk, lv) for a in argument x1])) + + if R has ConvertibleTo InputForm then + convert(x:%):InputForm == convert(x)$Rep + *) \end{chunk} @@ -50771,7 +56859,9 @@ ExponentialOfUnivariatePuiseuxSeries(FE,var,cen):_ Rep := UPXS exponential f == complete f + exponent f == f pretend UPXS + exponentialOrder f == order(exponent f,0) zero? f == empty? entries complete terms f @@ -50798,6 +56888,34 @@ ExponentialOfUnivariatePuiseuxSeries(FE,var,cen):_ \begin{chunk}{COQ EXPUPXS} (* domain EXPUPXS *) (* + + Rep := UPXS + + exponential f == complete f + + exponent f == f pretend UPXS + + exponentialOrder f == order(exponent f,0) + + zero? f == empty? entries complete terms f + + f = g == + -- we redefine equality because we know that we are dealing with + -- a FINITE series, so there is no danger in computing all terms + (entries complete terms f) = (entries complete terms g) + + f < g == + zero? f => not zero? g + zero? g => false + (ordf := exponentialOrder f) > (ordg := exponentialOrder g) => true + ordf < ordg => false + (fCoef := coefficient(f,ordf)) = (gCoef := coefficient(g,ordg)) => + reductum(f) < reductum(g) + fCoef < gCoef -- this is "random" if FE is EXPR INT + + coerce(f:%):OutputForm == + ("%e" :: OutputForm) ** ((coerce$Rep)(complete f)@OutputForm) + *) \end{chunk} @@ -50938,7 +57056,9 @@ ExtAlgBasis(): Export == Implement where ++ by n generators. Implement == add + Rep := L I + x,y : % x = y == x =$Rep y @@ -50958,14 +57078,6 @@ ExtAlgBasis(): Export == Implement where exponents x == copy(x @ Rep) --- subscripts x == --- cntr:I := 1 --- result: L I := [] --- for j in x repeat --- if j = 1 then result := cons(cntr,result) --- cntr:=cntr+1 --- reverse_! result - Nul n == [0 for i in 1..n] coerce x == coerce(x @ Rep)$(L I) @@ -50975,6 +57087,32 @@ ExtAlgBasis(): Export == Implement where \begin{chunk}{COQ EAB} (* domain EAB *) (* + + Rep := L I + + x,y : % + + x = y == x =$Rep y + + x < y == + null x => not null y + null y => false + first x = first y => rest x < rest y + first x > first y + + coerce(li:(L I)) == + for x in li repeat + if x ^= 1 and x ^= 0 then error "coerce: values can only be 0 and 1" + li + + degree x == (_+/x)::NNI + + exponents x == copy(x @ Rep) + + Nul n == [0 for i in 1..n] + + coerce x == coerce(x @ Rep)$(L I) + *) \end{chunk} @@ -51129,6 +57267,59 @@ e04dgfAnnaType(): NumericalOptimizationCategory == Result add \begin{chunk}{COQ E04DGFA} (* domain E04DGFA *) (* + DF ==> DoubleFloat + EF ==> Expression Float + EDF ==> Expression DoubleFloat + PDF ==> Polynomial DoubleFloat + VPDF ==> Vector Polynomial DoubleFloat + LDF ==> List DoubleFloat + LOCDF ==> List OrderedCompletion DoubleFloat + MDF ==> Matrix DoubleFloat + MPDF ==> Matrix Polynomial DoubleFloat + MF ==> Matrix Float + MEF ==> Matrix Expression Float + LEDF ==> List Expression DoubleFloat + VEF ==> Vector Expression Float + NOA ==> Record(fn:EDF, init:LDF, lb:LOCDF, cf:LEDF, ub:LOCDF) + LSA ==> Record(lfn:LEDF, init:LDF) + EF2 ==> ExpressionFunctions2 + MI ==> Matrix Integer + INT ==> Integer + F ==> Float + NNI ==> NonNegativeInteger + S ==> Symbol + LS ==> List Symbol + MVCF ==> MultiVariableCalculusFunctions + ESTOOLS2 ==> ExpertSystemToolsPackage2 + SDF ==> Stream DoubleFloat + LSDF ==> List Stream DoubleFloat + SOCDF ==> Segment OrderedCompletion DoubleFloat + OCDF ==> OrderedCompletion DoubleFloat + + Rep:=Result + import Rep, NagOptimisationPackage, ExpertSystemToolsPackage + + measure(R:RoutinesTable,args:NOA) == + string:String := "e04dgf is " + positive?(#(args.cf) + #(args.lb) + #(args.ub)) => + string := concat(string,"unsuitable for constrained problems. ") + [0.0,string] + string := concat(string,"recommended") + [getMeasure(R,e04dgf@Symbol)$RoutinesTable, string] + + numericalOptimization(args:NOA) == + argsFn:EDF := args.fn + n:NNI := #(variables(argsFn)$EDF) + fu:DF := float(4373903597,-24,10)$DF + it:INT := max(50,5*n) + lin:DF := float(9,-1,10)$DF + ma:DF := float(1,20,10)$DF + op:DF := float(326,-14,10)$DF + x:MDF := mat(args.init,n) + ArgsFn:Expression Float := edf2ef(argsFn) + f:Union(fn:FileName,fp:Asp49(OBJFUN)) := [retract(ArgsFn)$Asp49(OBJFUN)] + e04dgf(n,1$DF,fu,it,lin,true,ma,op,1,1,n,0,x,-1,f) + *) \end{chunk} @@ -51264,12 +57455,14 @@ e04fdfAnnaType(): NumericalOptimizationCategory == Result add [0.0,string] n:NNI := #(variables(argsFn)$EDF) (n>1)@Boolean => - string := concat(string,"unsuitable for single instances of multivariate problems. ") + string := concat(string,_ + "unsuitable for single instances of multivariate problems. ") [0.0,string] sumOfSquares(argsFn) case "failed" => string := concat(string,"unsuitable.") [0.0,string] - string := concat(string,"recommended since the function is a sum of squares.") + string := concat(string,_ + "recommended since the function is a sum of squares.") [getMeasure(R,e04fdf@Symbol)$RoutinesTable, string] measure(R:RoutinesTable,args:LSA) == @@ -51282,7 +57475,7 @@ e04fdfAnnaType(): NumericalOptimizationCategory == Result add x := mat(args.init,1) (a := sumOfSquares(argsFn)) case EDF => ArgsFn := vector([edf2ef(a)])$VEF - f : Union(fn:FileName,fp:Asp50(LSFUN1)) := [retract(ArgsFn)$Asp50(LSFUN1)] + f : Union(fn:FileName,fp:Asp50(LSFUN1)):= [retract(ArgsFn)$Asp50(LSFUN1)] out:Result := e04fdf(1,1,1,lw,x,-1,f) changeNameToObjf(fsumsq@Symbol,out) empty()$Result @@ -51293,7 +57486,6 @@ e04fdfAnnaType(): NumericalOptimizationCategory == Result add n:NNI := #(variables(args)) nn:INT := n lw:INT := --- one?(nn) => 9+5*m (nn = 1) => 9+5*m nn*(7+n+2*m+((nn-1) quo 2)$INT)+3*m x := mat(args.init,n) @@ -51307,6 +57499,86 @@ e04fdfAnnaType(): NumericalOptimizationCategory == Result add \begin{chunk}{COQ E04FDFA} (* domain E04FDFA *) (* + DF ==> DoubleFloat + EF ==> Expression Float + EDF ==> Expression DoubleFloat + PDF ==> Polynomial DoubleFloat + VPDF ==> Vector Polynomial DoubleFloat + LDF ==> List DoubleFloat + LOCDF ==> List OrderedCompletion DoubleFloat + MDF ==> Matrix DoubleFloat + MPDF ==> Matrix Polynomial DoubleFloat + MF ==> Matrix Float + MEF ==> Matrix Expression Float + LEDF ==> List Expression DoubleFloat + VEF ==> Vector Expression Float + NOA ==> Record(fn:EDF, init:LDF, lb:LOCDF, cf:LEDF, ub:LOCDF) + LSA ==> Record(lfn:LEDF, init:LDF) + EF2 ==> ExpressionFunctions2 + MI ==> Matrix Integer + INT ==> Integer + F ==> Float + NNI ==> NonNegativeInteger + S ==> Symbol + LS ==> List Symbol + MVCF ==> MultiVariableCalculusFunctions + ESTOOLS2 ==> ExpertSystemToolsPackage2 + SDF ==> Stream DoubleFloat + LSDF ==> List Stream DoubleFloat + SOCDF ==> Segment OrderedCompletion DoubleFloat + OCDF ==> OrderedCompletion DoubleFloat + + Rep:=Result + import Rep, NagOptimisationPackage + import e04AgentsPackage,ExpertSystemToolsPackage + + measure(R:RoutinesTable,args:NOA) == + argsFn := args.fn + string:String := "e04fdf is " + positive?(#(args.cf) + #(args.lb) + #(args.ub)) => + string := concat(string,"unsuitable for constrained problems. ") + [0.0,string] + n:NNI := #(variables(argsFn)$EDF) + (n>1)@Boolean => + string := concat(string,_ + "unsuitable for single instances of multivariate problems. ") + [0.0,string] + sumOfSquares(argsFn) case "failed" => + string := concat(string,"unsuitable.") + [0.0,string] + string := concat(string,_ + "recommended since the function is a sum of squares.") + [getMeasure(R,e04fdf@Symbol)$RoutinesTable, string] + + measure(R:RoutinesTable,args:LSA) == + string:String := "e04fdf is recommended" + [getMeasure(R,e04fdf@Symbol)$RoutinesTable, string] + + numericalOptimization(args:NOA) == + argsFn := args.fn + lw:INT := 14 + x := mat(args.init,1) + (a := sumOfSquares(argsFn)) case EDF => + ArgsFn := vector([edf2ef(a)])$VEF + f : Union(fn:FileName,fp:Asp50(LSFUN1)):= [retract(ArgsFn)$Asp50(LSFUN1)] + out:Result := e04fdf(1,1,1,lw,x,-1,f) + changeNameToObjf(fsumsq@Symbol,out) + empty()$Result + + numericalOptimization(args:LSA) == + argsFn := copy args.lfn + m:INT := #(argsFn) + n:NNI := #(variables(args)) + nn:INT := n + lw:INT := + (nn = 1) => 9+5*m + nn*(7+n+2*m+((nn-1) quo 2)$INT)+3*m + x := mat(args.init,n) + ArgsFn := vector([edf2ef(i)$ExpertSystemToolsPackage for i in argsFn])$VEF + f : Union(fn:FileName,fp:Asp50(LSFUN1)) := [retract(ArgsFn)$Asp50(LSFUN1)] + out:Result := e04fdf(m,n,1,lw,x,-1,f) + changeNameToObjf(fsumsq@Symbol,out) + *) \end{chunk} @@ -51442,7 +57714,8 @@ e04gcfAnnaType(): NumericalOptimizationCategory == Result add [0.0,string] n:NNI := #(variables(argsFn)$EDF) (n>1)@Boolean => - string := concat(string,"unsuitable for single instances of multivariate problems. ") + string := concat(string,_ + "unsuitable for single instances of multivariate problems. ") [0.0,string] a := coerce(float(10,0,10))$OCDF seg:SOCDF := -a..a @@ -51454,14 +57727,16 @@ e04gcfAnnaType(): NumericalOptimizationCategory == Result add sumOfSquares(args.fn) case "failed" => string := concat(string,"unsuitable.") [0.0,string] - string := concat(string,"recommended since the function is a sum of squares.") + string := concat(string,_ + "recommended since the function is a sum of squares.") [getMeasure(R,e04gcf@Symbol)$RoutinesTable, string] measure(R:RoutinesTable,args:LSA) == string:String := "e04gcf is " a := coerce(float(10,0,10))$OCDF seg:SOCDF := -a..a - sings := concat([singularitiesOf(i,variables(args),seg) for i in args.lfn])$SDF + sings := _ + concat([singularitiesOf(i,variables(args),seg) for i in args.lfn])$SDF s := #(sdf2lst(sings)) positive? s => string := concat(string,"not recommended for discontinuous functions.") @@ -51477,7 +57752,7 @@ e04gcfAnnaType(): NumericalOptimizationCategory == Result add x := mat(args.init,1) (a := sumOfSquares(argsFn)) case EDF => ArgsFn := vector([edf2ef(a)$ExpertSystemToolsPackage])$VEF - f : Union(fn:FileName,fp:Asp19(LSFUN2)) := [retract(ArgsFn)$Asp19(LSFUN2)] + f : Union(fn:FileName,fp:Asp19(LSFUN2)):= [retract(ArgsFn)$Asp19(LSFUN2)] out:Result := e04gcf(1,1,1,lw,x,-1,f) changeNameToObjf(fsumsq@Symbol,out) empty()$Result @@ -51487,7 +57762,6 @@ e04gcfAnnaType(): NumericalOptimizationCategory == Result add m:NNI := #(argsFn) n:NNI := #(variables(args)) lw:INT := --- one?(n) => 11+5*m (n = 1) => 11+5*m 2*n*(4+n+m)+3*m x := mat(args.init,n) @@ -51501,6 +57775,103 @@ e04gcfAnnaType(): NumericalOptimizationCategory == Result add \begin{chunk}{COQ E04GCFA} (* domain E04GCFA *) (* + DF ==> DoubleFloat + EF ==> Expression Float + EDF ==> Expression DoubleFloat + PDF ==> Polynomial DoubleFloat + VPDF ==> Vector Polynomial DoubleFloat + LDF ==> List DoubleFloat + LOCDF ==> List OrderedCompletion DoubleFloat + MDF ==> Matrix DoubleFloat + MPDF ==> Matrix Polynomial DoubleFloat + MF ==> Matrix Float + MEF ==> Matrix Expression Float + LEDF ==> List Expression DoubleFloat + VEF ==> Vector Expression Float + NOA ==> Record(fn:EDF, init:LDF, lb:LOCDF, cf:LEDF, ub:LOCDF) + LSA ==> Record(lfn:LEDF, init:LDF) + EF2 ==> ExpressionFunctions2 + MI ==> Matrix Integer + INT ==> Integer + F ==> Float + NNI ==> NonNegativeInteger + S ==> Symbol + LS ==> List Symbol + MVCF ==> MultiVariableCalculusFunctions + ESTOOLS2 ==> ExpertSystemToolsPackage2 + SDF ==> Stream DoubleFloat + LSDF ==> List Stream DoubleFloat + SOCDF ==> Segment OrderedCompletion DoubleFloat + OCDF ==> OrderedCompletion DoubleFloat + + Rep:=Result + import Rep, NagOptimisationPackage,ExpertSystemContinuityPackage + import e04AgentsPackage,ExpertSystemToolsPackage + + measure(R:RoutinesTable,args:NOA) == + argsFn:EDF := args.fn + string:String := "e04gcf is " + positive?(#(args.cf) + #(args.lb) + #(args.ub)) => + string := concat(string,"unsuitable for constrained problems. ") + [0.0,string] + n:NNI := #(variables(argsFn)$EDF) + (n>1)@Boolean => + string := concat(string,_ + "unsuitable for single instances of multivariate problems. ") + [0.0,string] + a := coerce(float(10,0,10))$OCDF + seg:SOCDF := -a..a + sings := singularitiesOf(argsFn,variables(argsFn)$EDF,seg) + s := #(sdf2lst(sings)) + positive? s => + string := concat(string,"not recommended for discontinuous functions.") + [0.0,string] + sumOfSquares(args.fn) case "failed" => + string := concat(string,"unsuitable.") + [0.0,string] + string := concat(string,_ + "recommended since the function is a sum of squares.") + [getMeasure(R,e04gcf@Symbol)$RoutinesTable, string] + + measure(R:RoutinesTable,args:LSA) == + string:String := "e04gcf is " + a := coerce(float(10,0,10))$OCDF + seg:SOCDF := -a..a + sings := _ + concat([singularitiesOf(i,variables(args),seg) for i in args.lfn])$SDF + s := #(sdf2lst(sings)) + positive? s => + string := concat(string,"not recommended for discontinuous functions.") + [0.0,string] + string := concat(string,"recommended.") + m := getMeasure(R,e04gcf@Symbol)$RoutinesTable + m := m-(1-exp(-(expenseOfEvaluation(args))**3)) + [m, string] + + numericalOptimization(args:NOA) == + argsFn:EDF := args.fn + lw:INT := 16 + x := mat(args.init,1) + (a := sumOfSquares(argsFn)) case EDF => + ArgsFn := vector([edf2ef(a)$ExpertSystemToolsPackage])$VEF + f : Union(fn:FileName,fp:Asp19(LSFUN2)):= [retract(ArgsFn)$Asp19(LSFUN2)] + out:Result := e04gcf(1,1,1,lw,x,-1,f) + changeNameToObjf(fsumsq@Symbol,out) + empty()$Result + + numericalOptimization(args:LSA) == + argsFn := copy args.lfn + m:NNI := #(argsFn) + n:NNI := #(variables(args)) + lw:INT := + (n = 1) => 11+5*m + 2*n*(4+n+m)+3*m + x := mat(args.init,n) + ArgsFn := vector([edf2ef(i)$ExpertSystemToolsPackage for i in argsFn])$VEF + f : Union(fn:FileName,fp:Asp19(LSFUN2)) := [retract(ArgsFn)$Asp19(LSFUN2)] + out:Result := e04gcf(m,n,1,lw,x,-1,f) + changeNameToObjf(fsumsq@Symbol,out) + *) \end{chunk} @@ -51630,9 +58001,7 @@ e04jafAnnaType(): NumericalOptimizationCategory == Result add bound(a:LOCDF,b:LOCDF):Integer == empty?(concat(a,b)) => 1 --- one?(#(removeDuplicates(a))) and zero?(first(a)) => 2 (#(removeDuplicates(a)) = 1) and zero?(first(a)) => 2 --- one?(#(removeDuplicates(a))) and one?(#(removeDuplicates(b))) => 3 (#(removeDuplicates(a)) = 1) and (#(removeDuplicates(b)) = 1) => 3 0 @@ -51641,7 +58010,8 @@ e04jafAnnaType(): NumericalOptimizationCategory == Result add if positive?(#(args.cf)) then if not simpleBounds?(args.cf) then string := - concat(string,"suitable for simple bounds only, not constraint functions.") + concat(string,_ + "suitable for simple bounds only, not constraint functions.") (# string) < 20 => if zero?(#(args.lb) + #(args.ub)) then string := concat(string, "usable if there are no constraints") @@ -51670,6 +58040,75 @@ e04jafAnnaType(): NumericalOptimizationCategory == Result add \begin{chunk}{COQ E04JAFA} (* domain E04JAFA *) (* + DF ==> DoubleFloat + EF ==> Expression Float + EDF ==> Expression DoubleFloat + PDF ==> Polynomial DoubleFloat + VPDF ==> Vector Polynomial DoubleFloat + LDF ==> List DoubleFloat + LOCDF ==> List OrderedCompletion DoubleFloat + MDF ==> Matrix DoubleFloat + MPDF ==> Matrix Polynomial DoubleFloat + MF ==> Matrix Float + MEF ==> Matrix Expression Float + LEDF ==> List Expression DoubleFloat + VEF ==> Vector Expression Float + NOA ==> Record(fn:EDF, init:LDF, lb:LOCDF, cf:LEDF, ub:LOCDF) + LSA ==> Record(lfn:LEDF, init:LDF) + EF2 ==> ExpressionFunctions2 + MI ==> Matrix Integer + INT ==> Integer + F ==> Float + NNI ==> NonNegativeInteger + S ==> Symbol + LS ==> List Symbol + MVCF ==> MultiVariableCalculusFunctions + ESTOOLS2 ==> ExpertSystemToolsPackage2 + SDF ==> Stream DoubleFloat + LSDF ==> List Stream DoubleFloat + SOCDF ==> Segment OrderedCompletion DoubleFloat + OCDF ==> OrderedCompletion DoubleFloat + + Rep:=Result + import Rep, NagOptimisationPackage + import e04AgentsPackage,ExpertSystemToolsPackage + + bound(a:LOCDF,b:LOCDF):Integer == + empty?(concat(a,b)) => 1 + (#(removeDuplicates(a)) = 1) and zero?(first(a)) => 2 + (#(removeDuplicates(a)) = 1) and (#(removeDuplicates(b)) = 1) => 3 + 0 + + measure(R:RoutinesTable,args:NOA) == + string:String := "e04jaf is " + if positive?(#(args.cf)) then + if not simpleBounds?(args.cf) then + string := + concat(string,_ + "suitable for simple bounds only, not constraint functions.") + (# string) < 20 => + if zero?(#(args.lb) + #(args.ub)) then + string := concat(string, "usable if there are no constraints") + [getMeasure(R,e04jaf@Symbol)$RoutinesTable*0.5,string] + else + string := concat(string,"recommended") + [getMeasure(R,e04jaf@Symbol)$RoutinesTable, string] + [0.0,string] + + numericalOptimization(args:NOA) == + argsFn:EDF := args.fn + n:NNI := #(variables(argsFn)$EDF) + ibound:INT := bound(args.lb,args.ub) + m:INT := n + lw:INT := max(13,12 * m + ((m * (m - 1)) quo 2)$INT)$INT + bl := mat(finiteBound(args.lb,float(1,6,10)$DF),n) + bu := mat(finiteBound(args.ub,float(1,6,10)$DF),n) + x := mat(args.init,n) + ArgsFn:EF := edf2ef(argsFn) + fr:Union(fn:FileName,fp:Asp24(FUNCT1)) := [retract(ArgsFn)$Asp24(FUNCT1)] + out:Result := e04jaf(n,ibound,n+2,lw,bl,bu,x,-1,fr) + changeNameToObjf(f@Symbol,out) + *) \end{chunk} @@ -51805,7 +58244,8 @@ e04mbfAnnaType(): NumericalOptimizationCategory == Result add numericalOptimization(args:NOA) == argsFn:EDF := args.fn c := args.cf - listVars:List LS := concat(variables(argsFn)$EDF,[variables(z)$EDF for z in c]) + listVars:List LS := _ + concat(variables(argsFn)$EDF,[variables(z)$EDF for z in c]) n:NNI := #(v := removeDuplicates(concat(listVars)$LS)$LS) A:MDF := linearMatrix(args.cf,n) nclin:NNI := # linearPart(c) @@ -51817,7 +58257,8 @@ e04mbfAnnaType(): NumericalOptimizationCategory == Result add lwork:INT := nclin < n => 2*nclin*(nclin+4)+2+6*n+nrowa 2*(n+3)*n+4*nclin+nrowa - out:Result := e04mbf(20,1,n,nclin,n+nclin,nrowa,A,bl,bu,cvec,true,2*n,lwork,x,-1) + out:Result := _ + e04mbf(20,1,n,nclin,n+nclin,nrowa,A,bl,bu,cvec,true,2*n,lwork,x,-1) changeNameToObjf(objlp@Symbol,out) \end{chunk} @@ -51825,13 +58266,71 @@ e04mbfAnnaType(): NumericalOptimizationCategory == Result add \begin{chunk}{COQ E04MBFA} (* domain E04MBFA *) (* -*) + DF ==> DoubleFloat + EF ==> Expression Float + EDF ==> Expression DoubleFloat + PDF ==> Polynomial DoubleFloat + VPDF ==> Vector Polynomial DoubleFloat + LDF ==> List DoubleFloat + LOCDF ==> List OrderedCompletion DoubleFloat + MDF ==> Matrix DoubleFloat + MPDF ==> Matrix Polynomial DoubleFloat + MF ==> Matrix Float + MEF ==> Matrix Expression Float + LEDF ==> List Expression DoubleFloat + VEF ==> Vector Expression Float + NOA ==> Record(fn:EDF, init:LDF, lb:LOCDF, cf:LEDF, ub:LOCDF) + LSA ==> Record(lfn:LEDF, init:LDF) + EF2 ==> ExpressionFunctions2 + MI ==> Matrix Integer + INT ==> Integer + F ==> Float + NNI ==> NonNegativeInteger + S ==> Symbol + LS ==> List Symbol + MVCF ==> MultiVariableCalculusFunctions + ESTOOLS2 ==> ExpertSystemToolsPackage2 + SDF ==> Stream DoubleFloat + LSDF ==> List Stream DoubleFloat + SOCDF ==> Segment OrderedCompletion DoubleFloat + OCDF ==> OrderedCompletion DoubleFloat -\end{chunk} + Rep:=Result + import Rep, NagOptimisationPackage + import e04AgentsPackage,ExpertSystemToolsPackage -\begin{chunk}{E04MBFA.dotabb} -"E04MBFA" [color="#88FF44",href="bookvol10.3.pdf#nameddest=E04MBFA"] -"TRANFUN" [color="#4488FF",href="bookvol10.2.pdf#nameddest=TRANFUN"] + measure(R:RoutinesTable,args:NOA) == + (not linear?([args.fn])) or (not linear?(args.cf)) => + [0.0,"e04mbf is for a linear objective function and constraints only."] + [getMeasure(R,e04mbf@Symbol)$RoutinesTable,"e04mbf is recommended" ] + + numericalOptimization(args:NOA) == + argsFn:EDF := args.fn + c := args.cf + listVars:List LS := _ + concat(variables(argsFn)$EDF,[variables(z)$EDF for z in c]) + n:NNI := #(v := removeDuplicates(concat(listVars)$LS)$LS) + A:MDF := linearMatrix(args.cf,n) + nclin:NNI := # linearPart(c) + nrowa:NNI := max(1,nclin) + bl:MDF := mat(finiteBound(args.lb,float(1,21,10)$DF),n) + bu:MDF := mat(finiteBound(args.ub,float(1,21,10)$DF),n) + cvec:MDF := mat(coefficients(retract(argsFn)@PDF)$PDF,n) + x := mat(args.init,n) + lwork:INT := + nclin < n => 2*nclin*(nclin+4)+2+6*n+nrowa + 2*(n+3)*n+4*nclin+nrowa + out:Result := _ + e04mbf(20,1,n,nclin,n+nclin,nrowa,A,bl,bu,cvec,true,2*n,lwork,x,-1) + changeNameToObjf(objlp@Symbol,out) + +*) + +\end{chunk} + +\begin{chunk}{E04MBFA.dotabb} +"E04MBFA" [color="#88FF44",href="bookvol10.3.pdf#nameddest=E04MBFA"] +"TRANFUN" [color="#4488FF",href="bookvol10.2.pdf#nameddest=TRANFUN"] "E04MBFA" -> "TRANFUN" \end{chunk} @@ -51966,7 +58465,8 @@ e04nafAnnaType(): NumericalOptimizationCategory == Result add numericalOptimization(args:NOA) == argsFn:EDF := args.fn c := args.cf - listVars:List LS := concat(variables(argsFn)$EDF,[variables(z)$EDF for z in c]) + listVars:List LS := _ + concat(variables(argsFn)$EDF,[variables(z)$EDF for z in c]) n:NNI := #(v := sort(removeDuplicates(concat(listVars)$LS)$LS)$LS) A:MDF := linearMatrix(c,n) nclin:NNI := # linearPart(c) @@ -51995,6 +58495,78 @@ e04nafAnnaType(): NumericalOptimizationCategory == Result add \begin{chunk}{COQ E04NAFA} (* domain E04NAFA *) (* + DF ==> DoubleFloat + EF ==> Expression Float + EDF ==> Expression DoubleFloat + PDF ==> Polynomial DoubleFloat + VPDF ==> Vector Polynomial DoubleFloat + LDF ==> List DoubleFloat + LOCDF ==> List OrderedCompletion DoubleFloat + MDF ==> Matrix DoubleFloat + MPDF ==> Matrix Polynomial DoubleFloat + MF ==> Matrix Float + MEF ==> Matrix Expression Float + LEDF ==> List Expression DoubleFloat + VEF ==> Vector Expression Float + NOA ==> Record(fn:EDF, init:LDF, lb:LOCDF, cf:LEDF, ub:LOCDF) + LSA ==> Record(lfn:LEDF, init:LDF) + EF2 ==> ExpressionFunctions2 + MI ==> Matrix Integer + INT ==> Integer + F ==> Float + NNI ==> NonNegativeInteger + S ==> Symbol + LS ==> List Symbol + MVCF ==> MultiVariableCalculusFunctions + ESTOOLS2 ==> ExpertSystemToolsPackage2 + SDF ==> Stream DoubleFloat + LSDF ==> List Stream DoubleFloat + SOCDF ==> Segment OrderedCompletion DoubleFloat + OCDF ==> OrderedCompletion DoubleFloat + + Rep:=Result + import Rep, NagOptimisationPackage + import e04AgentsPackage,ExpertSystemToolsPackage + + measure(R:RoutinesTable,args:NOA) == + string:String := "e04naf is " + argsFn:EDF := args.fn + if not (quadratic?(argsFn) and linear?(args.cf)) then + string := + concat(string,"for a quadratic function with linear constraints only.") + (# string) < 20 => + string := concat(string,"recommended") + [getMeasure(R,e04naf@Symbol)$RoutinesTable, string] + [0.0,string] + + numericalOptimization(args:NOA) == + argsFn:EDF := args.fn + c := args.cf + listVars:List LS := _ + concat(variables(argsFn)$EDF,[variables(z)$EDF for z in c]) + n:NNI := #(v := sort(removeDuplicates(concat(listVars)$LS)$LS)$LS) + A:MDF := linearMatrix(c,n) + nclin:NNI := # linearPart(c) + nrowa:NNI := max(1,nclin) + big:DF := float(1,10,10)$DF + fea:MDF := new(1,n+nclin,float(1053,-11,10)$DF)$MDF + bl:MDF := mat(finiteBound(args.lb,float(1,21,10)$DF),n) + bu:MDF := mat(finiteBound(args.ub,float(1,21,10)$DF),n) + alin:EDF := splitLinear(argsFn) + p:PDF := retract(alin)@PDF + pl:List PDF := [coefficient(p,i,1)$PDF for i in v] + cvec:MDF := mat([pdf2df j for j in pl],n) + h1:MPDF := hessian(p,v)$MVCF(S,PDF,VPDF,LS) + hess:MDF := map(pdf2df,h1)$ESTOOLS2(PDF,DF) + h2:MEF := map(df2ef,hess)$ESTOOLS2(DF,EF) + x := mat(args.init,n) + istate:MI := zero(1,n+nclin)$MI + lwork:INT := 2*n*(n+2*nclin)+nrowa + qphess:Union(fn:FileName,fp:Asp20(QPHESS)) := [retract(h2)$Asp20(QPHESS)] + out:Result := e04naf(20,1,n,nclin,n+nclin,nrowa,n,n,big,A,bl,bu,cvec,fea, + hess,true,false,true,2*n,lwork,x,istate,-1,qphess) + changeNameToObjf(obj@Symbol,out) + *) \end{chunk} @@ -52123,18 +58695,20 @@ e04ucfAnnaType(): NumericalOptimizationCategory == Result add import e04AgentsPackage,ExpertSystemToolsPackage measure(R:RoutinesTable,args:NOA) == - zero?(#(args.lb) + #(args.ub)) => - [0.0,"e04ucf is not recommended if there are no bounds specified"] - zero?(#(args.cf)) => - string:String := "e04ucf is usable but not always recommended if there are no constraints" - [getMeasure(R,e04ucf@Symbol)$RoutinesTable*0.5,string] - [getMeasure(R,e04ucf@Symbol)$RoutinesTable,"e04ucf is recommended"] + zero?(#(args.lb) + #(args.ub)) => + [0.0,"e04ucf is not recommended if there are no bounds specified"] + zero?(#(args.cf)) => + string:String := _ + "e04ucf is usable but not always recommended if there are no constraints" + [getMeasure(R,e04ucf@Symbol)$RoutinesTable*0.5,string] + [getMeasure(R,e04ucf@Symbol)$RoutinesTable,"e04ucf is recommended"] numericalOptimization(args:NOA) == Args := sortConstraints(args) argsFn := Args.fn c := Args.cf - listVars:List LS := concat(variables(argsFn)$EDF,[variables(z)$EDF for z in c]) + listVars:List LS := _ + concat(variables(argsFn)$EDF,[variables(z)$EDF for z in c]) n:NNI := #(v := sort(removeDuplicates(concat(listVars)$LS)$LS)$LS) lin:NNI := #(linearPart(c)) nlcf := nonLinearPart(c) @@ -52170,8 +58744,8 @@ e04ucfAnnaType(): NumericalOptimizationCategory == Result add x:MDF := mat(Args.init,n) VectCF:VEF := vector([edf2ef e for e in nlcf])$VEF ArgsFn:EF := edf2ef(argsFn) - fasp : Union(fn:FileName,fp:Asp49(OBJFUN)) := [retract(ArgsFn)$Asp49(OBJFUN)] - casp : Union(fn:FileName,fp:Asp55(CONFUN)) := [retract(VectCF)$Asp55(CONFUN)] + fasp : Union(fn:FileName,fp:Asp49(OBJFUN)):=[retract(ArgsFn)$Asp49(OBJFUN)] + casp : Union(fn:FileName,fp:Asp55(CONFUN)):=[retract(VectCF)$Asp55(CONFUN)] e04ucf(n,lin,nonlin,nrowa,nrowj,n,A,bl,bu,liwork,lwork,false,cra,3,fea, fun,true,infb,infb,fea,lint,true,maji,1,mini,0,-1,nonf,opt,ste,1, 1,n,n,3,istate,cjac,clambda,r,x,-1,casp,fasp) @@ -52181,6 +58755,95 @@ e04ucfAnnaType(): NumericalOptimizationCategory == Result add \begin{chunk}{COQ E04UCFA} (* domain E04UCFA *) (* + DF ==> DoubleFloat + EF ==> Expression Float + EDF ==> Expression DoubleFloat + PDF ==> Polynomial DoubleFloat + VPDF ==> Vector Polynomial DoubleFloat + LDF ==> List DoubleFloat + LOCDF ==> List OrderedCompletion DoubleFloat + MDF ==> Matrix DoubleFloat + MPDF ==> Matrix Polynomial DoubleFloat + MF ==> Matrix Float + MEF ==> Matrix Expression Float + LEDF ==> List Expression DoubleFloat + VEF ==> Vector Expression Float + NOA ==> Record(fn:EDF, init:LDF, lb:LOCDF, cf:LEDF, ub:LOCDF) + LSA ==> Record(lfn:LEDF, init:LDF) + EF2 ==> ExpressionFunctions2 + MI ==> Matrix Integer + INT ==> Integer + F ==> Float + NNI ==> NonNegativeInteger + S ==> Symbol + LS ==> List Symbol + MVCF ==> MultiVariableCalculusFunctions + ESTOOLS2 ==> ExpertSystemToolsPackage2 + SDF ==> Stream DoubleFloat + LSDF ==> List Stream DoubleFloat + SOCDF ==> Segment OrderedCompletion DoubleFloat + OCDF ==> OrderedCompletion DoubleFloat + + Rep:=Result + import Rep,NagOptimisationPackage + import e04AgentsPackage,ExpertSystemToolsPackage + + measure(R:RoutinesTable,args:NOA) == + zero?(#(args.lb) + #(args.ub)) => + [0.0,"e04ucf is not recommended if there are no bounds specified"] + zero?(#(args.cf)) => + string:String := _ + "e04ucf is usable but not always recommended if there are no constraints" + [getMeasure(R,e04ucf@Symbol)$RoutinesTable*0.5,string] + [getMeasure(R,e04ucf@Symbol)$RoutinesTable,"e04ucf is recommended"] + + numericalOptimization(args:NOA) == + Args := sortConstraints(args) + argsFn := Args.fn + c := Args.cf + listVars:List LS := _ + concat(variables(argsFn)$EDF,[variables(z)$EDF for z in c]) + n:NNI := #(v := sort(removeDuplicates(concat(listVars)$LS)$LS)$LS) + lin:NNI := #(linearPart(c)) + nlcf := nonLinearPart(c) + nonlin:NNI := #(nlcf) + if empty?(nlcf) then + nlcf := new(n,coerce(first(v)$LS)$EDF)$LEDF + nrowa:NNI := max(1,lin) + nrowj:NNI := max(1,nonlin) + A:MDF := linearMatrix(c,n) + bl:MDF := mat(finiteBound(Args.lb,float(1,25,10)$DF),n) + bu:MDF := mat(finiteBound(Args.ub,float(1,25,10)$DF),n) + liwork:INT := 3*n+lin+2*nonlin + lwork:INT := + zero?(lin+nonlin) => 20*n + zero?(nonlin) => 2*n*(n+10)+11*lin + 2*n*(n+nonlin+10)+(11+n)*lin + 21*nonlin + cra:DF := float(1,-2,10)$DF + fea:DF := float(1053671201,-17,10)$DF + fun:DF := float(4373903597,-24,10)$DF + infb:DF := float(1,15,10)$DF + lint:DF := float(9,-1,10)$DF + maji:INT := max(50,3*(n+lin)+10*nonlin) + mini:INT := max(50,3*(n+lin+nonlin)) + nonf:DF := float(105,-10,10)$DF + opt:DF := float(326,-10,10)$DF + ste:DF := float(2,0,10)$DF + istate:MI := zero(1,n+lin+nonlin)$MI + cjac:MDF := + positive?(nonlin) => zero(nrowj,n)$MDF + zero(nrowj,1)$MDF + clambda:MDF := zero(1,n+lin+nonlin)$MDF + r:MDF := zero(n,n)$MDF + x:MDF := mat(Args.init,n) + VectCF:VEF := vector([edf2ef e for e in nlcf])$VEF + ArgsFn:EF := edf2ef(argsFn) + fasp : Union(fn:FileName,fp:Asp49(OBJFUN)):=[retract(ArgsFn)$Asp49(OBJFUN)] + casp : Union(fn:FileName,fp:Asp55(CONFUN)):=[retract(VectCF)$Asp55(CONFUN)] + e04ucf(n,lin,nonlin,nrowa,nrowj,n,A,bl,bu,liwork,lwork,false,cra,3,fea, + fun,true,infb,infb,fea,lint,true,maji,1,mini,0,-1,nonf,opt,ste,1, + 1,n,n,3,istate,cjac,clambda,r,x,-1,casp,fasp) + *) \end{chunk} @@ -53172,24 +59835,27 @@ Factored(R: IntegralDomain): Exports == Implementation where empty?(lf := reverse factorList x) => convert(unit x)@InputForm l := empty()$List(InputForm) for rec in lf repeat --- one?(rec.fctr) => l ((rec.fctr) = 1) => l - iFactor : InputForm := binary( convert("::" :: Symbol)@InputForm, [convert(rec.fctr)@InputForm, (devaluate R)$Lisp :: InputForm ]$List(InputForm) ) + iFactor : InputForm := _ + binary( convert("::" :: Symbol)@InputForm, _ + [convert(rec.fctr)@InputForm, _ + (devaluate R)$Lisp :: InputForm ]$List(InputForm) ) iExpon : InputForm := convert(rec.xpnt)@InputForm iFun : List InputForm := rec.flg case "nil" => - [convert("nilFactor" :: Symbol)@InputForm, iFactor, iExpon]$List(InputForm) + [convert("nilFactor" :: Symbol)@InputForm, iFactor, _ + iExpon]$List(InputForm) rec.flg case "sqfr" => - [convert("sqfrFactor" :: Symbol)@InputForm, iFactor, iExpon]$List(InputForm) + [convert("sqfrFactor" :: Symbol)@InputForm, iFactor, _ + iExpon]$List(InputForm) rec.flg case "prime" => - [convert("primeFactor" :: Symbol)@InputForm, iFactor, iExpon]$List(InputForm) + [convert("primeFactor" :: Symbol)@InputForm, iFactor, _ + iExpon]$List(InputForm) rec.flg case "irred" => - [convert("irreducibleFactor" :: Symbol)@InputForm, iFactor, iExpon]$List(InputForm) + [convert("irreducibleFactor" :: Symbol)@InputForm, iFactor, _ + iExpon]$List(InputForm) nil$List(InputForm) l := concat( iFun pretend InputForm, l ) --- one?(rec.xpnt) => --- l := concat(convert(rec.fctr)@InputForm, l) --- l := concat(convert(rec.fctr)@InputForm ** rec.xpnt, l) empty? l => convert(unit x)@InputForm if unit x ^= 1 then l := concat(convert(unit x)@InputForm,l) empty? rest l => first l @@ -53199,49 +59865,71 @@ Factored(R: IntegralDomain): Exports == Implementation where -- Private function signatures: reciprocal : % -> % + qexpand : % -> R + negexp? : % -> Boolean + SimplifyFactorization : List FF -> List FF + LispLessP : (FF, FF) -> Boolean + mkFF : (R, List FF) -> % + SimplifyFactorization1 : (FF, List FF) -> List FF + stricterFlag : (fUnion, fUnion) -> fUnion nilFactor(r, i) == flagFactor(r, i, "nil") + sqfrFactor(r, i) == flagFactor(r, i, "sqfr") + irreducibleFactor(r, i) == flagFactor(r, i, "irred") + primeFactor(r, i) == flagFactor(r, i, "prime") + unit? u == (empty? u.fct) and (not zero? u.unt) + factorList u == u.fct + unit u == u.unt + numberOfFactors u == # u.fct + 0 == [1, [["nil", 0, 1]$FF]] + zero? u == # u.fct = 1 and (first u.fct).flg case "nil" and zero? (first u.fct).fctr and --- one? u.unt (u.unt = 1) + 1 == [1, empty()] + one? u == empty? u.fct and u.unt = 1 + mkFF(r, x) == [r, x] + coerce(j:Integer):% == (j::R)::% + characteristic() == characteristic()$R + i:Integer * u:% == (i :: %) * u + r:R * u:% == (r :: %) * u + factors u == [[fe.fctr, fe.xpnt] for fe in factorList u] + expand u == retract u + negexp? x == "or"/[negative?(y.xpnt) for y in factorList x] makeFR(u, l) == --- normalizing code to be installed when contents are handled better --- current squareFree returns the content as a unit part. --- if (not unit?(u)) then --- l := cons(["nil", u, 1]$FF,l) --- u := 1 unitNormalize mkFF(u, SimplifyFactorization l) if R has IntegerNumberSystem then + rational? x == true + rationalIfCan x == rational x rational x == @@ -53250,26 +59938,20 @@ Factored(R: IntegralDomain): Exports == Implementation where ** f.xpnt for f in factorList x] if R has Eltable(R, R) then + elt(x:%, v:%) == x(expand v) if R has Evalable(R) then + eval(x:%, l:List Equation %) == eval(x,[expand lhs e = expand rhs e for e in l]$List(Equation R)) if R has InnerEvalable(Symbol, R) then + eval(x:%, ls:List Symbol, lv:List %) == eval(x, ls, [expand v for v in lv]$List(R)) if R has RealConstant then - --! negcount and rest commented out since RealConstant doesn't support - --! positive? or negative? - -- negcount: % -> Integer - -- positive?(x:%):Boolean == not(zero? x) and even?(negcount x) - -- negative?(x:%):Boolean == not(zero? x) and odd?(negcount x) - -- negcount x == - -- n := count(negative?(#1.fctr), factorList x)$List(FF) - -- negative? unit x => n + 1 - -- n convert(x:%):Float == convert(unit x)@Float * @@ -53281,9 +59963,7 @@ Factored(R: IntegralDomain): Exports == Implementation where u:% * v:% == zero? u or zero? v => 0 --- one? u => v (u = 1) => v --- one? v => u (v = 1) => u mkFF(unit u * unit v, SimplifyFactorization concat(factorList u, copy factorList v)) @@ -53315,9 +59995,7 @@ Factored(R: IntegralDomain): Exports == Implementation where empty?(lf := reverse factorList x) => (unit x)::OutputForm l := empty()$List(OutputForm) for rec in lf repeat --- one?(rec.fctr) => l ((rec.fctr) = 1) => l --- one?(rec.xpnt) => ((rec.xpnt) = 1) => l := concat(rec.fctr :: OutputForm, l) l := concat(rec.fctr::OutputForm ** rec.xpnt::OutputForm, l) @@ -53368,7 +60046,6 @@ Factored(R: IntegralDomain): Exports == Implementation where unitNormalize(squareFree(r) pretend %) else coerce(r:R):% == --- one? r => 1 (r = 1) => 1 unitNormalize mkFF(1, [["nil", r, 1]$FF]) @@ -53421,7 +60098,8 @@ Factored(R: IntegralDomain): Exports == Implementation where ((u exquo nilFactor(fact.fctr, 1))::%) for fact in factorList u]) map(fn, u) == - fn(unit u) * _*/[irreducibleFactor(fn(f.fctr),f.xpnt) for f in factorList u] + fn(unit u) * _*/[irreducibleFactor(fn(f.fctr),f.xpnt)_ + for f in factorList u] u exquo v == empty?(x1 := factorList v) => unitNormal(retract v).associate * u @@ -53449,7 +60127,6 @@ Factored(R: IntegralDomain): Exports == Implementation where else un := un * (ucar.unit ** e) as := as * (ucar.associate ** e) --- if not one?(ucar.canonical) then if not ((ucar.canonical) = 1) then vl := concat([x.flg, ucar.canonical, x.xpnt], vl) [mkFF(un, empty()), mkFF(1, reverse_! vl), mkFF(as, empty())] @@ -53459,6 +60136,7 @@ Factored(R: IntegralDomain): Exports == Implementation where mkFF(unit(uca.unit)*unit(uca.canonical),factorList(uca.canonical)) if R has GcdDomain then + u + v == zero? u => v zero? v => u @@ -53466,7 +60144,6 @@ Factored(R: IntegralDomain): Exports == Implementation where (expand(u * v1) + expand(v * v1)) * u1 gcd(u, v) == --- one? u or one? v => 1 (u = 1) or (v = 1) => 1 zero? u => v zero? v => u @@ -53500,15 +60177,16 @@ Factored(R: IntegralDomain): Exports == Implementation where mkFF(1, x1) else -- R not a GCD domain + u + v == zero? u => v zero? v => u irreducibleFactor(expand u + expand v, 1) if R has UniqueFactorizationDomain then + prime? u == not(empty?(l := factorList u)) and (empty? rest l) and --- one?(l.first.xpnt) and (l.first.flg case "prime") ((l.first.xpnt) = 1) and (l.first.flg case "prime") \end{chunk} @@ -53516,6 +60194,371 @@ Factored(R: IntegralDomain): Exports == Implementation where \begin{chunk}{COQ FR} (* domain FR *) (* + + -- Representation: + -- Note: exponents are allowed to be integers so that some special cases + -- may be used in simplications + Rep := Record(unt:R, fct:List FF) + + if R has ConvertibleTo InputForm then + convert(x:%):InputForm == + empty?(lf := reverse factorList x) => convert(unit x)@InputForm + l := empty()$List(InputForm) + for rec in lf repeat + ((rec.fctr) = 1) => l + iFactor : InputForm := _ + binary( convert("::" :: Symbol)@InputForm, _ + [convert(rec.fctr)@InputForm, _ + (devaluate R)$Lisp :: InputForm ]$List(InputForm) ) + iExpon : InputForm := convert(rec.xpnt)@InputForm + iFun : List InputForm := + rec.flg case "nil" => + [convert("nilFactor" :: Symbol)@InputForm, iFactor, _ + iExpon]$List(InputForm) + rec.flg case "sqfr" => + [convert("sqfrFactor" :: Symbol)@InputForm, iFactor, _ + iExpon]$List(InputForm) + rec.flg case "prime" => + [convert("primeFactor" :: Symbol)@InputForm, iFactor, _ + iExpon]$List(InputForm) + rec.flg case "irred" => + [convert("irreducibleFactor" :: Symbol)@InputForm, iFactor, _ + iExpon]$List(InputForm) + nil$List(InputForm) + l := concat( iFun pretend InputForm, l ) + empty? l => convert(unit x)@InputForm + if unit x ^= 1 then l := concat(convert(unit x)@InputForm,l) + empty? rest l => first l + binary(convert(_*::Symbol)@InputForm, l)@InputForm + + orderedR? := R has OrderedSet + + -- Private function signatures: + reciprocal : % -> % + + qexpand : % -> R + + negexp? : % -> Boolean + + SimplifyFactorization : List FF -> List FF + + LispLessP : (FF, FF) -> Boolean + + mkFF : (R, List FF) -> % + + SimplifyFactorization1 : (FF, List FF) -> List FF + + stricterFlag : (fUnion, fUnion) -> fUnion + + nilFactor(r, i) == flagFactor(r, i, "nil") + + sqfrFactor(r, i) == flagFactor(r, i, "sqfr") + + irreducibleFactor(r, i) == flagFactor(r, i, "irred") + + primeFactor(r, i) == flagFactor(r, i, "prime") + + unit? u == (empty? u.fct) and (not zero? u.unt) + + factorList u == u.fct + + unit u == u.unt + + numberOfFactors u == # u.fct + + 0 == [1, [["nil", 0, 1]$FF]] + + zero? u == # u.fct = 1 and + (first u.fct).flg case "nil" and + zero? (first u.fct).fctr and + (u.unt = 1) + + 1 == [1, empty()] + + one? u == empty? u.fct and u.unt = 1 + + mkFF(r, x) == [r, x] + + coerce(j:Integer):% == (j::R)::% + + characteristic() == characteristic()$R + + i:Integer * u:% == (i :: %) * u + + r:R * u:% == (r :: %) * u + + factors u == [[fe.fctr, fe.xpnt] for fe in factorList u] + + expand u == retract u + + negexp? x == "or"/[negative?(y.xpnt) for y in factorList x] + + makeFR(u, l) == + unitNormalize mkFF(u, SimplifyFactorization l) + + if R has IntegerNumberSystem then + + rational? x == true + + rationalIfCan x == rational x + + rational x == + convert(unit x)@Integer * + _*/[(convert(f.fctr)@Integer)::Fraction(Integer) + ** f.xpnt for f in factorList x] + + if R has Eltable(R, R) then + + elt(x:%, v:%) == x(expand v) + + if R has Evalable(R) then + + eval(x:%, l:List Equation %) == + eval(x,[expand lhs e = expand rhs e for e in l]$List(Equation R)) + + if R has InnerEvalable(Symbol, R) then + + eval(x:%, ls:List Symbol, lv:List %) == + eval(x, ls, [expand v for v in lv]$List(R)) + + if R has RealConstant then + + convert(x:%):Float == + convert(unit x)@Float * + _*/[convert(f.fctr)@Float ** f.xpnt for f in factorList x] + + convert(x:%):DoubleFloat == + convert(unit x)@DoubleFloat * + _*/[convert(f.fctr)@DoubleFloat ** f.xpnt for f in factorList x] + + u:% * v:% == + zero? u or zero? v => 0 + (u = 1) => v + (v = 1) => u + mkFF(unit u * unit v, + SimplifyFactorization concat(factorList u, copy factorList v)) + + u:% ** n:NonNegativeInteger == + mkFF(unit(u)**n, [[x.flg, x.fctr, n * x.xpnt] for x in factorList u]) + + SimplifyFactorization x == + empty? x => empty() + x := sort_!(LispLessP, x) + x := SimplifyFactorization1(first x, rest x) + if orderedR? then x := sort_!(LispLessP, x) + x + + SimplifyFactorization1(f, x) == + empty? x => + zero?(f.xpnt) => empty() + list f + f1 := first x + f.fctr = f1.fctr => + SimplifyFactorization1([stricterFlag(f.flg, f1.flg), + f.fctr, f.xpnt + f1.xpnt], rest x) + l := SimplifyFactorization1(first x, rest x) + zero?(f.xpnt) => l + concat(f, l) + + + coerce(x:%):OutputForm == + empty?(lf := reverse factorList x) => (unit x)::OutputForm + l := empty()$List(OutputForm) + for rec in lf repeat + ((rec.fctr) = 1) => l + ((rec.xpnt) = 1) => + l := concat(rec.fctr :: OutputForm, l) + l := concat(rec.fctr::OutputForm ** rec.xpnt::OutputForm, l) + empty? l => (unit x) :: OutputForm + e := + empty? rest l => first l + reduce(_*, l) + 1 = unit x => e + (unit x)::OutputForm * e + + retract(u:%):R == + negexp? u => error "Negative exponent in factored object" + qexpand u + + qexpand u == + unit u * + _*/[y.fctr ** (y.xpnt::NonNegativeInteger) for y in factorList u] + + retractIfCan(u:%):Union(R, "failed") == + negexp? u => "failed" + qexpand u + + LispLessP(y, y1) == + orderedR? => y.fctr < y1.fctr + GGREATERP(y.fctr, y1.fctr)$Lisp => false + true + + stricterFlag(fl1, fl2) == + fl1 case "prime" => fl1 + fl1 case "irred" => + fl2 case "prime" => fl2 + fl1 + fl1 case "sqfr" => + fl2 case "nil" => fl1 + fl2 + fl2 + + if R has IntegerNumberSystem + then + coerce(r:R):% == + factor(r)$IntegerFactorizationPackage(R) pretend % + else + if R has UniqueFactorizationDomain + then + coerce(r:R):% == + zero? r => 0 + unit? r => mkFF(r, empty()) + unitNormalize(squareFree(r) pretend %) + else + coerce(r:R):% == + (r = 1) => 1 + unitNormalize mkFF(1, [["nil", r, 1]$FF]) + + u = v == + (unit u = unit v) and # u.fct = # v.fct and + set(factors u)$SRFE =$SRFE set(factors v)$SRFE + + - u == + zero? u => u + mkFF(- unit u, factorList u) + + recip u == + not empty? factorList u => "failed" + (r := recip unit u) case "failed" => "failed" + mkFF(r::R, empty()) + + reciprocal u == + mkFF((recip unit u)::R, + [[y.flg, y.fctr, - y.xpnt]$FF for y in factorList u]) + + exponent u == -- exponent of first factor + empty?(fl := factorList u) or zero? u => 0 + first(fl).xpnt + + nthExponent(u, i) == + l := factorList u + zero? u or i < 1 or i > #l => 0 + (l.(minIndex(l) + i - 1)).xpnt + + nthFactor(u, i) == + zero? u => 0 + zero? i => unit u + l := factorList u + negative? i or i > #l => 1 + (l.(minIndex(l) + i - 1)).fctr + + nthFlag(u, i) == + l := factorList u + zero? u or i < 1 or i > #l => "nil" + (l.(minIndex(l) + i - 1)).flg + + flagFactor(r, i, fl) == + zero? i => 1 + zero? r => 0 + unitNormalize mkFF(1, [[fl, r, i]$FF]) + + differentiate(u:%, deriv: R -> R) == + ans := deriv(unit u) * ((u exquo unit(u)::%)::%) + ans + (_+/[fact.xpnt * deriv(fact.fctr) * + ((u exquo nilFactor(fact.fctr, 1))::%) for fact in factorList u]) + + map(fn, u) == + fn(unit u) * _*/[irreducibleFactor(fn(f.fctr),f.xpnt)_ + for f in factorList u] + + u exquo v == + empty?(x1 := factorList v) => unitNormal(retract v).associate * u + empty? factorList u => "failed" + v1 := u * reciprocal v + goodQuotient:Boolean := true + while (goodQuotient and (not empty? x1)) repeat + if x1.first.xpnt < 0 + then goodQuotient := false + else x1 := rest x1 + goodQuotient => v1 + "failed" + + unitNormal u == -- does a bunch of work, but more canonical + (ur := recip(un := unit u)) case "failed" => [1, u, 1] + as := ur::R + vl := empty()$List(FF) + for x in factorList u repeat + ucar := unitNormal(x.fctr) + e := abs(x.xpnt)::NonNegativeInteger + if x.xpnt < 0 + then -- associate is recip of unit + un := un * (ucar.associate ** e) + as := as * (ucar.unit ** e) + else + un := un * (ucar.unit ** e) + as := as * (ucar.associate ** e) + if not ((ucar.canonical) = 1) then + vl := concat([x.flg, ucar.canonical, x.xpnt], vl) + [mkFF(un, empty()), mkFF(1, reverse_! vl), mkFF(as, empty())] + + unitNormalize u == + uca := unitNormal u + mkFF(unit(uca.unit)*unit(uca.canonical),factorList(uca.canonical)) + + if R has GcdDomain then + + u + v == + zero? u => v + zero? v => u + v1 := reciprocal(u1 := gcd(u, v)) + (expand(u * v1) + expand(v * v1)) * u1 + + gcd(u, v) == + (u = 1) or (v = 1) => 1 + zero? u => v + zero? v => u + f1 := empty()$List(Integer) -- list of used factor indices in x + f2 := f1 -- list of indices corresponding to a given factor + f3 := empty()$List(List Integer) -- list of f2-like lists + x := concat(factorList u, factorList v) + for i in minIndex x .. maxIndex x repeat + if not member?(i, f1) then + f1 := concat(i, f1) + f2 := [i] + for j in i+1..maxIndex x repeat + if x.i.fctr = x.j.fctr then + f1 := concat(j, f1) + f2 := concat(j, f2) + f3 := concat(f2, f3) + x1 := empty()$List(FF) + while not empty? f3 repeat + f1 := first f3 + if #f1 > 1 then + i := first f1 + y := copy x.i + f1 := rest f1 + while not empty? f1 repeat + i := first f1 + if x.i.xpnt < y.xpnt then y.xpnt := x.i.xpnt + f1 := rest f1 + x1 := concat(y, x1) + f3 := rest f3 + if orderedR? then x1 := sort_!(LispLessP, x1) + mkFF(1, x1) + + else -- R not a GCD domain + + u + v == + zero? u => v + zero? v => u + irreducibleFactor(expand u + expand v, 1) + + if R has UniqueFactorizationDomain then + + prime? u == + not(empty?(l := factorList u)) and (empty? rest l) and + ((l.first.xpnt) = 1) and (l.first.flg case "prime") + *) \end{chunk} @@ -54202,19 +61245,25 @@ o )show FileName FileName(): FileNameCategory == add f1 = f2 == EQUAL(f1, f2)$Lisp + coerce(f: %): OutputForm == f::String::OutputForm coerce(f: %): String == NAMESTRING(f)$Lisp + coerce(s: String): % == PARSE_-NAMESTRING(s)$Lisp filename(d,n,e) == fnameMake(d,n,e)$Lisp directory(f:%): String == fnameDirectory(f)$Lisp + name(f:%): String == fnameName(f)$Lisp + extension(f:%): String == fnameType(f)$Lisp exists? f == fnameExists?(f)$Lisp + readable? f == fnameReadable?(f)$Lisp + writable? f == fnameWritable?(f)$Lisp new(d,pref,e) == fnameNew(d,pref,e)$Lisp @@ -54224,6 +61273,31 @@ FileName(): FileNameCategory == add \begin{chunk}{COQ FNAME} (* domain FNAME *) (* + + f1 = f2 == EQUAL(f1, f2)$Lisp + + coerce(f: %): OutputForm == f::String::OutputForm + + coerce(f: %): String == NAMESTRING(f)$Lisp + + coerce(s: String): % == PARSE_-NAMESTRING(s)$Lisp + + filename(d,n,e) == fnameMake(d,n,e)$Lisp + + directory(f:%): String == fnameDirectory(f)$Lisp + + name(f:%): String == fnameName(f)$Lisp + + extension(f:%): String == fnameType(f)$Lisp + + exists? f == fnameExists?(f)$Lisp + + readable? f == fnameReadable?(f)$Lisp + + writable? f == fnameWritable?(f)$Lisp + + new(d,pref,e) == fnameNew(d,pref,e)$Lisp + *) \end{chunk} @@ -54376,20 +61450,31 @@ FiniteDivisor(F, UP, UPUP, R): Exports == Implementation where import UnivariatePolynomialCommonDenominator(UP, RF, UPUP) makeDivisor : (UP, UPUP, UP) -> % + intReduce : (R, UP) -> R ww := integralBasis()$R 0 == [1, empty()] + divisor(i:ID) == [i, empty()] + divisor(f:R) == divisor ideal [f] + coerce(d:%):OutputForm == ideal(d)::OutputForm + ideal d == d.id + decompose d == [ideal d, 1] + d1 = d2 == basis(ideal d1) = basis(ideal d2) + n * d == divisor(ideal(d) ** n) + d1 + d2 == divisor(ideal d1 * ideal d2) + - d == divisor inv ideal d + divisor(h, d, dp, g, r) == makeDivisor(d, lift h - (r * dp)::RF::UPUP, g) intReduce(h, b) == @@ -54453,6 +61538,95 @@ FiniteDivisor(F, UP, UPUP, R): Exports == Implementation where \begin{chunk}{COQ FDIV} (* domain FDIV *) (* + Rep := Record(id:ID, fbasis:Vector(R)) + + import CommonDenominator(UP, RF, Vector RF) + import UnivariatePolynomialCommonDenominator(UP, RF, UPUP) + + makeDivisor : (UP, UPUP, UP) -> % + + intReduce : (R, UP) -> R + + ww := integralBasis()$R + + 0 == [1, empty()] + + divisor(i:ID) == [i, empty()] + + divisor(f:R) == divisor ideal [f] + + coerce(d:%):OutputForm == ideal(d)::OutputForm + + ideal d == d.id + + decompose d == [ideal d, 1] + + d1 = d2 == basis(ideal d1) = basis(ideal d2) + + n * d == divisor(ideal(d) ** n) + + d1 + d2 == divisor(ideal d1 * ideal d2) + + - d == divisor inv ideal d + + divisor(h, d, dp, g, r) == makeDivisor(d, lift h - (r * dp)::RF::UPUP, g) + + intReduce(h, b) == + v := integralCoordinates(h).num + integralRepresents( + [qelt(v, i) rem b for i in minIndex v .. maxIndex v], 1) + + divisor(a, b) == + x := monomial(1, 1)$UP + not ground? gcd(d := x - a::UP, retract(discriminant())@UP) => + error "divisor: point is singular" + makeDivisor(d, monomial(1, 1)$UPUP - b::UP::RF::UPUP, 1) + + divisor(a, b, n) == + not(ground? gcd(d := monomial(1, 1)$UP - a::UP, + retract(discriminant())@UP)) and + ((n exquo rank()) case "failed") => + error "divisor: point is singular" + m:N := + n < 0 => (-n)::N + n::N + g := makeDivisor(d**m,(monomial(1,1)$UPUP - b::UP::RF::UPUP)**m,1) + n < 0 => -g + g + + reduce d == + (i := minimize(j := ideal d)) = j => d + #(n := numer i) ^= 2 => divisor i + cd := splitDenominator lift n(1 + minIndex n) + b := gcd(cd.den * retract(retract(n minIndex n)@RF)@UP, + retract(norm reduce(cd.num))@UP) + e := cd.den * denom i + divisor ideal([(b / e)::R, + reduce map((s:RF):RF+->(retract(s)@UP rem b)/e, cd.num)]$Vector(R)) + + finiteBasis d == + if empty?(d.fbasis) then + d.fbasis := normalizeAtInfinity + basis module(ideal d)$FramedModule(UP, RF, UPUP, R, ww) + d.fbasis + + generator d == + bsis := finiteBasis d + for i in minIndex bsis .. maxIndex bsis repeat + integralAtInfinity? qelt(bsis, i) => + return primitivePart qelt(bsis,i) + "failed" + + lSpaceBasis d == + map_!(primitivePart, reduceBasisAtInfinity finiteBasis(-d)) + +-- b = center, hh = integral function, g = gcd(b, discriminant) + makeDivisor(b, hh, g) == + b := gcd(b, retract(norm(h := reduce hh))@UP) + h := intReduce(h, b) + if not ground? gcd(g, b) then h := intReduce(h ** rank(), b) + divisor ideal [b::RF::R, h]$Vector(R) + *) \end{chunk} @@ -54987,13 +62161,14 @@ FiniteFieldCyclicGroup(p,extdeg):_ p : PositiveInteger extdeg : PositiveInteger PI ==> PositiveInteger - FFPOLY ==> FiniteFieldPolynomialPackage(PrimeField(p)) + FFPOLY ==> FiniteFieldPolynomialPackage(PrimeField(p)) SI ==> SingleInteger Exports ==> FiniteAlgebraicExtensionField(PrimeField(p)) with getZechTable:() -> PrimitiveArray(SingleInteger) ++ getZechTable() returns the zech logarithm table of the field. ++ This table is used to perform additions in the field quickly. - Implementation ==> FiniteFieldCyclicGroupExtensionByPolynomial(PrimeField(p),_ + Implementation ==> + FiniteFieldCyclicGroupExtensionByPolynomial(PrimeField(p),_ createPrimitivePoly(extdeg)$FFPOLY) \end{chunk} @@ -55599,6 +62774,252 @@ FiniteFieldCyclicGroupExtensionByPolynomial(GF,defpol):_ sizeFG:SI:=(sizeCG quo (size()$GF-1)) pretend SI -- the order of the factor group + zechlog:ARR:=new(((sizeFF+1) quo 2)::NNI,-1::SI)$ARR + -- the table for the zech logarithm + + alpha :=new()$Symbol :: OutputForm + -- get a new symbol for the output representation of + -- the elements + + primEltGF:GF:= + odd?(extdeg)$I => -$GF coefficient(defpol,0)$(SUP GF) + coefficient(defpol,0)$(SUP GF) + -- the corresponding primitive element of the groundfield + -- equals the trace of the primitive element w.r.t. the groundfield + + facOfGroupSize := nil()$(List Record(factor:Integer,exponent:Integer)) + -- the factorization of sizeCG + + initzech?:Boolean:=true + -- gets false after initialization of the zech logarithm array + + initelt?:Boolean:=true + -- gets false after initialization of the normal element + + normalElt:SI:=0 + -- the global variable containing a normal element + +-- functions ========================================================== + + -- for completeness we have to give a dummy implementation for + -- 'tableForDiscreteLogarithm', although this function is not + -- necessary in the cyclic group representation case + + tableForDiscreteLogarithm(fac) == table()$TBL + + getZechTable() == zechlog + + initializeZech:() -> Void + + initializeElt: () -> Void + + order(x:$):PI == + zero?(x) => + error"order: order of zero undefined" + (sizeCG quo gcd(sizeCG,x pretend NNI))::PI + + primitive?(x:$) == + zero?(x) or (x = 1) => false + gcd(x::Rep,sizeCG)$Rep = 1$Rep => true + false + + coordinates(x:$) == + x=0 => new(extdeg,0)$(Vector GF) + primElement:SAE:=convert(monomial(1,1)$(SUP GF))$SAE + -- the primitive element in the corresponding algebraic extension + coordinates(primElement **$SAE (x pretend SI))$SAE + + x:$ + y:$ == + if initzech? then initializeZech() + zero? x => y + zero? y => x + d:Rep:=positiveRemainder(y -$Rep x,sizeCG)$Rep + (d pretend SI) <= shift(sizeCG,-$SI (1$SI)) => + zechlog.(d pretend SI) =$SI -1::SI => 0 + addmod(x,zechlog.(d pretend SI) pretend Rep,sizeCG)$Rep + --d:Rep:=positiveRemainder(x -$Rep y,sizeCG)$Rep + d:Rep:=(sizeCG -$SI d)::Rep + addmod(y,zechlog.(d pretend SI) pretend Rep,sizeCG)$Rep + --positiveRemainder(x +$Rep zechlog.(d pretend SI) -$Rep d,sizeCG)$Rep + + initializeZech() == + zechlog:=createZechTable(defpol)$FFF + -- set initialization flag + initzech? := false + void()$Void + + basis(n:PI) == + extensionDegree() rem n ^= 0 => + error("argument must divide extension degree") + m:=sizeCG quo (size()$GF**n-1) + [index((1+i*m) ::PI) for i in 0..(n-1)]::Vector $ + + n:I * x:$ == ((n::GF)::$) * x + + minimalPolynomial(a) == + f:SUP $:=monomial(1,1)$(SUP $) - monomial(a,0)$(SUP $) + u:$:=Frobenius(a) + while not(u = a) repeat + f:=f * (monomial(1,1)$(SUP $) - monomial(u,0)$(SUP $)) + u:=Frobenius(u) + p:SUP GF:=0$(SUP GF) + while not zero?(f)$(SUP $) repeat + g:GF:=retract(leadingCoefficient(f)$(SUP $)) + p:=p+monomial(g,_ + degree(f)$(SUP $))$(SUP GF) + f:=reductum(f)$(SUP $) + p + + factorsOfCyclicGroupSize() == + if empty? facOfGroupSize then initializeElt() + facOfGroupSize + + representationType() == "cyclic" + + definingPolynomial() == defpol + + random() == + positiveRemainder(random()$Rep,sizeFF pretend Rep)$Rep -$Rep 1$Rep + + represents(v) == + u:FFP:=represents(v)$FFP + u =$FFP 0$FFP => 0 + discreteLog(u)$FFP pretend Rep + + coerce(e:GF):$ == + zero?(e)$GF => 0 + log:I:=discreteLog(primEltGF,e)$GF::NNI *$I sizeFG + -- version before 10.20.92: log pretend Rep + -- 1$GF is coerced to sizeCG pretend Rep by old version + -- now 1$GF is coerced to 0$Rep which is correct. + positiveRemainder(log,sizeCG) pretend Rep + + retractIfCan(x:$) == + zero? x => 0$GF + u:= (x::Rep) exquo$Rep (sizeFG pretend Rep) + u = "failed" => "failed" + primEltGF **$GF ((u::$) pretend SI) + + retract(x:$) == + a:=retractIfCan(x) + a="failed" => error "element not in groundfield" + a :: GF + + basis() == [index(i :: PI) for i in 1..extdeg]::Vector $ + + inGroundField?(x) == + zero? x=> true + positiveRemainder(x::Rep,sizeFG pretend Rep)$Rep =$Rep 0$Rep => true + false + + discreteLog(b:$,x:$) == + zero? x => "failed" + e:= extendedEuclidean(b,sizeCG,x)$Rep + e = "failed" => "failed" + e1:Record(coef1:$,coef2:$) := e :: Record(coef1:$,coef2:$) + positiveRemainder(e1.coef1,sizeCG)$Rep pretend NNI + + - x:$ == + zero? x => 0 + characteristic() =$I 2 => x + addmod(x,shift(sizeCG,-1)$SI pretend Rep,sizeCG) + + generator() == 1$SI + createPrimitiveElement() == 1$SI + primitiveElement() == 1$SI + + discreteLog(x:$) == + zero? x => error "discrete logarithm error" + x pretend NNI + + normalElement() == + if initelt? then initializeElt() + normalElt::$ + + initializeElt() == + facOfGroupSize := factors(factor(sizeCG)$Integer) + normalElt:=createNormalElement() pretend SI + initelt?:=false + void()$Void + + extensionDegree() == extdeg pretend PI + + characteristic() == characteristic()$GF + + lookup(x:$) == + x =$Rep (-$Rep 1$Rep) => sizeFF pretend PI + (x +$Rep 1$Rep) pretend PI + + index(a:PI) == + positiveRemainder(a,sizeFF)$I pretend Rep -$Rep 1$Rep + + 0 == (-$Rep 1$Rep) + + 1 == 0$Rep + +-- to get a "exponent like" output form + coerce(x:$):OUT == + x =$Rep (-$Rep 1$Rep) => "0"::OUT + x =$Rep 0$Rep => "1"::OUT + y:I:=lookup(x)-1 + alpha **$OUT (y::OUT) + + x:$ = y:$ == x =$Rep y + + x:$ * y:$ == + x = 0 => 0 + y = 0 => 0 + addmod(x,y,sizeCG)$Rep + + a:GF * x:$ == coerce(a)@$ * x + + x:$/a:GF == x/coerce(a)@$ + + inv(x:$) == + zero?(x) => error "inv: not invertible" + (x = 1) => 1 + sizeCG -$Rep x + + x:$ ** n:PI == x ** n::I + + x:$ ** n:NNI == x ** n::I + + x:$ ** n:I == + m:Rep:=positiveRemainder(n,sizeCG)$I pretend Rep + m =$Rep 0$Rep => 1 + x = 0 => 0 + mulmod(m,x,sizeCG::Rep)$Rep + +\end{chunk} + +\begin{chunk}{COQ FFCGP} +(* domain FFCGP *) +(* + + Rep:= SI + -- elements are represented by small integers in the range + -- (-1)..(size()-2). The (-1) representing the field element zero, + -- the other small integers representing the corresponding power + -- of the primitive element, the root of the defining polynomial + + -- it would be very nice if we could use the representation + -- Rep:= Union("zero", IntegerMod(size()$GF ** degree(defpol) -1)), + -- why doesn't the compiler like this ? + + extdeg:NNI :=degree(defpol)$(SUP GF)::NNI + -- the extension degree + + sizeFF:NNI:=(size()$GF ** extdeg) pretend NNI + -- the size of the field + + if sizeFF > 2**20 then + error "field too large for this representation" + + sizeCG:SI:=(sizeFF - 1) pretend SI + -- the order of the cyclic group + + sizeFG:SI:=(sizeCG quo (size()$GF-1)) pretend SI + -- the order of the factor group zechlog:ARR:=new(((sizeFF+1) quo 2)::NNI,-1::SI)$ARR -- the table for the zech logarithm @@ -55633,9 +63054,10 @@ FiniteFieldCyclicGroupExtensionByPolynomial(GF,defpol):_ tableForDiscreteLogarithm(fac) == table()$TBL - getZechTable() == zechlog + initializeZech:() -> Void + initializeElt: () -> Void order(x:$):PI == @@ -55644,7 +63066,6 @@ FiniteFieldCyclicGroupExtensionByPolynomial(GF,defpol):_ (sizeCG quo gcd(sizeCG,x pretend NNI))::PI primitive?(x:$) == --- zero?(x) or one?(x) => false zero?(x) or (x = 1) => false gcd(x::Rep,sizeCG)$Rep = 1$Rep => true false @@ -55652,7 +63073,7 @@ FiniteFieldCyclicGroupExtensionByPolynomial(GF,defpol):_ coordinates(x:$) == x=0 => new(extdeg,0)$(Vector GF) primElement:SAE:=convert(monomial(1,1)$(SUP GF))$SAE --- the primitive element in the corresponding algebraic extension + -- the primitive element in the corresponding algebraic extension coordinates(primElement **$SAE (x pretend SI))$SAE x:$ + y:$ == @@ -55668,7 +63089,6 @@ FiniteFieldCyclicGroupExtensionByPolynomial(GF,defpol):_ addmod(y,zechlog.(d pretend SI) pretend Rep,sizeCG)$Rep --positiveRemainder(x +$Rep zechlog.(d pretend SI) -$Rep d,sizeCG)$Rep - initializeZech() == zechlog:=createZechTable(defpol)$FFF -- set initialization flag @@ -55713,8 +63133,6 @@ FiniteFieldCyclicGroupExtensionByPolynomial(GF,defpol):_ u =$FFP 0$FFP => 0 discreteLog(u)$FFP pretend Rep - - coerce(e:GF):$ == zero?(e)$GF => 0 log:I:=discreteLog(primEltGF,e)$GF::NNI *$I sizeFG @@ -55723,7 +63141,6 @@ FiniteFieldCyclicGroupExtensionByPolynomial(GF,defpol):_ -- now 1$GF is coerced to 0$Rep which is correct. positiveRemainder(log,sizeCG) pretend Rep - retractIfCan(x:$) == zero? x => 0$GF u:= (x::Rep) exquo$Rep (sizeFG pretend Rep) @@ -55737,7 +63154,6 @@ FiniteFieldCyclicGroupExtensionByPolynomial(GF,defpol):_ basis() == [index(i :: PI) for i in 1..extdeg]::Vector $ - inGroundField?(x) == zero? x=> true positiveRemainder(x::Rep,sizeFG pretend Rep)$Rep =$Rep 0$Rep => true @@ -55803,15 +63219,11 @@ FiniteFieldCyclicGroupExtensionByPolynomial(GF,defpol):_ addmod(x,y,sizeCG)$Rep a:GF * x:$ == coerce(a)@$ * x - x:$/a:GF == x/coerce(a)@$ --- x:$ / a:GF == --- a = 0$GF => error "division by zero" --- x * inv(coerce(a)) + x:$/a:GF == x/coerce(a)@$ inv(x:$) == zero?(x) => error "inv: not invertible" --- one?(x) => 1 (x = 1) => 1 sizeCG -$Rep x @@ -55825,11 +63237,6 @@ FiniteFieldCyclicGroupExtensionByPolynomial(GF,defpol):_ x = 0 => 0 mulmod(m,x,sizeCG::Rep)$Rep -\end{chunk} - -\begin{chunk}{COQ FFCGP} -(* domain FFCGP *) -(* *) \end{chunk} @@ -56402,7 +63809,6 @@ FiniteFieldExtensionByPolynomial(GF:FiniteFieldCategory,_ -- gets false after initialization of the primitive and the -- normal element - discLogTable:Table(PI,TBL):=table()$Table(PI,TBL) -- tables indexed by the factors of sizeCG, -- discLogTable(factor) is a table with keys @@ -56412,19 +63818,14 @@ FiniteFieldExtensionByPolynomial(GF:FiniteFieldCategory,_ -- functions =========================================================== --- createNormalElement() == --- a:=primitiveElement() --- nElt:=generator() --- for i in 1.. repeat --- normal? nElt => return nElt --- nElt:=nElt*a --- nElt - generator() == reduce(monomial(1,1)$SUP(GF))$Rep + norm x == resultant(defpol, lift x) initializeElt: () -> Void + initializeLog: () -> Void + basis(n:PI) == (extdeg rem n) ^= 0 => error "argument must divide extension degree" a:$:=norm(primitiveElement(),n) @@ -56457,30 +63858,46 @@ FiniteFieldExtensionByPolynomial(GF:FiniteFieldCategory,_ ((rank matrix(l)$(Matrix GF)) = extdeg::NNI) => true false - a:GF * x:$ == a *$Rep x + n:I * x:$ == n *$Rep x + -x == -$Rep x + random() == random()$Rep + coordinates(x:$) == coordinates(x)$Rep + represents(v) == represents(v)$Rep + coerce(x:GF):$ == coerce(x)$Rep + definingPolynomial() == defpol + retract(x) == retract(x)$Rep + retractIfCan(x) == retractIfCan(x)$Rep + index(x) == index(x)$Rep + lookup(x) == lookup(x)$Rep + x:$/y:$ == x /$Rep y + x:$/a:GF == x/coerce(a) --- x:$ / a:GF == --- a = 0$GF => error "division by zero" --- x * inv(coerce(a)) + x:$ * y:$ == x *$Rep y + x:$ + y:$ == x +$Rep y + x:$ - y:$ == x -$Rep y + x:$ = y:$ == x =$Rep y + basis() == basis()$Rep + 0 == 0$Rep + 1 == 1$Rep factorsOfCyclicGroupSize() == @@ -56521,9 +63938,9 @@ FiniteFieldExtensionByPolynomial(GF:FiniteFieldCategory,_ initializeLog() == if initelt? then initializeElt() --- set up tables for discrete logarithm + -- set up tables for discrete logarithm limit:Integer:=30 - -- the minimum size for the discrete logarithm table + -- the minimum size for the discrete logarithm table for f in facOfGroupSize repeat fac:=f.factor base:$:=primitiveElement() ** (sizeCG quo fac) @@ -56553,8 +63970,6 @@ FiniteFieldExtensionByPolynomial(GF:FiniteFieldCategory,_ size() == (sizeCG + 1) pretend NNI --- sizeOfGroundField() == size()$GF - inGroundField?(x) == retractIfCan(x) = "failed" => false true @@ -56566,6 +63981,203 @@ FiniteFieldExtensionByPolynomial(GF:FiniteFieldCategory,_ \begin{chunk}{COQ FFP} (* domain FFP *) (* + + Rep:=SAE + + extdeg:PI := degree(defpol)$(SUP GF) pretend PI + -- the extension degree + + alpha := new()$Symbol :: OutputForm + -- a new symbol for the output form of field elements + + sizeCG:Integer := size()$GF**extdeg - 1 + -- the order of the multiplicative group + + facOfGroupSize := nil()$(List Record(factor:Integer,exponent:Integer)) + -- the factorization of sizeCG + + normalElt:PI:=1 + -- for the lookup of the normal Element computed by + -- createNormalElement + + primitiveElt:PI:=1 + -- for the lookup of the primitive Element computed by + -- createPrimitiveElement() + + initlog?:Boolean:=true + -- gets false after initialization of the discrete logarithm table + + initelt?:Boolean:=true + -- gets false after initialization of the primitive and the + -- normal element + + discLogTable:Table(PI,TBL):=table()$Table(PI,TBL) + -- tables indexed by the factors of sizeCG, + -- discLogTable(factor) is a table with keys + -- primitiveElement() ** (i * (sizeCG quo factor)) and entries i for + -- i in 0..n-1, n computed in initialize() in order to use + -- the minimal size limit 'limit' optimal. + +-- functions =========================================================== + + generator() == reduce(monomial(1,1)$SUP(GF))$Rep + + norm x == resultant(defpol, lift x) + + initializeElt: () -> Void + + initializeLog: () -> Void + + basis(n:PI) == + (extdeg rem n) ^= 0 => error "argument must divide extension degree" + a:$:=norm(primitiveElement(),n) + vector [a**i for i in 0..n-1] + + degree(x) == + y:$:=1 + m:=zero(extdeg,extdeg+1)$(Matrix GF) + for i in 1..extdeg+1 repeat + setColumn_!(m,i,coordinates(y))$(Matrix GF) + y:=y*x + rank(m)::PI + + minimalPolynomial(x:$) == + y:$:=1 + m:=zero(extdeg,extdeg+1)$(Matrix GF) + for i in 1..extdeg+1 repeat + setColumn_!(m,i,coordinates(y))$(Matrix GF) + y:=y*x + v:=first nullSpace(m)$(Matrix GF) + +/[monomial(v.(i+1),i)$(SUP GF) for i in 0..extdeg] + + + normal?(x) == + l:List List GF:=[entries coordinates x] + a:=x + for i in 2..extdeg repeat + a:=Frobenius(a) + l:=concat(l,entries coordinates a)$(List List GF) + ((rank matrix(l)$(Matrix GF)) = extdeg::NNI) => true + false + + a:GF * x:$ == a *$Rep x + + n:I * x:$ == n *$Rep x + + -x == -$Rep x + + random() == random()$Rep + + coordinates(x:$) == coordinates(x)$Rep + + represents(v) == represents(v)$Rep + + coerce(x:GF):$ == coerce(x)$Rep + + definingPolynomial() == defpol + + retract(x) == retract(x)$Rep + + retractIfCan(x) == retractIfCan(x)$Rep + + index(x) == index(x)$Rep + + lookup(x) == lookup(x)$Rep + + x:$/y:$ == x /$Rep y + + x:$/a:GF == x/coerce(a) + + x:$ * y:$ == x *$Rep y + + x:$ + y:$ == x +$Rep y + + x:$ - y:$ == x -$Rep y + + x:$ = y:$ == x =$Rep y + + basis() == basis()$Rep + + 0 == 0$Rep + + 1 == 1$Rep + + factorsOfCyclicGroupSize() == + if empty? facOfGroupSize then initializeElt() + facOfGroupSize + + representationType() == "polynomial" + + tableForDiscreteLogarithm(fac) == + if initlog? then initializeLog() + tbl:=search(fac::PI,discLogTable)$Table(PI,TBL) + tbl case "failed" => + error "tableForDiscreteLogarithm: argument must be prime divisor_ + of the order of the multiplicative group" + tbl pretend TBL + + primitiveElement() == + if initelt? then initializeElt() + index(primitiveElt) + + normalElement() == + if initelt? then initializeElt() + index(normalElt) + + initializeElt() == + facOfGroupSize:=factors(factor(sizeCG)$Integer) + -- get a primitive element + pE:=createPrimitiveElement() + primitiveElt:=lookup(pE) + -- create a normal element + nElt:=generator() + while not normal? nElt repeat + nElt:=nElt*pE + normalElt:=lookup(nElt) + -- set elements initialization flag + initelt? := false + void()$Void + + initializeLog() == + if initelt? then initializeElt() + -- set up tables for discrete logarithm + limit:Integer:=30 + -- the minimum size for the discrete logarithm table + for f in facOfGroupSize repeat + fac:=f.factor + base:$:=primitiveElement() ** (sizeCG quo fac) + l:Integer:=length(fac)$Integer + n:Integer:=0 + if odd?(l)$Integer then n:=shift(fac,-(l quo 2)) + else n:=shift(1,(l quo 2)) + if n < limit then + d:=(fac-1) quo limit + 1 + n:=(fac-1) quo d + 1 + tbl:TBL:=table()$TBL + a:$:=1 + for i in (0::NNI)..(n-1)::NNI repeat + insert_!([lookup(a),i::NNI]$R,tbl)$TBL + a:=a*base + insert_!([fac::PI,copy(tbl)$TBL]_ + $Record(key:PI,entry:TBL),discLogTable)$Table(PI,TBL) + -- set logarithm initialization flag + initlog? := false + -- tell user about initialization + --print("discrete logarithm tables initialized"::OUT) + void()$Void + + coerce(e:$):OutputForm == outputForm(lift(e),alpha) + + extensionDegree() == extdeg + + size() == (sizeCG + 1) pretend NNI + + inGroundField?(x) == + retractIfCan(x) = "failed" => false + true + + characteristic() == characteristic()$GF + *) \end{chunk} @@ -56851,7 +64463,8 @@ FiniteFieldNormalBasis(p,extdeg):_ ++ multiplication table of the field. Note: The time of multiplication ++ of field elements depends on this size. - Implementation ==> FiniteFieldNormalBasisExtensionByPolynomial(PrimeField(p),_ + Implementation ==> + FiniteFieldNormalBasisExtensionByPolynomial(PrimeField(p),_ createLowComplexityNormalBasis(extdeg)$FFF) \end{chunk} @@ -57495,18 +65108,16 @@ FiniteFieldNormalBasisExtensionByPolynomial(GF,uni): Exports == _ append([alpha, alpha **$OUT qs],_ [alpha **$OUT (qs **$OUT i::OUT) for i in 2..extdeg-1] ) - facOfGroupSize :=nil()$(List Record(factor:Integer,exponent:Integer)) -- the factorization of the cyclic group size - traceAlpha:GF:=-$GF coefficient(defpol,(degree(defpol)-1)::NNI) -- the inverse of the trace of the normalElt -- is computed here. It defines the imbedding of -- GF in the extension field primitiveElt:PI:=1 - -- for the lookup the primitive Element computed by createPrimitiveElement() + -- lookup the primitive Element computed by createPrimitiveElement() discLogTable:Table(PI,TBL):=table()$Table(PI,TBL) -- tables indexed by the factors of sizeCG, @@ -57518,9 +65129,10 @@ FiniteFieldNormalBasisExtensionByPolynomial(GF,uni): Exports == _ -- functions =========================================================== initializeLog: () -> Void + initializeElt: () -> Void - initializeMult: () -> Void + initializeMult: () -> Void coerce(v:GF):$ == new(extdeg,v /$GF traceAlpha)$Rep represents(v) == v::$ @@ -57537,10 +65149,13 @@ FiniteFieldNormalBasisExtensionByPolynomial(GF,uni): Exports == _ xm:SUP(GF):=monomial(1$GF,extdeg)$(SUP GF) - 1$(SUP GF) r:= (f * pol(x::Rep)$INBFF) rem xm vectorise(r,extdeg)$(SUP GF) + linearAssociatedLog(x) == pol(x::Rep)$INBFF + linearAssociatedOrder(x) == xm:SUP(GF):=monomial(1$GF,extdeg)$(SUP GF) - 1$(SUP GF) xm quo gcd(xm,pol(x::Rep)$INBFF) + linearAssociatedLog(b,x) == zero? x => 0 xm:SUP(GF):=monomial(1$GF,extdeg)$(SUP GF) - 1$(SUP GF) @@ -57552,16 +65167,21 @@ FiniteFieldNormalBasisExtensionByPolynomial(GF,uni): Exports == _ getMultiplicationTable() == if initmult? then initializeMult() multTable + getMultiplicationMatrix() == if initmult? then initializeMult() createMultiplicationMatrix(multTable)$FFF + sizeMultiplication() == if initmult? then initializeMult() sizeMultiplication(multTable)$FFF trace(a:$) == retract trace(a,1) + norm(a:$) == retract norm(a,1) + generator() == normalElement(extdeg)$INBFF + basis(n:PI) == (extdeg rem n) ^= 0 => error "argument must divide extension degree" [Frobenius(trace(normalElement,n),i) for i in 0..(n-1)]::(Vector $) @@ -57569,10 +65189,6 @@ FiniteFieldNormalBasisExtensionByPolynomial(GF,uni): Exports == _ a:GF * x:$ == a *$Rep x x:$/a:GF == x/coerce(a) --- x:$ / a:GF == --- a = 0$GF => error "division by zero" --- x * inv(coerce(a)) - coordinates(x:$) == x::Rep @@ -57589,16 +65205,14 @@ FiniteFieldNormalBasisExtensionByPolynomial(GF,uni): Exports == _ x.1 *$GF traceAlpha error("element not in ground field") --- to get a "normal basis like" output form + -- to get a "normal basis like" output form coerce(x:$):OUT == l:List OUT:=nil()$(List OUT) n : PI := extdeg --- one? n => (x.1) :: OUT (n = 1) => (x.1) :: OUT for i in 1..n for b in basisOutput repeat if not zero? x.i then mon : OUT := --- one? x.i => b (x.i = 1) => b ((x.i)::OUT) *$OUT b l:=cons(mon,l)$(List OUT) @@ -57685,7 +65299,6 @@ divisor of the order of the multiplicative group" setFieldInfo(multTable,traceAlpha)$INBFF x::Rep *$INBFF y::Rep - 1 == new(extdeg,inv(traceAlpha)$GF)$Rep 0 == zero(extdeg)$Rep @@ -57696,12 +65309,10 @@ divisor of the order of the multiplicative group" lookup(x:$) == lookup(x::Rep)$INBFF - basis() == a:=basis(extdeg)$INBFF vector([e::$ for e in entries a]) - x:$ ** e:I == if initmult? then initializeMult() setFieldInfo(multTable,traceAlpha)$INBFF @@ -57710,13 +65321,14 @@ divisor of the order of the multiplicative group" normal?(x) == normal?(x::Rep)$INBFF -(x:$) == -$Rep x + x:$ + y:$ == x +$Rep y - x:$ - y:$ == x -$Rep y - x:$ = y:$ == x =$Rep y - n:I * x:$ == x *$Rep (n::GF) + x:$ - y:$ == x -$Rep y + x:$ = y:$ == x =$Rep y + n:I * x:$ == x *$Rep (n::GF) representationType() == "normal" @@ -57725,7 +65337,7 @@ divisor of the order of the multiplicative group" setFieldInfo(multTable,traceAlpha)$INBFF minimalPolynomial(a::Rep)$INBFF --- is x an element of the ground field GF ? + -- is x an element of the ground field GF ? inGroundField?(x) == erg:=true for i in 2..extdeg repeat @@ -57754,6 +65366,301 @@ divisor of the order of the multiplicative group" \begin{chunk}{COQ FFNBP} (* domain FFNBP *) (* + + Rep:= V -- elements are represented by vectors over GF + + alpha :=new()$Symbol :: OutputForm + -- get a new Symbol for the output representation of the elements + + initlog?:Boolean:=true + -- gets false after initialization of the logarithm table + + initelt?:Boolean:=true + -- gets false after initialization of the primitive element + + initmult?:Boolean:=true + -- gets false after initialization of the multiplication + -- table or the primitive element + + extdeg:PI :=1 + + defpol:SUP(GF):=0$SUP(GF) + -- the defining polynomial + + multTable:Vector List TERM:=new(1,nil()$(List TERM)) + -- global variable containing the multiplication table + + if uni case (Vector List TERM) then + multTable:=uni :: (Vector List TERM) + extdeg:= (#multTable) pretend PI + vv:V:=new(extdeg,0)$V + vv.1:=1$GF + setFieldInfo(multTable,1$GF)$INBFF + defpol:=minimalPolynomial(vv)$INBFF + initmult?:=false + else + defpol:=uni :: SUP(GF) + extdeg:=degree(defpol)$(SUP GF) pretend PI + multTable:Vector List TERM:=new(extdeg,nil()$(List TERM)) + + basisOutput : List OUT := + qs:OUT:=(q::Symbol)::OUT + append([alpha, alpha **$OUT qs],_ + [alpha **$OUT (qs **$OUT i::OUT) for i in 2..extdeg-1] ) + + facOfGroupSize :=nil()$(List Record(factor:Integer,exponent:Integer)) + -- the factorization of the cyclic group size + + traceAlpha:GF:=-$GF coefficient(defpol,(degree(defpol)-1)::NNI) + -- the inverse of the trace of the normalElt + -- is computed here. It defines the imbedding of + -- GF in the extension field + + primitiveElt:PI:=1 + -- lookup the primitive Element computed by createPrimitiveElement() + + discLogTable:Table(PI,TBL):=table()$Table(PI,TBL) + -- tables indexed by the factors of sizeCG, + -- discLogTable(factor) is a table with keys + -- primitiveElement() ** (i * (sizeCG quo factor)) and entries i for + -- i in 0..n-1, n computed in initialize() in order to use + -- the minimal size limit 'limit' optimal. + +-- functions =========================================================== + + initializeLog: () -> Void + + initializeElt: () -> Void + + initializeMult: () -> Void + + coerce(v:GF):$ == new(extdeg,v /$GF traceAlpha)$Rep + represents(v) == v::$ + + degree(a) == + d:PI:=1 + b:= qPot(a::Rep,1)$INBFF + while (b^=a) repeat + b:= qPot(b::Rep,1)$INBFF + d:=d+1 + d + + linearAssociatedExp(x,f) == + xm:SUP(GF):=monomial(1$GF,extdeg)$(SUP GF) - 1$(SUP GF) + r:= (f * pol(x::Rep)$INBFF) rem xm + vectorise(r,extdeg)$(SUP GF) + + linearAssociatedLog(x) == pol(x::Rep)$INBFF + + linearAssociatedOrder(x) == + xm:SUP(GF):=monomial(1$GF,extdeg)$(SUP GF) - 1$(SUP GF) + xm quo gcd(xm,pol(x::Rep)$INBFF) + + linearAssociatedLog(b,x) == + zero? x => 0 + xm:SUP(GF):=monomial(1$GF,extdeg)$(SUP GF) - 1$(SUP GF) + e:= extendedEuclidean(pol(b::Rep)$INBFF,xm,pol(x::Rep)$INBFF)$(SUP GF) + e = "failed" => "failed" + e1:= e :: Record(coef1:(SUP GF),coef2:(SUP GF)) + e1.coef1 + + getMultiplicationTable() == + if initmult? then initializeMult() + multTable + + getMultiplicationMatrix() == + if initmult? then initializeMult() + createMultiplicationMatrix(multTable)$FFF + + sizeMultiplication() == + if initmult? then initializeMult() + sizeMultiplication(multTable)$FFF + + trace(a:$) == retract trace(a,1) + + norm(a:$) == retract norm(a,1) + + generator() == normalElement(extdeg)$INBFF + + basis(n:PI) == + (extdeg rem n) ^= 0 => error "argument must divide extension degree" + [Frobenius(trace(normalElement,n),i) for i in 0..(n-1)]::(Vector $) + + a:GF * x:$ == a *$Rep x + + x:$/a:GF == x/coerce(a) + + coordinates(x:$) == x::Rep + + Frobenius(e) == qPot(e::Rep,1)$INBFF + Frobenius(e,n) == qPot(e::Rep,n)$INBFF + + retractIfCan(x) == + inGroundField?(x) => + x.1 *$GF traceAlpha + "failed" + + retract(x) == + inGroundField?(x) => + x.1 *$GF traceAlpha + error("element not in ground field") + + -- to get a "normal basis like" output form + coerce(x:$):OUT == + l:List OUT:=nil()$(List OUT) + n : PI := extdeg + (n = 1) => (x.1) :: OUT + for i in 1..n for b in basisOutput repeat + if not zero? x.i then + mon : OUT := + (x.i = 1) => b + ((x.i)::OUT) *$OUT b + l:=cons(mon,l)$(List OUT) + null(l)$(List OUT) => (0::OUT) + r:=reduce("+",l)$(List OUT) + r + + initializeElt() == + facOfGroupSize := factors factor(size()$GF**extdeg-1)$I + -- get a primitive element + primitiveElt:=lookup(createPrimitiveElement()) + initelt?:=false + void()$Void + + initializeMult() == + multTable:=createMultiplicationTable(defpol)$FFF + setFieldInfo(multTable,traceAlpha)$INBFF + -- reset initialize flag + initmult?:=false + void()$Void + + initializeLog() == + if initelt? then initializeElt() + -- set up tables for discrete logarithm + limit:Integer:=30 + -- the minimum size for the discrete logarithm table + for f in facOfGroupSize repeat + fac:=f.factor + base:$:=index(primitiveElt)**((size()$GF**extdeg -$I 1$I) quo$I fac) + l:Integer:=length(fac)$Integer + n:Integer:=0 + if odd?(l)$I then n:=shift(fac,-$I (l quo$I 2))$I + else n:=shift(1,l quo$I 2)$I + if n <$I limit then + d:=(fac -$I 1$I) quo$I limit +$I 1$I + n:=(fac -$I 1$I) quo$I d +$I 1$I + tbl:TBL:=table()$TBL + a:$:=1 + for i in (0::NNI)..(n-1)::NNI repeat + insert_!([lookup(a),i::NNI]$R,tbl)$TBL + a:=a*base + insert_!([fac::PI,copy(tbl)$TBL]_ + $Record(key:PI,entry:TBL),discLogTable)$Table(PI,TBL) + initlog?:=false + -- tell user about initialization + --print("discrete logarithm table initialized"::OUT) + void()$Void + + tableForDiscreteLogarithm(fac) == + if initlog? then initializeLog() + tbl:=search(fac::PI,discLogTable)$Table(PI,TBL) + tbl case "failed" => + error "tableForDiscreteLogarithm: argument must be prime _ +divisor of the order of the multiplicative group" + tbl :: TBL + + primitiveElement() == + if initelt? then initializeElt() + index(primitiveElt) + + factorsOfCyclicGroupSize() == + if empty? facOfGroupSize then initializeElt() + facOfGroupSize + + extensionDegree() == extdeg + + sizeOfGroundField() == size()$GF pretend NNI + + definingPolynomial() == defpol + + trace(a,d) == + v:=trace(a::Rep,d)$INBFF + erg:=v + for i in 2..(extdeg quo d) repeat + erg:=concat(erg,v)$Rep + erg + + characteristic() == characteristic()$GF + + random() == random(extdeg)$INBFF + + x:$ * y:$ == + if initmult? then initializeMult() + setFieldInfo(multTable,traceAlpha)$INBFF + x::Rep *$INBFF y::Rep + + 1 == new(extdeg,inv(traceAlpha)$GF)$Rep + + 0 == zero(extdeg)$Rep + + size() == size()$GF ** extdeg + + index(n:PI) == index(extdeg,n)$INBFF + + lookup(x:$) == lookup(x::Rep)$INBFF + + basis() == + a:=basis(extdeg)$INBFF + vector([e::$ for e in entries a]) + + x:$ ** e:I == + if initmult? then initializeMult() + setFieldInfo(multTable,traceAlpha)$INBFF + (x::Rep) **$INBFF e + + normal?(x) == normal?(x::Rep)$INBFF + + -(x:$) == -$Rep x + + x:$ + y:$ == x +$Rep y + + x:$ - y:$ == x -$Rep y + + x:$ = y:$ == x =$Rep y + + n:I * x:$ == x *$Rep (n::GF) + + representationType() == "normal" + + minimalPolynomial(a) == + if initmult? then initializeMult() + setFieldInfo(multTable,traceAlpha)$INBFF + minimalPolynomial(a::Rep)$INBFF + + -- is x an element of the ground field GF ? + inGroundField?(x) == + erg:=true + for i in 2..extdeg repeat + not(x.i =$GF x.1) => erg:=false + erg + + x:$ / y:$ == + if initmult? then initializeMult() + setFieldInfo(multTable,traceAlpha)$INBFF + x::Rep /$INBFF y::Rep + + inv(a) == + if initmult? then initializeMult() + setFieldInfo(multTable,traceAlpha)$INBFF + inv(a::Rep)$INBFF + + norm(a,d) == + if initmult? then initializeMult() + setFieldInfo(multTable,traceAlpha)$INBFF + norm(a::Rep,d)$INBFF + + normalElement() == normalElement(extdeg)$INBFF + *) \end{chunk} @@ -59650,42 +67557,70 @@ Float(): ++ outputGeneral(n) sets the output mode to general notation ++ with n significant digits displayed. outputSpacing: N -> Void - ++ outputSpacing(n) inserts a space after n (default 10) digits on output; + ++ outputSpacing(n) inserts space after n (default 10) digits on output; ++ outputSpacing(0) means no spaces are inserted. arbitraryPrecision arbitraryExponent == add + BASE ==> 2 + BITS:Reference(PI) := ref 68 -- 20 digits + LENGTH ==> INTEGER_-LENGTH$Lisp + ISQRT ==> approxSqrt$IntegerRoots(I) + Rep := Record( mantissa:I, exponent:I ) + StoredConstant ==> Record( precision:PI, value:% ) + UCA ==> Record( unit:%, coef:%, associate:% ) + inc ==> increasePrecision + dec ==> decreasePrecision -- local utility operations + shift2 : (I,I) -> I -- WSP: fix bug in shift + times : (%,%) -> % -- multiply x and y with no rounding + itimes: (I,%) -> % -- multiply by a small integer + chop: (%,PI) -> % -- chop x at p bits of precision + dvide: (%,%) -> % -- divide x by y with no rounding + square: (%,I) -> % -- repeated squaring with chopping + power: (%,I) -> % -- x ** n with chopping + plus: (%,%) -> % -- addition with no rounding + sub: (%,%) -> % -- subtraction with no rounding + negate: % -> % -- negation with no rounding + ceillog10base2: PI -> PI -- rational approximation + floorln2: PI -> PI -- rational approximation atanSeries: % -> % -- atan(x) by taylor series |x| < 1/2 + atanInverse: I -> % -- atan(1/n) for n an integer > 1 + expInverse: I -> % -- exp(1/n) for n an integer + expSeries: % -> % -- exp(x) by taylor series |x| < 1/2 + logSeries: % -> % -- log(x) by taylor series 1/2 < x < 2 + sinSeries: % -> % -- sin(x) by taylor series |x| < 1/2 + cosSeries: % -> % -- cos(x) by taylor series |x| < 1/2 + piRamanujan: () -> % -- pi using Ramanujans series writeOMFloat(dev: OpenMathDevice, x: %): Void == @@ -59737,7 +67672,6 @@ Float(): asin x == zero? x => 0 negative? x => -asin(-x) --- one? x => pi()/2 (x = 1) => pi()/2 x > 1 => error "asin: argument > 1 in magnitude" inc 5; r := atan(x/sqrt(sub(1,times(x,x)))); dec 5 @@ -59746,7 +67680,6 @@ Float(): acos x == zero? x => pi()/2 negative? x => (inc 3; r := pi()-acos(-x); dec 3; normalize r) --- one? x => 0 (x = 1) => 0 x > 1 => error "acos: argument > 1 in magnitude" inc 5; r := atan(sqrt(sub(1,times(x,x)))/x); dec 5 @@ -59768,7 +67701,8 @@ Float(): negative? x => -atan(-x) if x > 1 then inc 4 - r := if zero? fractionPart x and x < [bits(),0] then atanInverse wholePart x + r := if zero? fractionPart x and x < [bits(),0] _ + then atanInverse wholePart x else atan(1/x) r := pi/2 - r dec 4 @@ -59859,8 +67793,6 @@ Float(): bits p s * r - - cosSeries x == -- cos(x) = 1 - x**2/2! + x**4/4! - x**6/6! + ... |x| < 1/2 p := bits() + LENGTH bits() + 1 @@ -59884,6 +67816,7 @@ Float(): s * t P:StoredConstant := [1,[1,2]] + pi() == -- We use Ramanujan's identity to compute pi. -- The running time is quadratic in the precision. @@ -59978,6 +67911,7 @@ Float(): y * [s,1-p] L2:StoredConstant := [1,1] + log2() == -- log x = 2 * sum( ((x-1)/(x+1))**(2*k+1)/(2*k+1), k=1.. ) -- log 2 = 2 * sum( 1/9**k / (2*k+1), k=0..n ) / 3 @@ -59993,6 +67927,7 @@ Float(): normalize L2.value L10:StoredConstant := [1,[1,1]] + log10() == -- log x = 2 * sum( ((x-1)/(x+1))**(2*k+1)/(2*k+1), k=0.. ) -- log 5/4 = 2 * sum( 1/81**k / (2*k+1), k=0.. ) / 9 @@ -60009,6 +67944,7 @@ Float(): normalize L10.value log2(x) == (inc 2; r := log(x)/log2; dec 2; normalize r) + log10(x) == (inc 2; r := log(x)/log10; dec 2; normalize r) exp(x) == @@ -60050,6 +67986,7 @@ Float(): dvide([p1,0],[q1,0]) E:StoredConstant := [1,[1,1]] + exp1() == if bits() > E.precision then E := [bits(),expInverse 1] normalize E.value @@ -60066,36 +68003,57 @@ Float(): normalize [i,(e-p) quo 2] bits() == BITS() + bits(n) == (t := bits(); BITS() := n; t) + precision() == bits() + precision(n) == bits(n) + increasePrecision n == (b := bits(); bits((b + n)::PI); b) + decreasePrecision n == (b := bits(); bits((b - n)::PI); b) + ceillog10base2 n == ((13301 * n + 4003) quo 4004) :: PI + digits() == max(1,4004 * (bits()-1) quo 13301)::PI + digits(n) == (t := digits(); bits (1 + ceillog10base2 n); t) order(a) == LENGTH a.mantissa + a.exponent - 1 + relerror(a,b) == order((a-b)/b) + 0 == [0,0] + 1 == [1,0] + base() == BASE + mantissa x == x.mantissa + exponent x == x.exponent + one? a == a = 1 + zero? a == zero?(a.mantissa) + negative? a == negative?(a.mantissa) + positive? a == positive?(a.mantissa) chop(x,p) == e : I := LENGTH x.mantissa - p if e > 0 then x := [shift2(x.mantissa,-e),x.exponent+e] x + float(m,e) == normalize [m,e] + float(m,e,b) == m = 0 => 0 inc 4; r := m * [b,0] ** e; dec 4 normalize r + normalize x == m := x.mantissa m = 0 => 0 @@ -60110,10 +68068,12 @@ Float(): else y := y quo 2 x := [y,x.exponent+e] x + shift(x:%,n:I) == [x.mantissa,x.exponent+n] x = y == order x = order y and sign x = sign y and zero? (x - y) + x < y == y.mantissa = 0 => x.mantissa < 0 x.mantissa = 0 => y.mantissa > 0 @@ -60124,24 +68084,37 @@ Float(): negative? (x-y) abs x == if negative? x then -x else normalize x + ceiling x == if negative? x then return (-floor(-x)) if zero? fractionPart x then x else truncate x + 1 + wholePart x == shift2(x.mantissa,x.exponent) + floor x == if negative? x then -ceiling(-x) else truncate x + round x == (half := [sign x,-1]; truncate(x + half)) + sign x == if x.mantissa < 0 then -1 else 1 + truncate x == if x.exponent >= 0 then return x normalize [shift2(x.mantissa,x.exponent),0] + recip(x) == if x=0 then "failed" else 1/x + differentiate x == 0 - x == normalize negate x + negate x == [-x.mantissa,x.exponent] + x + y == normalize plus(x,y) + x - y == normalize plus(x,negate y) + sub(x,y) == plus(x,negate y) + plus(x,y) == mx := x.mantissa; my := y.mantissa mx = 0 => y @@ -60156,15 +68129,20 @@ Float(): [mw,ey] x:% * y:% == normalize times (x,y) + x:I * y:% == if LENGTH x > bits() then normalize [x,0] * y else normalize [x * y.mantissa,y.exponent] + x:% / y:% == normalize dvide(x,y) + x:% / y:I == if LENGTH y > bits() then x / normalize [y,0] else x / [y,0] + inv x == 1 / x times(x:%,y:%) == [x.mantissa * y.mantissa, x.exponent + y.exponent] + itimes(n:I,y:%) == [n * y.mantissa,y.exponent] dvide(x,y) == @@ -60237,14 +68215,23 @@ Float(): normalize y -- Utility routines for conversion to decimal + ceilLength10: I -> I + chop10: (%,I) -> % + convert10:(%,I) -> % + floorLength10: I -> I + length10: I -> I + normalize10: (%,I) -> % + quotient10: (%,%,I) -> % + power10: (%,I,I) -> % + times10: (%,%,I) -> % convert10(x,d) == @@ -60259,8 +68246,9 @@ Float(): else times10([m,0],h,d) ceilLength10 n == 146 * LENGTH n quo 485 + 1 + floorLength10 n == 643 * LENGTH n quo 2136 --- length10 n == DECIMAL_-LENGTH(n)$Lisp + length10 n == ln := LENGTH(n:=abs n) upper := 76573 * ln quo 254370 @@ -60276,6 +68264,7 @@ Float(): e : I := floorLength10 x.mantissa - p if e > 0 then x := [x.mantissa quo 10**e::N,x.exponent+e] x + normalize10(x,p) == ma := x.mantissa ex := x.exponent @@ -60288,13 +68277,16 @@ Float(): ma := ma + 1 if ma = 10**p::N then (ma := 1; ex := ex + p) [ma,ex] + times10(x,y,p) == normalize10(times(x,y),p) + quotient10(x,y,p) == ew := floorLength10 y.mantissa - ceilLength10 x.mantissa + p + 2 if ew < 0 then ew := 0 mw := (x.mantissa * 10**ew::N) quo y.mantissa ew := x.exponent - y.exponent - ew normalize10([mw,ew],p) + power10(x,n,d) == x = 0 => 0 n = 0 => 1 @@ -60313,14 +68305,19 @@ Float(): -- Output routines for Floats -- -------------------------------- zero ==> char("0") + separator ==> space()$Character SPACING : Reference(N) := ref 10 + OUTMODE : Reference(S) := ref "general" + OUTPREC : Reference(I) := ref(-1) fixed : % -> S + floating : % -> S + general : % -> S padFromLeft(s:S):S == @@ -60433,11 +68430,17 @@ Float(): concat ["0.", t, s, convert(e+n)@S] outputSpacing n == SPACING() := n + outputFixed() == (OUTMODE() := "fixed"; OUTPREC() := -1) + outputFixed n == (OUTMODE() := "fixed"; OUTPREC() := n::I) + outputGeneral() == (OUTMODE() := "general"; OUTPREC() := -1) + outputGeneral n == (OUTMODE() := "general"; OUTPREC() := n::I) + outputFloating() == (OUTMODE() := "floating"; OUTPREC() := -1) + outputFloating n == (OUTMODE() := "floating"; OUTPREC() := n::I) convert(f):S == @@ -60463,9 +68466,13 @@ Float(): convert exponent f, convert base()]$List(InputForm) -- Conversion routines + convert(x:%):Float == x pretend Float + convert(x:%):SF == makeSF(x.mantissa,x.exponent)$Lisp + coerce(x:%):SF == convert(x)@SF + convert(sf:SF):% == float(mantissa sf,exponent sf,base()$SF) retract(f:%):RN == rationalApproximation(f,(bits()-1)::N,BASE) @@ -60507,1357 +68514,1059 @@ Float(): \begin{chunk}{COQ FLOAT} (* domain FLOAT *) (* -*) -\end{chunk} + BASE ==> 2 -\begin{chunk}{FLOAT.dotabb} -"FLOAT" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FLOAT"] -"ALIST" [color="#88FF44",href="bookvol10.3.pdf#nameddest=ALIST"] -"FLOAT" -> "ALIST" + BITS:Reference(PI) := ref 68 -- 20 digits -\end{chunk} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain FC FortranCode} + LENGTH ==> INTEGER_-LENGTH$Lisp -\begin{chunk}{FortranCode.input} -)set break resume -)sys rm -f FortranCode.output -)spool FortranCode.output -)set message test on -)set message auto off -)clear all + ISQRT ==> approxSqrt$IntegerRoots(I) ---S 1 of 1 -)show FortranCode ---R ---R FortranCode is a domain constructor ---R Abbreviation for FortranCode is FC ---R This constructor is exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for FC ---R ---R------------------------------- Operations -------------------------------- ---R ?=? : (%,%) -> Boolean assign : (Symbol,String) -> % ---R block : List(%) -> % call : String -> % ---R coerce : % -> OutputForm comment : List(String) -> % ---R comment : String -> % common : (Symbol,List(Symbol)) -> % ---R cond : (Switch,%,%) -> % cond : (Switch,%) -> % ---R continue : SingleInteger -> % getCode : % -> SExpression ---R goto : SingleInteger -> % hash : % -> SingleInteger ---R latex : % -> String printCode : % -> Void ---R repeatUntilLoop : (Switch,%) -> % returns : Expression(Integer) -> % ---R returns : Expression(Float) -> % returns : () -> % ---R save : () -> % stop : () -> % ---R whileLoop : (Switch,%) -> % ?~=? : (%,%) -> Boolean ---R assign : (Symbol,List(Polynomial(Integer)),Expression(Complex(Float))) -> % ---R assign : (Symbol,List(Polynomial(Integer)),Expression(Float)) -> % ---R assign : (Symbol,List(Polynomial(Integer)),Expression(Integer)) -> % ---R assign : (Symbol,Vector(Expression(Complex(Float)))) -> % ---R assign : (Symbol,Vector(Expression(Float))) -> % ---R assign : (Symbol,Vector(Expression(Integer))) -> % ---R assign : (Symbol,Matrix(Expression(Complex(Float)))) -> % ---R assign : (Symbol,Matrix(Expression(Float))) -> % ---R assign : (Symbol,Matrix(Expression(Integer))) -> % ---R assign : (Symbol,Expression(Complex(Float))) -> % ---R assign : (Symbol,Expression(Float)) -> % ---R assign : (Symbol,Expression(Integer)) -> % ---R assign : (Symbol,List(Polynomial(Integer)),Expression(MachineComplex)) -> % ---R assign : (Symbol,List(Polynomial(Integer)),Expression(MachineFloat)) -> % ---R assign : (Symbol,List(Polynomial(Integer)),Expression(MachineInteger)) -> % ---R assign : (Symbol,Vector(Expression(MachineComplex))) -> % ---R assign : (Symbol,Vector(Expression(MachineFloat))) -> % ---R assign : (Symbol,Vector(Expression(MachineInteger))) -> % ---R assign : (Symbol,Matrix(Expression(MachineComplex))) -> % ---R assign : (Symbol,Matrix(Expression(MachineFloat))) -> % ---R assign : (Symbol,Matrix(Expression(MachineInteger))) -> % ---R assign : (Symbol,Vector(MachineComplex)) -> % ---R assign : (Symbol,Vector(MachineFloat)) -> % ---R assign : (Symbol,Vector(MachineInteger)) -> % ---R assign : (Symbol,Matrix(MachineComplex)) -> % ---R assign : (Symbol,Matrix(MachineFloat)) -> % ---R assign : (Symbol,Matrix(MachineInteger)) -> % ---R assign : (Symbol,Expression(MachineComplex)) -> % ---R assign : (Symbol,Expression(MachineFloat)) -> % ---R assign : (Symbol,Expression(MachineInteger)) -> % ---R code : % -> Union(nullBranch: null,assignmentBranch: Record(var: Symbol,arrayIndex: List(Polynomial(Integer)),rand: Record(ints2Floats?: Boolean,expr: OutputForm)),arrayAssignmentBranch: Record(var: Symbol,rand: OutputForm,ints2Floats?: Boolean),conditionalBranch: Record(switch: Switch,thenClause: %,elseClause: %),returnBranch: Record(empty?: Boolean,value: Record(ints2Floats?: Boolean,expr: OutputForm)),blockBranch: List(%),commentBranch: List(String),callBranch: String,forBranch: Record(range: SegmentBinding(Polynomial(Integer)),span: Polynomial(Integer),body: %),labelBranch: SingleInteger,loopBranch: Record(switch: Switch,body: %),commonBranch: Record(name: Symbol,contents: List(Symbol)),printBranch: List(OutputForm)) ---R forLoop : (SegmentBinding(Polynomial(Integer)),Polynomial(Integer),%) -> % ---R forLoop : (SegmentBinding(Polynomial(Integer)),%) -> % ---R operation : % -> Union(Null: null,Assignment: assignment,Conditional: conditional,Return: return,Block: block,Comment: comment,Call: call,For: for,While: while,Repeat: repeat,Goto: goto,Continue: continue,ArrayAssignment: arrayAssignment,Save: save,Stop: stop,Common: common,Print: print) ---R printStatement : List(OutputForm) -> % ---R returns : Expression(Complex(Float)) -> % ---R returns : Expression(MachineComplex) -> % ---R returns : Expression(MachineInteger) -> % ---R returns : Expression(MachineFloat) -> % ---R setLabelValue : SingleInteger -> SingleInteger ---R ---E 1 + Rep := Record( mantissa:I, exponent:I ) -)spool -)lisp (bye) -\end{chunk} -\begin{chunk}{FortranCode.help} -==================================================================== -FortranCode examples -==================================================================== + StoredConstant ==> Record( precision:PI, value:% ) -This domain builds representations of program code segments for use with -the FortranProgram domain. + UCA ==> Record( unit:%, coef:%, associate:% ) -See Also: -o )show FortranCode + inc ==> increasePrecision -\end{chunk} + dec ==> decreasePrecision -\pagehead{FortranCode}{FC} -\pagepic{ps/v103fortrancode.ps}{FC}{1.00} -{\bf See}\\ -\pageto{Result}{RESULT} -\pageto{FortranProgram}{FORTRAN} -\pageto{ThreeDimensionalMatrix}{M3D} -\pageto{SimpleFortranProgram}{SFORT} -\pageto{Switch}{SWITCH} -\pageto{FortranTemplate}{FTEM} -\pageto{FortranExpression}{FEXPR} + -- local utility operations -{\bf Exports:}\\ -\begin{tabular}{lllll} -\cross{FC}{assign} & -\cross{FC}{block} & -\cross{FC}{call} & -\cross{FC}{code} & -\cross{FC}{coerce} \\ -\cross{FC}{comment} & -\cross{FC}{common} & -\cross{FC}{cond} & -\cross{FC}{continue} & -\cross{FC}{forLoop} \\ -\cross{FC}{getCode} & -\cross{FC}{goto} & -\cross{FC}{hash} & -\cross{FC}{latex} & -\cross{FC}{operation} \\ -\cross{FC}{printCode} & -\cross{FC}{printStatement} & -\cross{FC}{repeatUntilLoop} & -\cross{FC}{returns} & -\cross{FC}{save} \\ -\cross{FC}{setLabelValue} & -\cross{FC}{stop} & -\cross{FC}{whileLoop} & -\cross{FC}{?=?} & -\cross{FC}{?~=?} -\end{tabular} + shift2 : (I,I) -> I -- WSP: fix bug in shift -\begin{chunk}{domain FC FortranCode} -)abbrev domain FC FortranCode -++ Author: Mike Dewar -++ Date Created: April 1991 -++ Date Last Updated: 9 January 1995 Added fortran2Lines to getCall, MCD -++ Description: -++ This domain builds representations of program code segments for use with -++ the FortranProgram domain. + times : (%,%) -> % -- multiply x and y with no rounding -FortranCode(): public == private where - L ==> List - PI ==> PositiveInteger - PIN ==> Polynomial Integer - SEX ==> SExpression - O ==> OutputForm - OP ==> Union(Null:"null", - Assignment:"assignment", - Conditional:"conditional", - Return:"return", - Block:"block", - Comment:"comment", - Call:"call", - For:"for", - While:"while", - Repeat:"repeat", - Goto:"goto", - Continue:"continue", - ArrayAssignment:"arrayAssignment", - Save:"save", - Stop:"stop", - Common:"common", - Print:"print") - ARRAYASS ==> Record(var:Symbol, rand:O, ints2Floats?:Boolean) - EXPRESSION ==> Record(ints2Floats?:Boolean,expr:O) - ASS ==> Record(var:Symbol, - arrayIndex:L PIN, - rand:EXPRESSION - ) - COND ==> Record(switch: Switch(), - thenClause: $, - elseClause: $ - ) - RETURN ==> Record(empty?:Boolean,value:EXPRESSION) - BLOCK ==> List $ - COMMENT ==> List String - COMMON ==> Record(name:Symbol,contents:List Symbol) - CALL ==> String - FOR ==> Record(range:SegmentBinding PIN, span:PIN, body:$) - LABEL ==> SingleInteger - LOOP ==> Record(switch:Switch(),body:$) - PRINTLIST ==> List O - OPREC ==> Union(nullBranch:"null", assignmentBranch:ASS, - arrayAssignmentBranch:ARRAYASS, - conditionalBranch:COND, returnBranch:RETURN, - blockBranch:BLOCK, commentBranch:COMMENT, callBranch:CALL, - forBranch:FOR, labelBranch:LABEL, loopBranch:LOOP, - commonBranch:COMMON, printBranch:PRINTLIST) + itimes: (I,%) -> % -- multiply by a small integer - public == SetCategory with - coerce: $ -> O - ++ coerce(f) returns an object of type OutputForm. - forLoop: (SegmentBinding PIN,$) -> $ - ++ forLoop(i=1..10,c) creates a representation of a FORTRAN DO loop with - ++ \spad{i} ranging over the values 1 to 10. - forLoop: (SegmentBinding PIN,PIN,$) -> $ - ++ forLoop(i=1..10,n,c) creates a representation of a FORTRAN DO loop with - ++ \spad{i} ranging over the values 1 to 10 by n. - whileLoop: (Switch,$) -> $ - ++ whileLoop(s,c) creates a while loop in FORTRAN. - repeatUntilLoop: (Switch,$) -> $ - ++ repeatUntilLoop(s,c) creates a repeat ... until loop in FORTRAN. - goto: SingleInteger -> $ - ++ goto(l) creates a representation of a FORTRAN GOTO statement - continue: SingleInteger -> $ - ++ continue(l) creates a representation of a FORTRAN CONTINUE labelled - ++ with l - comment: String -> $ - ++ comment(s) creates a representation of the String s as a single FORTRAN - ++ comment. - comment: List String -> $ - ++ comment(s) creates a representation of the Strings s as a multi-line - ++ FORTRAN comment. - call: String -> $ - ++ call(s) creates a representation of a FORTRAN CALL statement - returns: () -> $ - ++ returns() creates a representation of a FORTRAN RETURN statement. - returns: Expression MachineFloat -> $ - ++ returns(e) creates a representation of a FORTRAN RETURN statement - ++ with a returned value. - returns: Expression MachineInteger -> $ - ++ returns(e) creates a representation of a FORTRAN RETURN statement - ++ with a returned value. - returns: Expression MachineComplex -> $ - ++ returns(e) creates a representation of a FORTRAN RETURN statement - ++ with a returned value. - returns: Expression Float -> $ - ++ returns(e) creates a representation of a FORTRAN RETURN statement - ++ with a returned value. - returns: Expression Integer -> $ - ++ returns(e) creates a representation of a FORTRAN RETURN statement - ++ with a returned value. - returns: Expression Complex Float -> $ - ++ returns(e) creates a representation of a FORTRAN RETURN statement - ++ with a returned value. - cond: (Switch,$) -> $ - ++ cond(s,e) creates a representation of the FORTRAN expression - ++ IF (s) THEN e. - cond: (Switch,$,$) -> $ - ++ cond(s,e,f) creates a representation of the FORTRAN expression - ++ IF (s) THEN e ELSE f. - assign: (Symbol,String) -> $ - ++ assign(x,y) creates a representation of the FORTRAN expression - ++ x=y. - assign: (Symbol,Expression MachineInteger) -> $ - ++ assign(x,y) creates a representation of the FORTRAN expression - ++ x=y. - assign: (Symbol,Expression MachineFloat) -> $ - ++ assign(x,y) creates a representation of the FORTRAN expression - ++ x=y. - assign: (Symbol,Expression MachineComplex) -> $ - ++ assign(x,y) creates a representation of the FORTRAN expression - ++ x=y. - assign: (Symbol,Matrix MachineInteger) -> $ - ++ assign(x,y) creates a representation of the FORTRAN expression - ++ x=y. - assign: (Symbol,Matrix MachineFloat) -> $ - ++ assign(x,y) creates a representation of the FORTRAN expression - ++ x=y. - assign: (Symbol,Matrix MachineComplex) -> $ - ++ assign(x,y) creates a representation of the FORTRAN expression - ++ x=y. - assign: (Symbol,Vector MachineInteger) -> $ - ++ assign(x,y) creates a representation of the FORTRAN expression - ++ x=y. - assign: (Symbol,Vector MachineFloat) -> $ - ++ assign(x,y) creates a representation of the FORTRAN expression - ++ x=y. - assign: (Symbol,Vector MachineComplex) -> $ - ++ assign(x,y) creates a representation of the FORTRAN expression - ++ x=y. - assign: (Symbol,Matrix Expression MachineInteger) -> $ - ++ assign(x,y) creates a representation of the FORTRAN expression - ++ x=y. - assign: (Symbol,Matrix Expression MachineFloat) -> $ - ++ assign(x,y) creates a representation of the FORTRAN expression - ++ x=y. - assign: (Symbol,Matrix Expression MachineComplex) -> $ - ++ assign(x,y) creates a representation of the FORTRAN expression - ++ x=y. - assign: (Symbol,Vector Expression MachineInteger) -> $ - ++ assign(x,y) creates a representation of the FORTRAN expression - ++ x=y. - assign: (Symbol,Vector Expression MachineFloat) -> $ - ++ assign(x,y) creates a representation of the FORTRAN expression - ++ x=y. - assign: (Symbol,Vector Expression MachineComplex) -> $ - ++ assign(x,y) creates a representation of the FORTRAN expression - ++ x=y. - assign: (Symbol,L PIN,Expression MachineInteger) -> $ - ++ assign(x,l,y) creates a representation of the assignment of \spad{y} - ++ to the \spad{l}'th element of array \spad{x} (\spad{l} is a list of - ++ indices). - assign: (Symbol,L PIN,Expression MachineFloat) -> $ - ++ assign(x,l,y) creates a representation of the assignment of \spad{y} - ++ to the \spad{l}'th element of array \spad{x} (\spad{l} is a list of - ++ indices). - assign: (Symbol,L PIN,Expression MachineComplex) -> $ - ++ assign(x,l,y) creates a representation of the assignment of \spad{y} - ++ to the \spad{l}'th element of array \spad{x} (\spad{l} is a list of - ++ indices). - assign: (Symbol,Expression Integer) -> $ - ++ assign(x,y) creates a representation of the FORTRAN expression - ++ x=y. - assign: (Symbol,Expression Float) -> $ - ++ assign(x,y) creates a representation of the FORTRAN expression - ++ x=y. - assign: (Symbol,Expression Complex Float) -> $ - ++ assign(x,y) creates a representation of the FORTRAN expression - ++ x=y. - assign: (Symbol,Matrix Expression Integer) -> $ - ++ assign(x,y) creates a representation of the FORTRAN expression - ++ x=y. - assign: (Symbol,Matrix Expression Float) -> $ - ++ assign(x,y) creates a representation of the FORTRAN expression - ++ x=y. - assign: (Symbol,Matrix Expression Complex Float) -> $ - ++ assign(x,y) creates a representation of the FORTRAN expression - ++ x=y. - assign: (Symbol,Vector Expression Integer) -> $ - ++ assign(x,y) creates a representation of the FORTRAN expression - ++ x=y. - assign: (Symbol,Vector Expression Float) -> $ - ++ assign(x,y) creates a representation of the FORTRAN expression - ++ x=y. - assign: (Symbol,Vector Expression Complex Float) -> $ - ++ assign(x,y) creates a representation of the FORTRAN expression - ++ x=y. - assign: (Symbol,L PIN,Expression Integer) -> $ - ++ assign(x,l,y) creates a representation of the assignment of \spad{y} - ++ to the \spad{l}'th element of array \spad{x} (\spad{l} is a list of - ++ indices). - assign: (Symbol,L PIN,Expression Float) -> $ - ++ assign(x,l,y) creates a representation of the assignment of \spad{y} - ++ to the \spad{l}'th element of array \spad{x} (\spad{l} is a list of - ++ indices). - assign: (Symbol,L PIN,Expression Complex Float) -> $ - ++ assign(x,l,y) creates a representation of the assignment of \spad{y} - ++ to the \spad{l}'th element of array \spad{x} (\spad{l} is a list of - ++ indices). - block: List($) -> $ - ++ block(l) creates a representation of the statements in l as a block. - stop: () -> $ - ++ stop() creates a representation of a STOP statement. - save: () -> $ - ++ save() creates a representation of a SAVE statement. - printStatement: List O -> $ - ++ printStatement(l) creates a representation of a PRINT statement. - common: (Symbol,List Symbol) -> $ - ++ common(name,contents) creates a representation a named common block. - operation: $ -> OP - ++ operation(f) returns the name of the operation represented by \spad{f}. - code: $ -> OPREC - ++ code(f) returns the internal representation of the object represented - ++ by \spad{f}. - printCode: $ -> Void - ++ printCode(f) prints out \spad{f} in FORTRAN notation. - getCode: $ -> SEX - ++ getCode(f) returns a Lisp list of strings representing \spad{f} - ++ in Fortran notation. This is used by the FortranProgram domain. - setLabelValue:SingleInteger -> SingleInteger - ++ setLabelValue(i) resets the counter which produces labels to i + chop: (%,PI) -> % -- chop x at p bits of precision - private == add - import Void - import ASS - import COND - import RETURN - import L PIN - import O - import SEX - import FortranType - import TheSymbolTable + dvide: (%,%) -> % -- divide x by y with no rounding - Rep := Record(op: OP, data: OPREC) + square: (%,I) -> % -- repeated squaring with chopping - -- We need to be able to generate unique labels - labelValue:SingleInteger := 25000::SingleInteger - setLabelValue(u:SingleInteger):SingleInteger == labelValue := u - newLabel():SingleInteger == - labelValue := labelValue + 1$SingleInteger - labelValue + power: (%,I) -> % -- x ** n with chopping - commaSep(l:List String):List(String) == - [(l.1),:[:[",",u] for u in rest(l)]] + plus: (%,%) -> % -- addition with no rounding - getReturn(rec:RETURN):SEX == - returnToken : SEX := convert("RETURN"::Symbol::O)$SEX - elt(rec,empty?)$RETURN => - getStatement(returnToken,NIL$Lisp)$Lisp - rt : EXPRESSION := elt(rec,value)$RETURN - rv : O := elt(rt,expr)$EXPRESSION - getStatement([returnToken,convert(rv)$SEX]$Lisp, - elt(rt,ints2Floats?)$EXPRESSION )$Lisp + sub: (%,%) -> % -- subtraction with no rounding - getStop():SEX == - fortran2Lines(LIST("STOP")$Lisp)$Lisp + negate: % -> % -- negation with no rounding - getSave():SEX == - fortran2Lines(LIST("SAVE")$Lisp)$Lisp + ceillog10base2: PI -> PI -- rational approximation - getCommon(u:COMMON):SEX == - fortran2Lines(APPEND(LIST("COMMON"," /",string (u.name),"/ ")$Lisp,_ - addCommas(u.contents)$Lisp)$Lisp)$Lisp - - getPrint(l:PRINTLIST):SEX == - ll : SEX := LIST("PRINT*")$Lisp - for i in l repeat - ll := APPEND(ll,CONS(",",expression2Fortran(i)$Lisp)$Lisp)$Lisp - fortran2Lines(ll)$Lisp + floorln2: PI -> PI -- rational approximation - getBlock(rec:BLOCK):SEX == - indentFortLevel(convert(1@Integer)$SEX)$Lisp - expr : SEX := LIST()$Lisp - for u in rec repeat - expr := APPEND(expr,getCode(u))$Lisp - indentFortLevel(convert(-1@Integer)$SEX)$Lisp - expr + atanSeries: % -> % -- atan(x) by taylor series |x| < 1/2 - getBody(f:$):SEX == - operation(f) case Block => getCode f - indentFortLevel(convert(1@Integer)$SEX)$Lisp - expr := getCode f - indentFortLevel(convert(-1@Integer)$SEX)$Lisp - expr + atanInverse: I -> % -- atan(1/n) for n an integer > 1 - getElseIf(f:$):SEX == - rec := code f - expr := - fortFormatElseIf(elt(rec.conditionalBranch,switch)$COND::O)$Lisp - expr := - APPEND(expr,getBody elt(rec.conditionalBranch,thenClause)$COND)$Lisp - elseBranch := elt(rec.conditionalBranch,elseClause)$COND - not(operation(elseBranch) case Null) => - operation(elseBranch) case Conditional => - APPEND(expr,getElseIf elseBranch)$Lisp - expr := APPEND(expr, getStatement(ELSE::O,NIL$Lisp)$Lisp)$Lisp - expr := APPEND(expr, getBody elseBranch)$Lisp - expr + expInverse: I -> % -- exp(1/n) for n an integer - getContinue(label:SingleInteger):SEX == - lab : O := label::O - if (width(lab) > 6) then error "Label too big" - cnt : O := "CONTINUE"::O - --sp : O := hspace(6-width lab) - sp : O := hspace(_$fortIndent$Lisp -width lab) - LIST(STRCONC(PRINC_-TO_-STRING(lab)$Lisp,sp,cnt)$Lisp)$Lisp + expSeries: % -> % -- exp(x) by taylor series |x| < 1/2 - getGoto(label:SingleInteger):SEX == - fortran2Lines( - LIST(STRCONC("GOTO ",PRINC_-TO_-STRING(label::O)$Lisp)$Lisp)$Lisp)$Lisp + logSeries: % -> % -- log(x) by taylor series 1/2 < x < 2 - getRepeat(repRec:LOOP):SEX == - sw : Switch := NOT elt(repRec,switch)$LOOP - lab := newLabel() - bod := elt(repRec,body)$LOOP - APPEND(getContinue lab,getBody bod, - fortFormatIfGoto(sw::O,lab)$Lisp)$Lisp + sinSeries: % -> % -- sin(x) by taylor series |x| < 1/2 - getWhile(whileRec:LOOP):SEX == - sw := NOT elt(whileRec,switch)$LOOP - lab1 := newLabel() - lab2 := newLabel() - bod := elt(whileRec,body)$LOOP - APPEND(fortFormatLabelledIfGoto(sw::O,lab1,lab2)$Lisp, - getBody bod, getBody goto(lab1), getContinue lab2)$Lisp + cosSeries: % -> % -- cos(x) by taylor series |x| < 1/2 - getArrayAssign(rec:ARRAYASS):SEX == - getfortarrayexp((rec.var)::O,rec.rand,rec.ints2Floats?)$Lisp + piRamanujan: () -> % -- pi using Ramanujans series - getAssign(rec:ASS):SEX == - indices : L PIN := elt(rec,arrayIndex)$ASS - if indices = []::(L PIN) then - lhs := elt(rec,var)$ASS::O - else - lhs := cons(elt(rec,var)$ASS::PIN,indices)::O - -- Must get the index brackets correct: - lhs := (cdr car cdr convert(lhs)$SEX::SEX)::O -- Yuck! - elt(elt(rec,rand)$ASS,ints2Floats?)$EXPRESSION => - assignment2Fortran1(lhs,elt(elt(rec,rand)$ASS,expr)$EXPRESSION)$Lisp - integerAssignment2Fortran1(lhs,elt(elt(rec,rand)$ASS,expr)$EXPRESSION)$Lisp + writeOMFloat(dev: OpenMathDevice, x: %): Void == + OMputApp(dev) + OMputSymbol(dev, "bigfloat1", "bigfloat") + OMputInteger(dev, mantissa x) + OMputInteger(dev, 2) + OMputInteger(dev, exponent x) + OMputEndApp(dev) - getCond(rec:COND):SEX == - expr := APPEND(fortFormatIf(elt(rec,switch)$COND::O)$Lisp, - getBody elt(rec,thenClause)$COND)$Lisp - elseBranch := elt(rec,elseClause)$COND - if not(operation(elseBranch) case Null) then - operation(elseBranch) case Conditional => - expr := APPEND(expr,getElseIf elseBranch)$Lisp - expr := APPEND(expr,getStatement(ELSE::O,NIL$Lisp)$Lisp, - getBody elseBranch)$Lisp - APPEND(expr,getStatement(ENDIF::O,NIL$Lisp)$Lisp)$Lisp + OMwrite(x: %): String == + s: String := "" + sp := OM_-STRINGTOSTRINGPTR(s)$Lisp + dev: OpenMathDevice := OMopenString(sp pretend String, OMencodingXML) + OMputObject(dev) + writeOMFloat(dev, x) + OMputEndObject(dev) + OMclose(dev) + s := OM_-STRINGPTRTOSTRING(sp)$Lisp pretend String + s - getComment(rec:COMMENT):SEX == - convert([convert(concat("C ",c)$String)@SEX for c in rec])@SEX + OMwrite(x: %, wholeObj: Boolean): String == + s: String := "" + sp := OM_-STRINGTOSTRINGPTR(s)$Lisp + dev: OpenMathDevice := OMopenString(sp pretend String, OMencodingXML) + if wholeObj then + OMputObject(dev) + writeOMFloat(dev, x) + if wholeObj then + OMputEndObject(dev) + OMclose(dev) + s := OM_-STRINGPTRTOSTRING(sp)$Lisp pretend String + s - getCall(rec:CALL):SEX == - expr := concat("CALL ",rec)$String - #expr > 1320 => error "Fortran CALL too large" - fortran2Lines(convert([convert(expr)@SEX ])@SEX)$Lisp + OMwrite(dev: OpenMathDevice, x: %): Void == + OMputObject(dev) + writeOMFloat(dev, x) + OMputEndObject(dev) - getFor(rec:FOR):SEX == - rnge : SegmentBinding PIN := elt(rec,range)$FOR - increment : PIN := elt(rec,span)$FOR - lab : SingleInteger := newLabel() - declare!(variable rnge,fortranInteger()) - expr := fortFormatDo(variable rnge, (lo segment rnge)::O,_ - (hi segment rnge)::O,increment::O,lab)$Lisp - APPEND(expr, getBody elt(rec,body)$FOR, getContinue(lab))$Lisp - - getCode(f:$):SEX == - opp:OP := operation f - rec:OPREC:= code f - opp case Assignment => getAssign(rec.assignmentBranch) - opp case ArrayAssignment => getArrayAssign(rec.arrayAssignmentBranch) - opp case Conditional => getCond(rec.conditionalBranch) - opp case Return => getReturn(rec.returnBranch) - opp case Block => getBlock(rec.blockBranch) - opp case Comment => getComment(rec.commentBranch) - opp case Call => getCall(rec.callBranch) - opp case For => getFor(rec.forBranch) - opp case Continue => getContinue(rec.labelBranch) - opp case Goto => getGoto(rec.labelBranch) - opp case Repeat => getRepeat(rec.loopBranch) - opp case While => getWhile(rec.loopBranch) - opp case Save => getSave() - opp case Stop => getStop() - opp case Print => getPrint(rec.printBranch) - opp case Common => getCommon(rec.commonBranch) - error "Unsupported program construct." - convert(0)@SEX + OMwrite(dev: OpenMathDevice, x: %, wholeObj: Boolean): Void == + if wholeObj then + OMputObject(dev) + writeOMFloat(dev, x) + if wholeObj then + OMputEndObject(dev) + + shift2(x,y) == sign(x)*shift(sign(x)*x,y) - printCode(f:$):Void == - displayLines1$Lisp getCode f - void()$Void + asin x == + zero? x => 0 + negative? x => -asin(-x) + (x = 1) => pi()/2 + x > 1 => error "asin: argument > 1 in magnitude" + inc 5; r := atan(x/sqrt(sub(1,times(x,x)))); dec 5 + normalize r - code (f:$):OPREC == - elt(f,data)$Rep + acos x == + zero? x => pi()/2 + negative? x => (inc 3; r := pi()-acos(-x); dec 3; normalize r) + (x = 1) => 0 + x > 1 => error "acos: argument > 1 in magnitude" + inc 5; r := atan(sqrt(sub(1,times(x,x)))/x); dec 5 + normalize r - operation (f:$):OP == - elt(f,op)$Rep + atan(x,y) == + x = 0 => + y > 0 => pi()/2 + y < 0 => -pi()/2 + 0 + -- Only count on first quadrant being on principal branch. + theta := atan abs(y/x) + if x < 0 then theta := pi() - theta + if y < 0 then theta := - theta + theta - common(name:Symbol,contents:List Symbol):$ == - [["common"]$OP,[[name,contents]$COMMON]$OPREC]$Rep + atan x == + zero? x => 0 + negative? x => -atan(-x) + if x > 1 then + inc 4 + r := if zero? fractionPart x and x < [bits(),0] _ + then atanInverse wholePart x + else atan(1/x) + r := pi/2 - r + dec 4 + return normalize r + -- make |x| < O( 2**(-sqrt p) ) < 1/2 to speed series convergence + -- by using the formula atan(x) = 2*atan(x/(1+sqrt(1+x**2))) + k := ISQRT (bits()-100)::I quo 5 + k := max(0,2 + k + order x) + inc(2*k) + for i in 1..k repeat x := x/(1+sqrt(1+x*x)) + t := atanSeries x + dec(2*k) + t := shift(t,k) + normalize t - stop():$ == - [["stop"]$OP,["null"]$OPREC]$Rep + atanSeries x == + -- atan(x) = x (1 - x**2/3 + x**4/5 - x**6/7 + ...) |x| < 1 + p := bits() + LENGTH bits() + 2 + s:I := d:I := shift(1,p) + y := times(x,x) + t := m := - shift2(y.mantissa,y.exponent+p) + for i in 3.. by 2 while t ^= 0 repeat + s := s + t quo i + t := (m * t) quo d + x * [s,-p] - save():$ == - [["save"]$OP,["null"]$OPREC]$Rep + atanInverse n == + -- compute atan(1/n) for an integer n > 1 + -- atan n = 1/n - 1/n**3/3 + 1/n**5/4 - ... + -- pi = 16 atan(1/5) - 4 atan(1/239) + n2 := -n*n + e:I := bits() + LENGTH bits() + LENGTH n + 1 + s:I := shift(1,e) quo n + t:I := s quo n2 + for k in 3.. by 2 while t ^= 0 repeat + s := s + t quo k + t := t quo n2 + normalize [s,-e] - printStatement(l:List O):$ == - [["print"]$OP,[l]$OPREC]$Rep + sin x == + s := sign x; x := abs x; p := bits(); inc 4 + if x > [6,0] then (inc p; x := 2*pi*fractionPart(x/pi/2); bits p) + if x > [3,0] then (inc p; s := -s; x := x - pi; bits p) + if x > [3,-1] then (inc p; x := pi - x; dec p) + -- make |x| < O( 2**(-sqrt p) ) < 1/2 to speed series convergence + -- by using the formula sin(3*x/3) = 3 sin(x/3) - 4 sin(x/3)**3 + -- the running time is O( sqrt p M(p) ) assuming |x| < 1 + k := ISQRT (bits()-100)::I quo 4 + k := max(0,2 + k + order x) + if k > 0 then (inc k; x := x / 3**k::N) + r := sinSeries x + for i in 1..k repeat r := itimes(3,r)-shift(r**3,2) + bits p + s * r - comment(s:List String):$ == - [["comment"]$OP,[s]$OPREC]$Rep + sinSeries x == + -- sin(x) = x (1 - x**2/3! + x**4/5! - x**6/7! + ... |x| < 1/2 + p := bits() + LENGTH bits() + 2 + y := times(x,x) + s:I := d:I := shift(1,p) + m:I := - shift2(y.mantissa,y.exponent+p) + t:I := m quo 6 + for i in 4.. by 2 while t ^= 0 repeat + s := s + t + t := (m * t) quo (i*(i+1)) + t := t quo d + x * [s,-p] - comment(s:String):$ == - [["comment"]$OP,[list s]$OPREC]$Rep + cos x == + s:I := 1; x := abs x; p := bits(); inc 4 + if x > [6,0] then (inc p; x := 2*pi*fractionPart(x/pi/2); dec p) + if x > [3,0] then (inc p; s := -s; x := x-pi; dec p) + if x > [1,0] then + -- take care of the accuracy problem near pi/2 + inc p; x := pi/2-x; bits p; x := normalize x + return (s * sin x) + -- make |x| < O( 2**(-sqrt p) ) < 1/2 to speed series convergence + -- by using the formula cos(2*x/2) = 2 cos(x/2)**2 - 1 + -- the running time is O( sqrt p M(p) ) assuming |x| < 1 + k := ISQRT (bits()-100)::I quo 3 + k := max(0,2 + k + order x) + -- need to increase precision by more than k, otherwise recursion + -- causes loss of accuracy. + -- Michael Monagan suggests adding a factor of log(k) + if k > 0 then (inc(k+length(k)**2); x := shift(x,-k)) + r := cosSeries x + for i in 1..k repeat r := shift(r*r,1)-1 + bits p + s * r - forLoop(r:SegmentBinding PIN,body:$):$ == - [["for"]$OP,[[r,(incr segment r)::PIN,body]$FOR]$OPREC]$Rep + cosSeries x == + -- cos(x) = 1 - x**2/2! + x**4/4! - x**6/6! + ... |x| < 1/2 + p := bits() + LENGTH bits() + 1 + y := times(x,x) + s:I := d:I := shift(1,p) + m:I := - shift2(y.mantissa,y.exponent+p) + t:I := m quo 2 + for i in 3.. by 2 while t ^= 0 repeat + s := s + t + t := (m * t) quo (i*(i+1)) + t := t quo d + normalize [s,-p] - forLoop(r:SegmentBinding PIN,increment:PIN,body:$):$ == - [["for"]$OP,[[r,increment,body]$FOR]$OPREC]$Rep + tan x == + s := sign x; x := abs x; p := bits(); inc 6 + if x > [3,0] then (inc p; x := pi()*fractionPart(x/pi()); dec p) + if x > [3,-1] then (inc p; x := pi()-x; s := -s; dec p) + if x > 1 then (c := cos x; t := sqrt(1-c*c)/c) + else (c := sin x; t := c/sqrt(1-c*c)) + bits p + s * t - goto(l:SingleInteger):$ == - [["goto"]$OP,[l]$OPREC]$Rep + P:StoredConstant := [1,[1,2]] - continue(l:SingleInteger):$ == - [["continue"]$OP,[l]$OPREC]$Rep + pi() == + -- We use Ramanujan's identity to compute pi. + -- The running time is quadratic in the precision. + -- This is about twice as fast as Machin's identity on Lisp/VM + -- pi = 16 atan(1/5) - 4 atan(1/239) + bits() <= P.precision => normalize P.value + (P := [bits(), piRamanujan()]) value - whileLoop(sw:Switch,b:$):$ == - [["while"]$OP,[[sw,b]$LOOP]$OPREC]$Rep + piRamanujan() == + -- Ramanujans identity for 1/pi + -- Reference: Shanks and Wrench, Math Comp, 1962 + -- "Calculation of pi to 100,000 Decimals". + n := bits() + LENGTH bits() + 11 + t:I := shift(1,n) quo 882 + d:I := 4*882**2 + s:I := 0 + for i in 2.. by 2 for j in 1123.. by 21460 while t ^= 0 repeat + s := s + j*t + m := -(i-1)*(2*i-1)*(2*i-3) + t := (m*t) quo (d*i**3) + 1 / [s,-n-2] - repeatUntilLoop(sw:Switch,b:$):$ == - [["repeat"]$OP,[[sw,b]$LOOP]$OPREC]$Rep + sinh x == + zero? x => 0 + lost:I := max(- order x,0) + 2*lost > bits() => x + inc(5+lost); e := exp x; s := (e-1/e)/2; dec(5+lost) + normalize s - returns():$ == - v := [false,0::O]$EXPRESSION - [["return"]$OP,[[true,v]$RETURN]$OPREC]$Rep + cosh x == + (inc 5; e := exp x; c := (e+1/e)/2; dec 5; normalize c) - returns(v:Expression MachineInteger):$ == - [["return"]$OP,[[false,[false,v::O]$EXPRESSION]$RETURN]$OPREC]$Rep + tanh x == + zero? x => 0 + lost:I := max(- order x,0) + 2*lost > bits() => x + inc(6+lost); e := exp x; e := e*e; t := (e-1)/(e+1); dec(6+lost) + normalize t - returns(v:Expression MachineFloat):$ == - [["return"]$OP,[[false,[false,v::O]$EXPRESSION]$RETURN]$OPREC]$Rep + asinh x == + p := min(0,order x) + if zero? x or 2*p < -bits() then return x + inc(5-p); r := log(x+sqrt(1+x*x)); dec(5-p) + normalize r - returns(v:Expression MachineComplex):$ == - [["return"]$OP,[[false,[false,v::O]$EXPRESSION]$RETURN]$OPREC]$Rep + acosh x == + if x < 1 then error "invalid argument to acosh" + inc 5; r := log(x+sqrt(sub(times(x,x),1))); dec 5 + normalize r - returns(v:Expression Integer):$ == - [["return"]$OP,[[false,[false,v::O]$EXPRESSION]$RETURN]$OPREC]$Rep + atanh x == + if x > 1 or x < -1 then error "invalid argument to atanh" + p := min(0,order x) + if zero? x or 2*p < -bits() then return x + inc(5-p); r := log((x+1)/(1-x))/2; dec(5-p) + normalize r - returns(v:Expression Float):$ == - [["return"]$OP,[[false,[false,v::O]$EXPRESSION]$RETURN]$OPREC]$Rep + log x == + negative? x => error "negative log" + zero? x => error "log 0 generated" + p := bits(); inc 5 + -- apply log(x) = n log 2 + log(x/2**n) so that 1/2 < x < 2 + if (n := order x) < 0 then n := n+1 + l := if n = 0 then 0 else (x := shift(x,-n); n * log2) + -- speed the series convergence by finding m and k such that + -- | exp(m/2**k) x - 1 | < 1 / 2 ** O(sqrt p) + -- write log(exp(m/2**k) x) as m/2**k + log x + k := ISQRT (p-100)::I quo 3 + if k > 1 then + k := max(1,k+order(x-1)) + inc k + ek := expInverse (2**k::N) + dec(p quo 2); m := order square(x,k); inc(p quo 2) + m := (6847196937 * m) quo 9878417065 -- m := m log 2 + x := x * ek ** (-m) + l := l + [m,-k] + l := l + logSeries x + bits p + normalize l - returns(v:Expression Complex Float):$ == - [["return"]$OP,[[false,[false,v::O]$EXPRESSION]$RETURN]$OPREC]$Rep + logSeries x == + -- log(x) = 2 y (1 + y**2/3 + y**4/5 ...) for y = (x-1) / (x+1) + -- given 1/2 < x < 2 on input we have -1/3 < y < 1/3 + p := bits() + (g := LENGTH bits() + 3) + inc g; y := (x-1)/(x+1); dec g + s:I := d:I := shift(1,p) + z := times(y,y) + t := m := shift2(z.mantissa,z.exponent+p) + for i in 3.. by 2 while t ^= 0 repeat + s := s + t quo i + t := m * t quo d + y * [s,1-p] - block(l:List $):$ == - [["block"]$OP,[l]$OPREC]$Rep - - cond(sw:Switch,thenC:$):$ == - [["conditional"]$OP, - [[sw,thenC,[["null"]$OP,["null"]$OPREC]$Rep]$COND]$OPREC]$Rep + L2:StoredConstant := [1,1] - cond(sw:Switch,thenC:$,elseC:$):$ == - [["conditional"]$OP,[[sw,thenC,elseC]$COND]$OPREC]$Rep + log2() == + -- log x = 2 * sum( ((x-1)/(x+1))**(2*k+1)/(2*k+1), k=1.. ) + -- log 2 = 2 * sum( 1/9**k / (2*k+1), k=0..n ) / 3 + n := bits() :: N + n <= L2.precision => normalize L2.value + n := n + LENGTH n + 3 -- guard bits + s:I := shift(1,n+1) quo 3 + t:I := s quo 9 + for k in 3.. by 2 while t ^= 0 repeat + s := s + t quo k + t := t quo 9 + L2 := [bits(),[s,-n]] + normalize L2.value - coerce(f : $):O == - (f.op)::O + L10:StoredConstant := [1,[1,1]] - assign(v:Symbol,rhs:String):$ == - [["assignment"]$OP,[[v,nil()::L PIN,[false,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep + log10() == + -- log x = 2 * sum( ((x-1)/(x+1))**(2*k+1)/(2*k+1), k=0.. ) + -- log 5/4 = 2 * sum( 1/81**k / (2*k+1), k=0.. ) / 9 + n := bits() :: N + n <= L10.precision => normalize L10.value + n := n + LENGTH n + 5 -- guard bits + s:I := shift(1,n+1) quo 9 + t:I := s quo 81 + for k in 3.. by 2 while t ^= 0 repeat + s := s + t quo k + t := t quo 81 + -- We have log 10 = log 5 + log 2 and log 5/4 = log 5 - 2 log 2 + inc 2; L10 := [bits(),[s,-n] + 3*log2]; dec 2 + normalize L10.value - assign(v:Symbol,rhs:Matrix MachineInteger):$ == - [["arrayAssignment"]$OP,[[v,rhs::O,false]$ARRAYASS]$OPREC]$Rep + log2(x) == (inc 2; r := log(x)/log2; dec 2; normalize r) - assign(v:Symbol,rhs:Matrix MachineFloat):$ == - [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep + log10(x) == (inc 2; r := log(x)/log10; dec 2; normalize r) - assign(v:Symbol,rhs:Matrix MachineComplex):$ == - [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep + exp(x) == + -- exp(n+x) = exp(1)**n exp(x) for n such that |x| < 1 + p := bits(); inc 5; e1:% := 1 + if (n := wholePart x) ^= 0 then + inc LENGTH n; e1 := exp1 ** n; dec LENGTH n + x := fractionPart x + if zero? x then (bits p; return normalize e1) + -- make |x| < O( 2**(-sqrt p) ) < 1/2 to speed series convergence + -- by repeated use of the formula exp(2*x/2) = exp(x/2)**2 + -- results in an overall running time of O( sqrt p M(p) ) + k := ISQRT (p-100)::I quo 3 + k := max(0,2 + k + order x) + if k > 0 then (inc k; x := shift(x,-k)) + e := expSeries x + if k > 0 then e := square(e,k) + bits p + e * e1 - assign(v:Symbol,rhs:Vector MachineInteger):$ == - [["arrayAssignment"]$OP,[[v,rhs::O,false]$ARRAYASS]$OPREC]$Rep + expSeries x == + -- exp(x) = 1 + x + x**2/2 + ... + x**i/i! valid for all x + p := bits() + LENGTH bits() + 1 + s:I := d:I := shift(1,p) + t:I := n:I := shift2(x.mantissa,x.exponent+p) + for i in 2.. while t ^= 0 repeat + s := s + t + t := (n * t) quo i + t := t quo d + normalize [s,-p] - assign(v:Symbol,rhs:Vector MachineFloat):$ == - [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep + expInverse k == + -- computes exp(1/k) via continued fraction + p0:I := 2*k+1; p1:I := 6*k*p0+1 + q0:I := 2*k-1; q1:I := 6*k*q0+1 + for i in 10*k.. by 4*k while 2 * LENGTH p0 < bits() repeat + (p0,p1) := (p1,i*p1+p0) + (q0,q1) := (q1,i*q1+q0) + dvide([p1,0],[q1,0]) - assign(v:Symbol,rhs:Vector MachineComplex):$ == - [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep + E:StoredConstant := [1,[1,1]] - assign(v:Symbol,rhs:Matrix Expression MachineInteger):$ == - [["arrayAssignment"]$OP,[[v,rhs::O,false]$ARRAYASS]$OPREC]$Rep + exp1() == + if bits() > E.precision then E := [bits(),expInverse 1] + normalize E.value - assign(v:Symbol,rhs:Matrix Expression MachineFloat):$ == - [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep + sqrt x == + negative? x => error "negative sqrt" + m := x.mantissa; e := x.exponent + l := LENGTH m + p := 2 * bits() - l + 2 + if odd?(e-l) then p := p - 1 + i := shift2(x.mantissa,p) + -- ISQRT uses a variable precision newton iteration + i := ISQRT i + normalize [i,(e-p) quo 2] - assign(v:Symbol,rhs:Matrix Expression MachineComplex):$ == - [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep + bits() == BITS() - assign(v:Symbol,rhs:Vector Expression MachineInteger):$ == - [["arrayAssignment"]$OP,[[v,rhs::O,false]$ARRAYASS]$OPREC]$Rep + bits(n) == (t := bits(); BITS() := n; t) - assign(v:Symbol,rhs:Vector Expression MachineFloat):$ == - [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep + precision() == bits() - assign(v:Symbol,rhs:Vector Expression MachineComplex):$ == - [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep + precision(n) == bits(n) - assign(v:Symbol,index:L PIN,rhs:Expression MachineInteger):$ == - [["assignment"]$OP,[[v,index,[false,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep + increasePrecision n == (b := bits(); bits((b + n)::PI); b) - assign(v:Symbol,index:L PIN,rhs:Expression MachineFloat):$ == - [["assignment"]$OP,[[v,index,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep + decreasePrecision n == (b := bits(); bits((b - n)::PI); b) - assign(v:Symbol,index:L PIN,rhs:Expression MachineComplex):$ == - [["assignment"]$OP,[[v,index,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep + ceillog10base2 n == ((13301 * n + 4003) quo 4004) :: PI - assign(v:Symbol,rhs:Expression MachineInteger):$ == - [["assignment"]$OP,[[v,nil()::L PIN,[false,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep + digits() == max(1,4004 * (bits()-1) quo 13301)::PI - assign(v:Symbol,rhs:Expression MachineFloat):$ == - [["assignment"]$OP,[[v,nil()::L PIN,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep + digits(n) == (t := digits(); bits (1 + ceillog10base2 n); t) - assign(v:Symbol,rhs:Expression MachineComplex):$ == - [["assignment"]$OP,[[v,nil()::L PIN,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep + order(a) == LENGTH a.mantissa + a.exponent - 1 - assign(v:Symbol,rhs:Matrix Expression Integer):$ == - [["arrayAssignment"]$OP,[[v,rhs::O,false]$ARRAYASS]$OPREC]$Rep + relerror(a,b) == order((a-b)/b) - assign(v:Symbol,rhs:Matrix Expression Float):$ == - [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep + 0 == [0,0] - assign(v:Symbol,rhs:Matrix Expression Complex Float):$ == - [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep + 1 == [1,0] - assign(v:Symbol,rhs:Vector Expression Integer):$ == - [["arrayAssignment"]$OP,[[v,rhs::O,false]$ARRAYASS]$OPREC]$Rep + base() == BASE - assign(v:Symbol,rhs:Vector Expression Float):$ == - [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep + mantissa x == x.mantissa - assign(v:Symbol,rhs:Vector Expression Complex Float):$ == - [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep + exponent x == x.exponent - assign(v:Symbol,index:L PIN,rhs:Expression Integer):$ == - [["assignment"]$OP,[[v,index,[false,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep + one? a == a = 1 - assign(v:Symbol,index:L PIN,rhs:Expression Float):$ == - [["assignment"]$OP,[[v,index,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep + zero? a == zero?(a.mantissa) - assign(v:Symbol,index:L PIN,rhs:Expression Complex Float):$ == - [["assignment"]$OP,[[v,index,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep + negative? a == negative?(a.mantissa) - assign(v:Symbol,rhs:Expression Integer):$ == - [["assignment"]$OP,[[v,nil()::L PIN,[false,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep + positive? a == positive?(a.mantissa) - assign(v:Symbol,rhs:Expression Float):$ == - [["assignment"]$OP,[[v,nil()::L PIN,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep + chop(x,p) == + e : I := LENGTH x.mantissa - p + if e > 0 then x := [shift2(x.mantissa,-e),x.exponent+e] + x - assign(v:Symbol,rhs:Expression Complex Float):$ == - [["assignment"]$OP,[[v,nil()::L PIN,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep + float(m,e) == normalize [m,e] - call(s:String):$ == - [["call"]$OP,[s]$OPREC]$Rep + float(m,e,b) == + m = 0 => 0 + inc 4; r := m * [b,0] ** e; dec 4 + normalize r -\end{chunk} + normalize x == + m := x.mantissa + m = 0 => 0 + e : I := LENGTH m - bits() + if e > 0 then + y := shift2(m,1-e) + if odd? y then + y := (if y>0 then y+1 else y-1) quo 2 + if LENGTH y > bits() then + y := y quo 2 + e := e+1 + else y := y quo 2 + x := [y,x.exponent+e] + x -\begin{chunk}{COQ FC} -(* domain FC *) -(* -*) + shift(x:%,n:I) == [x.mantissa,x.exponent+n] -\end{chunk} + x = y == + order x = order y and sign x = sign y and zero? (x - y) -\begin{chunk}{FC.dotabb} -"FC" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FC"] -"FS" [color="#4488FF",href="bookvol10.2.pdf#nameddest=FS"] -"COMPCAT" [color="#4488FF",href="bookvol10.2.pdf#nameddest=COMPCAT"] -"FC" -> "COMPCAT" -"FC" -> "FS" + x < y == + y.mantissa = 0 => x.mantissa < 0 + x.mantissa = 0 => y.mantissa > 0 + negative? x and positive? y => true + negative? y and positive? x => false + order x < order y => positive? x + order x > order y => negative? x + negative? (x-y) -\end{chunk} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain FEXPR FortranExpression} + abs x == if negative? x then -x else normalize x -\begin{chunk}{FortranExpression.input} -)set break resume -)sys rm -f FortranExpression.output -)spool FortranExpression.output -)set message test on -)set message auto off -)clear all + ceiling x == + if negative? x then return (-floor(-x)) + if zero? fractionPart x then x else truncate x + 1 ---S 1 of 1 -)show FortranExpression ---R ---R FortranExpression(basicSymbols: List(Symbol),subscriptedSymbols: List(Symbol),R: FortranMachineTypeCategory) is a domain constructor ---R Abbreviation for FortranExpression is FEXPR ---R This constructor is exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for FEXPR ---R ---R------------------------------- Operations -------------------------------- ---R ?*? : (PositiveInteger,%) -> % ?*? : (NonNegativeInteger,%) -> % ---R ?*? : (Integer,%) -> % ?*? : (%,%) -> % ---R ?*? : (%,R) -> % ?*? : (R,%) -> % ---R ?**? : (%,PositiveInteger) -> % ?**? : (%,NonNegativeInteger) -> % ---R ?+? : (%,%) -> % -? : % -> % ---R ?-? : (%,%) -> % ? Boolean ---R ?<=? : (%,%) -> Boolean ?=? : (%,%) -> Boolean ---R ?>? : (%,%) -> Boolean ?>=? : (%,%) -> Boolean ---R D : (%,Symbol) -> % D : (%,List(Symbol)) -> % ---R 1 : () -> % 0 : () -> % ---R ?^? : (%,PositiveInteger) -> % ?^? : (%,NonNegativeInteger) -> % ---R abs : % -> % acos : % -> % ---R asin : % -> % atan : % -> % ---R belong? : BasicOperator -> Boolean box : List(%) -> % ---R box : % -> % coerce : % -> Expression(R) ---R coerce : Integer -> % coerce : R -> % ---R coerce : Kernel(%) -> % coerce : % -> OutputForm ---R cos : % -> % cosh : % -> % ---R differentiate : (%,Symbol) -> % distribute : (%,%) -> % ---R distribute : % -> % elt : (BasicOperator,List(%)) -> % ---R elt : (BasicOperator,%,%,%) -> % elt : (BasicOperator,%,%) -> % ---R elt : (BasicOperator,%) -> % eval : (%,Symbol,(% -> %)) -> % ---R eval : (%,List(%),List(%)) -> % eval : (%,%,%) -> % ---R eval : (%,Equation(%)) -> % eval : (%,List(Equation(%))) -> % ---R eval : (%,Kernel(%),%) -> % exp : % -> % ---R freeOf? : (%,Symbol) -> Boolean freeOf? : (%,%) -> Boolean ---R hash : % -> SingleInteger height : % -> NonNegativeInteger ---R is? : (%,Symbol) -> Boolean is? : (%,BasicOperator) -> Boolean ---R kernel : (BasicOperator,%) -> % kernels : % -> List(Kernel(%)) ---R latex : % -> String log : % -> % ---R log10 : % -> % map : ((% -> %),Kernel(%)) -> % ---R max : (%,%) -> % min : (%,%) -> % ---R one? : % -> Boolean paren : List(%) -> % ---R paren : % -> % pi : () -> % ---R recip : % -> Union(%,"failed") retract : Symbol -> % ---R retract : Expression(R) -> % retract : % -> R ---R retract : % -> Kernel(%) sample : () -> % ---R sin : % -> % sinh : % -> % ---R sqrt : % -> % subst : (%,Equation(%)) -> % ---R tan : % -> % tanh : % -> % ---R tower : % -> List(Kernel(%)) useNagFunctions : Boolean -> Boolean ---R useNagFunctions : () -> Boolean variables : % -> List(Symbol) ---R zero? : % -> Boolean ?~=? : (%,%) -> Boolean ---R D : (%,Symbol,NonNegativeInteger) -> % ---R D : (%,List(Symbol),List(NonNegativeInteger)) -> % ---R characteristic : () -> NonNegativeInteger ---R definingPolynomial : % -> % if $ has RING ---R differentiate : (%,List(Symbol)) -> % ---R differentiate : (%,Symbol,NonNegativeInteger) -> % ---R differentiate : (%,List(Symbol),List(NonNegativeInteger)) -> % ---R elt : (BasicOperator,%,%,%,%) -> % ---R eval : (%,BasicOperator,(% -> %)) -> % ---R eval : (%,BasicOperator,(List(%) -> %)) -> % ---R eval : (%,List(BasicOperator),List((List(%) -> %))) -> % ---R eval : (%,List(BasicOperator),List((% -> %))) -> % ---R eval : (%,Symbol,(List(%) -> %)) -> % ---R eval : (%,List(Symbol),List((List(%) -> %))) -> % ---R eval : (%,List(Symbol),List((% -> %))) -> % ---R eval : (%,List(Kernel(%)),List(%)) -> % ---R even? : % -> Boolean if $ has RETRACT(INT) ---R kernel : (BasicOperator,List(%)) -> % ---R mainKernel : % -> Union(Kernel(%),"failed") ---R minPoly : Kernel(%) -> SparseUnivariatePolynomial(%) if $ has RING ---R odd? : % -> Boolean if $ has RETRACT(INT) ---R operator : BasicOperator -> BasicOperator ---R operators : % -> List(BasicOperator) ---R retract : Polynomial(Float) -> % if R has RETRACT(FLOAT) ---R retract : Fraction(Polynomial(Float)) -> % if R has RETRACT(FLOAT) ---R retract : Expression(Float) -> % if R has RETRACT(FLOAT) ---R retract : Polynomial(Integer) -> % if R has RETRACT(INT) ---R retract : Fraction(Polynomial(Integer)) -> % if R has RETRACT(INT) ---R retract : Expression(Integer) -> % if R has RETRACT(INT) ---R retractIfCan : Polynomial(Float) -> Union(%,"failed") if R has RETRACT(FLOAT) ---R retractIfCan : Fraction(Polynomial(Float)) -> Union(%,"failed") if R has RETRACT(FLOAT) ---R retractIfCan : Expression(Float) -> Union(%,"failed") if R has RETRACT(FLOAT) ---R retractIfCan : Polynomial(Integer) -> Union(%,"failed") if R has RETRACT(INT) ---R retractIfCan : Fraction(Polynomial(Integer)) -> Union(%,"failed") if R has RETRACT(INT) ---R retractIfCan : Expression(Integer) -> Union(%,"failed") if R has RETRACT(INT) ---R retractIfCan : Symbol -> Union(%,"failed") ---R retractIfCan : Expression(R) -> Union(%,"failed") ---R retractIfCan : % -> Union(R,"failed") ---R retractIfCan : % -> Union(Kernel(%),"failed") ---R subst : (%,List(Kernel(%)),List(%)) -> % ---R subst : (%,List(Equation(%))) -> % ---R subtractIfCan : (%,%) -> Union(%,"failed") ---R ---E 1 + wholePart x == shift2(x.mantissa,x.exponent) -)spool -)lisp (bye) -\end{chunk} -\begin{chunk}{FortranExpression.help} -==================================================================== -FortranExpression examples -==================================================================== + floor x == if negative? x then -ceiling(-x) else truncate x -A domain of expressions involving functions which can be translated into -standard Fortran-77, with some extra extensions from the NAG Fortran Library. + round x == (half := [sign x,-1]; truncate(x + half)) -See Also: -o )show FortranExpression + sign x == if x.mantissa < 0 then -1 else 1 -\end{chunk} + truncate x == + if x.exponent >= 0 then return x + normalize [shift2(x.mantissa,x.exponent),0] -\pagehead{FortranExpression}{FEXPR} -\pagepic{ps/v103fortranexpression.ps}{FEXPR}{1.00} -{\bf See}\\ -\pageto{Result}{RESULT} -\pageto{FortranCode}{FC} -\pageto{FortranProgram}{FORTRAN} -\pageto{ThreeDimensionalMatrix}{M3D} -\pageto{SimpleFortranProgram}{SFORT} -\pageto{Switch}{SWITCH} -\pageto{FortranTemplate}{FTEM} + recip(x) == if x=0 then "failed" else 1/x -{\bf Exports:}\\ -\begin{tabular}{lllll} -\cross{FEXPR}{0} & -\cross{FEXPR}{1} & -\cross{FEXPR}{abs} & -\cross{FEXPR}{acos} & -\cross{FEXPR}{asin} \\ -\cross{FEXPR}{atan} & -\cross{FEXPR}{belong?} & -\cross{FEXPR}{box} & -\cross{FEXPR}{characteristic} & -\cross{FEXPR}{coerce} \\ -\cross{FEXPR}{cos} & -\cross{FEXPR}{cosh} & -\cross{FEXPR}{D} & -\cross{FEXPR}{definingPolynomial} & -\cross{FEXPR}{differentiate} \\ -\cross{FEXPR}{distribute} & -\cross{FEXPR}{elt} & -\cross{FEXPR}{eval} & -\cross{FEXPR}{even?} & -\cross{FEXPR}{exp} \\ -\cross{FEXPR}{freeOf?} & -\cross{FEXPR}{hash} & -\cross{FEXPR}{height} & -\cross{FEXPR}{is?} & -\cross{FEXPR}{kernel} \\ -\cross{FEXPR}{kernels} & -\cross{FEXPR}{latex} & -\cross{FEXPR}{log} & -\cross{FEXPR}{log10} & -\cross{FEXPR}{mainKernel} \\ -\cross{FEXPR}{map} & -\cross{FEXPR}{max} & -\cross{FEXPR}{min} & -\cross{FEXPR}{minPoly} & -\cross{FEXPR}{odd?} \\ -\cross{FEXPR}{one?} & -\cross{FEXPR}{operator} & -\cross{FEXPR}{operators} & -\cross{FEXPR}{paren} & -\cross{FEXPR}{pi} \\ -\cross{FEXPR}{recip} & -\cross{FEXPR}{retract} & -\cross{FEXPR}{retractIfCan} & -\cross{FEXPR}{sample} & -\cross{FEXPR}{sin} \\ -\cross{FEXPR}{sinh} & -\cross{FEXPR}{sqrt} & -\cross{FEXPR}{subst} & -\cross{FEXPR}{subtractIfCan} & -\cross{FEXPR}{tan} \\ -\cross{FEXPR}{tanh} & -\cross{FEXPR}{tower} & -\cross{FEXPR}{useNagFunctions} & -\cross{FEXPR}{variables} & -\cross{FEXPR}{zero?} \\ -\cross{FEXPR}{?*?} & -\cross{FEXPR}{?**?} & -\cross{FEXPR}{?+?} & -\cross{FEXPR}{-?} & -\cross{FEXPR}{?-?} \\ -\cross{FEXPR}{?$<$?} & -\cross{FEXPR}{?$<=$?} & -\cross{FEXPR}{?=?} & -\cross{FEXPR}{?$>$?} & -\cross{FEXPR}{?$>=$?} \\ -\cross{FEXPR}{?\^{}?} & -\cross{FEXPR}{?\~{}=?} &&& -\end{tabular} + differentiate x == 0 -\begin{chunk}{domain FEXPR FortranExpression} -)abbrev domain FEXPR FortranExpression -++ Author: Mike Dewar -++ Date Created: December 1993 -++ Date Last Updated: 12 July 1994 added RetractableTo(R) -++ Description: -++ A domain of expressions involving functions which can be -++ translated into standard Fortran-77, with some extra extensions from -++ the NAG Fortran Library. + - x == normalize negate x -FortranExpression(basicSymbols,subscriptedSymbols,R): - Exports==Implementation where - basicSymbols : List Symbol - subscriptedSymbols : List Symbol - R : FortranMachineTypeCategory + negate x == [-x.mantissa,x.exponent] - EXPR ==> Expression - EXF2 ==> ExpressionFunctions2 - S ==> Symbol - L ==> List - BO ==> BasicOperator - FRAC ==> Fraction - POLY ==> Polynomial + x + y == normalize plus(x,y) - Exports ==> Join(ExpressionSpace,Algebra(R),RetractableTo(R), - PartialDifferentialRing(Symbol)) with - retract : EXPR R -> $ - ++ retract(e) takes e and transforms it into a - ++ FortranExpression checking that it contains no non-Fortran - ++ functions, and that it only contains the given basic symbols - ++ and subscripted symbols which correspond to scalar and array - ++ parameters respectively. - retractIfCan : EXPR R -> Union($,"failed") - ++ retractIfCan(e) takes e and tries to transform it into a - ++ FortranExpression checking that it contains no non-Fortran - ++ functions, and that it only contains the given basic symbols - ++ and subscripted symbols which correspond to scalar and array - ++ parameters respectively. - retract : S -> $ - ++ retract(e) takes e and transforms it into a FortranExpression - ++ checking that it is one of the given basic symbols - ++ or subscripted symbols which correspond to scalar and array - ++ parameters respectively. - retractIfCan : S -> Union($,"failed") - ++ retractIfCan(e) takes e and tries to transform it into a - ++ FortranExpression checking that it is one of the given basic symbols - ++ or subscripted symbols which correspond to scalar and array - ++ parameters respectively. - coerce : $ -> EXPR R - ++ coerce(x) is not documented - if (R has RetractableTo(Integer)) then - retract : EXPR Integer -> $ - ++ retract(e) takes e and transforms it into a - ++ FortranExpression checking that it contains no non-Fortran - ++ functions, and that it only contains the given basic symbols - ++ and subscripted symbols which correspond to scalar and array - ++ parameters respectively. - retractIfCan : EXPR Integer -> Union($,"failed") - ++ retractIfCan(e) takes e and tries to transform it into a - ++ FortranExpression checking that it contains no non-Fortran - ++ functions, and that it only contains the given basic symbols - ++ and subscripted symbols which correspond to scalar and array - ++ parameters respectively. - retract : FRAC POLY Integer -> $ - ++ retract(e) takes e and transforms it into a - ++ FortranExpression checking that it contains no non-Fortran - ++ functions, and that it only contains the given basic symbols - ++ and subscripted symbols which correspond to scalar and array - ++ parameters respectively. - retractIfCan : FRAC POLY Integer -> Union($,"failed") - ++ retractIfCan(e) takes e and tries to transform it into a - ++ FortranExpression checking that it contains no non-Fortran - ++ functions, and that it only contains the given basic symbols - ++ and subscripted symbols which correspond to scalar and array - ++ parameters respectively. - retract : POLY Integer -> $ - ++ retract(e) takes e and transforms it into a - ++ FortranExpression checking that it contains no non-Fortran - ++ functions, and that it only contains the given basic symbols - ++ and subscripted symbols which correspond to scalar and array - ++ parameters respectively. - retractIfCan : POLY Integer -> Union($,"failed") - ++ retractIfCan(e) takes e and tries to transform it into a - ++ FortranExpression checking that it contains no non-Fortran - ++ functions, and that it only contains the given basic symbols - ++ and subscripted symbols which correspond to scalar and array - ++ parameters respectively. - if (R has RetractableTo(Float)) then - retract : EXPR Float -> $ - ++ retract(e) takes e and transforms it into a - ++ FortranExpression checking that it contains no non-Fortran - ++ functions, and that it only contains the given basic symbols - ++ and subscripted symbols which correspond to scalar and array - ++ parameters respectively. - retractIfCan : EXPR Float -> Union($,"failed") - ++ retractIfCan(e) takes e and tries to transform it into a - ++ FortranExpression checking that it contains no non-Fortran - ++ functions, and that it only contains the given basic symbols - ++ and subscripted symbols which correspond to scalar and array - ++ parameters respectively. - retract : FRAC POLY Float -> $ - ++ retract(e) takes e and transforms it into a - ++ FortranExpression checking that it contains no non-Fortran - ++ functions, and that it only contains the given basic symbols - ++ and subscripted symbols which correspond to scalar and array - ++ parameters respectively. - retractIfCan : FRAC POLY Float -> Union($,"failed") - ++ retractIfCan(e) takes e and tries to transform it into a - ++ FortranExpression checking that it contains no non-Fortran - ++ functions, and that it only contains the given basic symbols - ++ and subscripted symbols which correspond to scalar and array - ++ parameters respectively. - retract : POLY Float -> $ - ++ retract(e) takes e and transforms it into a - ++ FortranExpression checking that it contains no non-Fortran - ++ functions, and that it only contains the given basic symbols - ++ and subscripted symbols which correspond to scalar and array - ++ parameters respectively. - retractIfCan : POLY Float -> Union($,"failed") - ++ retractIfCan(e) takes e and tries to transform it into a - ++ FortranExpression checking that it contains no non-Fortran - ++ functions, and that it only contains the given basic symbols - ++ and subscripted symbols which correspond to scalar and array - ++ parameters respectively. - abs : $ -> $ - ++ abs(x) represents the Fortran intrinsic function ABS - sqrt : $ -> $ - ++ sqrt(x) represents the Fortran intrinsic function SQRT - exp : $ -> $ - ++ exp(x) represents the Fortran intrinsic function EXP - log : $ -> $ - ++ log(x) represents the Fortran intrinsic function LOG - log10 : $ -> $ - ++ log10(x) represents the Fortran intrinsic function LOG10 - sin : $ -> $ - ++ sin(x) represents the Fortran intrinsic function SIN - cos : $ -> $ - ++ cos(x) represents the Fortran intrinsic function COS - tan : $ -> $ - ++ tan(x) represents the Fortran intrinsic function TAN - asin : $ -> $ - ++ asin(x) represents the Fortran intrinsic function ASIN - acos : $ -> $ - ++ acos(x) represents the Fortran intrinsic function ACOS - atan : $ -> $ - ++ atan(x) represents the Fortran intrinsic function ATAN - sinh : $ -> $ - ++ sinh(x) represents the Fortran intrinsic function SINH - cosh : $ -> $ - ++ cosh(x) represents the Fortran intrinsic function COSH - tanh : $ -> $ - ++ tanh(x) represents the Fortran intrinsic function TANH - pi : () -> $ - ++ pi(x) represents the NAG Library function X01AAF which returns - ++ an approximation to the value of pi - variables : $ -> L S - ++ variables(e) return a list of all the variables in \spad{e}. - useNagFunctions : () -> Boolean - ++ useNagFunctions() indicates whether NAG functions are being used - ++ for mathematical and machine constants. - useNagFunctions : Boolean -> Boolean - ++ useNagFunctions(v) sets the flag which controls whether NAG functions - ++ are being used for mathematical and machine constants. The previous - ++ value is returned. + x - y == normalize plus(x,negate y) - Implementation ==> EXPR R add + sub(x,y) == plus(x,negate y) - -- The standard FORTRAN-77 intrinsic functions, plus nthRoot which - -- can be translated into an arithmetic expression: - f77Functions : L S := [abs,sqrt,exp,log,log10,sin,cos,tan,asin,acos, - atan,sinh,cosh,tanh,nthRoot,%power] - nagFunctions : L S := [pi, X01AAF] - useNagFunctionsFlag : Boolean := true + plus(x,y) == + mx := x.mantissa; my := y.mantissa + mx = 0 => y + my = 0 => x + ex := x.exponent; ey := y.exponent + ex = ey => [mx+my,ex] + de := ex + LENGTH mx - ey - LENGTH my + de > bits()+1 => x + de < -(bits()+1) => y + if ex < ey then (mx,my,ex,ey) := (my,mx,ey,ex) + mw := my + shift2(mx,ex-ey) + [mw,ey] - -- Local functions to check for "unassigned" symbols etc. + x:% * y:% == normalize times (x,y) - mkEqn(s1:Symbol,s2:Symbol):Equation EXPR(R) == - equation(s2::EXPR(R),script(s1,scripts(s2))::EXPR(R)) + x:I * y:% == + if LENGTH x > bits() then normalize [x,0] * y + else normalize [x * y.mantissa,y.exponent] - fixUpSymbols(u:EXPR R):Union(EXPR R,"failed") == - -- If its a univariate expression then just fix it up: - syms : L S := variables(u) --- one?(#basicSymbols) and zero?(#subscriptedSymbols) => - (#basicSymbols = 1) and zero?(#subscriptedSymbols) => --- not one?(#syms) => "failed" - not (#syms = 1) => "failed" - subst(u,equation(first(syms)::EXPR(R),first(basicSymbols)::EXPR(R))) - -- We have one variable but it is subscripted: --- zero?(#basicSymbols) and one?(#subscriptedSymbols) => - zero?(#basicSymbols) and (#subscriptedSymbols = 1) => - -- Make sure we don't have both X and X_i - for s in syms repeat - not scripted?(s) => return "failed" --- not one?(#(syms:=removeDuplicates! [name(s) for s in syms]))=> "failed" - not ((#(syms:=removeDuplicates! [name(s) for s in syms])) = 1)=> "failed" - sym : Symbol := first subscriptedSymbols - subst(u,[mkEqn(sym,i) for i in variables(u)]) - "failed" + x:% / y:% == normalize dvide(x,y) - extraSymbols?(u:EXPR R):Boolean == - syms : L S := [name(v) for v in variables(u)] - extras : L S := setDifference(syms, - setUnion(basicSymbols,subscriptedSymbols)) - not empty? extras + x:% / y:I == + if LENGTH y > bits() then x / normalize [y,0] else x / [y,0] - checkSymbols(u:EXPR R):EXPR(R) == - syms : L S := [name(v) for v in variables(u)] - extras : L S := setDifference(syms, - setUnion(basicSymbols,subscriptedSymbols)) - not empty? extras => - m := fixUpSymbols(u) - m case EXPR(R) => m::EXPR(R) - error("Extra symbols detected:",[string(v) for v in extras]$L(String)) - u + inv x == 1 / x - notSymbol?(v:BO):Boolean == - s : S := name v - member?(s,basicSymbols) or - scripted?(s) and member?(name s,subscriptedSymbols) => false - true + times(x:%,y:%) == [x.mantissa * y.mantissa, x.exponent + y.exponent] - extraOperators?(u:EXPR R):Boolean == - ops : L S := [name v for v in operators(u) | notSymbol?(v)] - if useNagFunctionsFlag then - fortranFunctions : L S := append(f77Functions,nagFunctions) - else - fortranFunctions : L S := f77Functions - extras : L S := setDifference(ops,fortranFunctions) - not empty? extras + itimes(n:I,y:%) == [n * y.mantissa,y.exponent] - checkOperators(u:EXPR R):Void == - ops : L S := [name v for v in operators(u) | notSymbol?(v)] - if useNagFunctionsFlag then - fortranFunctions : L S := append(f77Functions,nagFunctions) - else - fortranFunctions : L S := f77Functions - extras : L S := setDifference(ops,fortranFunctions) - not empty? extras => - error("Non FORTRAN-77 functions detected:",[string(v) for v in extras]) - void() + dvide(x,y) == + ew := LENGTH y.mantissa - LENGTH x.mantissa + bits() + 1 + mw := shift2(x.mantissa,ew) quo y.mantissa + ew := x.exponent - y.exponent - ew + [mw,ew] - checkForNagOperators(u:EXPR R):$ == - useNagFunctionsFlag => - import Pi - import PiCoercions(R) - piOp : BasicOperator := operator X01AAF - piSub : Equation EXPR R := - equation(pi()$Pi::EXPR(R),kernel(piOp,0::EXPR(R))$EXPR(R)) - subst(u,piSub) pretend $ - u pretend $ + square(x,n) == + ma := x.mantissa; ex := x.exponent + for k in 1..n repeat + ma := ma * ma; ex := ex + ex + l:I := bits()::I - LENGTH ma + ma := shift2(ma,l); ex := ex - l + [ma,ex] - -- Conditional retractions: + power(x,n) == + y:% := 1; z:% := x + repeat + if odd? n then y := chop( times(y,z), bits() ) + if (n := n quo 2) = 0 then return y + z := chop( times(z,z), bits() ) - if R has RetractableTo(Integer) then + x:% ** y:% == + x = 0 => + y = 0 => error "0**0 is undefined" + y < 0 => error "division by 0" + y > 0 => 0 + y = 0 => 1 + y = 1 => x + x = 1 => 1 + p := abs order y + 5 + inc p; r := exp(y*log(x)); dec p + normalize r - retractIfCan(u:POLY Integer):Union($,"failed") == - retractIfCan((u::EXPR Integer)$EXPR(Integer))@Union($,"failed") + x:% ** r:RN == + x = 0 => + r = 0 => error "0**0 is undefined" + r < 0 => error "division by 0" + r > 0 => 0 + r = 0 => 1 + r = 1 => x + x = 1 => 1 + n := numer r + d := denom r + negative? x => + odd? d => + odd? n => return -((-x)**r) + return ((-x)**r) + error "negative root" + if d = 2 then + inc LENGTH n; y := sqrt(x); y := y**n; dec LENGTH n + return normalize y + y := [n,0]/[d,0] + x ** y - retract(u:POLY Integer):$ == - retract((u::EXPR Integer)$EXPR(Integer))@$ + x:% ** n:I == + x = 0 => + n = 0 => error "0**0 is undefined" + n < 0 => error "division by 0" + n > 0 => 0 + n = 0 => 1 + n = 1 => x + x = 1 => 1 + p := bits() + bits(p + LENGTH n + 2) + y := power(x,abs n) + if n < 0 then y := dvide(1,y) + bits p + normalize y - retractIfCan(u:FRAC POLY Integer):Union($,"failed") == - retractIfCan((u::EXPR Integer)$EXPR(Integer))@Union($,"failed") + -- Utility routines for conversion to decimal - retract(u:FRAC POLY Integer):$ == - retract((u::EXPR Integer)$EXPR(Integer))@$ + ceilLength10: I -> I - int2R(u:Integer):R == u::R + chop10: (%,I) -> % - retractIfCan(u:EXPR Integer):Union($,"failed") == - retractIfCan(map(int2R,u)$EXF2(Integer,R))@Union($,"failed") + convert10:(%,I) -> % - retract(u:EXPR Integer):$ == - retract(map(int2R,u)$EXF2(Integer,R))@$ + floorLength10: I -> I - if R has RetractableTo(Float) then + length10: I -> I - retractIfCan(u:POLY Float):Union($,"failed") == - retractIfCan((u::EXPR Float)$EXPR(Float))@Union($,"failed") + normalize10: (%,I) -> % - retract(u:POLY Float):$ == - retract((u::EXPR Float)$EXPR(Float))@$ + quotient10: (%,%,I) -> % - retractIfCan(u:FRAC POLY Float):Union($,"failed") == - retractIfCan((u::EXPR Float)$EXPR(Float))@Union($,"failed") + power10: (%,I,I) -> % - retract(u:FRAC POLY Float):$ == - retract((u::EXPR Float)$EXPR(Float))@$ + times10: (%,%,I) -> % - float2R(u:Float):R == (u::R) + convert10(x,d) == + m := x.mantissa; e := x.exponent + --!! deal with bits here + b := bits(); (q,r) := divide(abs e, b) + b := 2**b::N; r := 2**r::N + -- compute 2**e = b**q * r + h := power10([b,0],q,d+5) + h := chop10([r*h.mantissa,h.exponent],d+5) + if e < 0 then h := quotient10([m,0],h,d) + else times10([m,0],h,d) - retractIfCan(u:EXPR Float):Union($,"failed") == - retractIfCan(map(float2R,u)$EXF2(Float,R))@Union($,"failed") + ceilLength10 n == 146 * LENGTH n quo 485 + 1 - retract(u:EXPR Float):$ == - retract(map(float2R,u)$EXF2(Float,R))@$ + floorLength10 n == 643 * LENGTH n quo 2136 - -- Exported Functions + length10 n == + ln := LENGTH(n:=abs n) + upper := 76573 * ln quo 254370 + lower := 21306 * (ln-1) quo 70777 + upper = lower => upper + 1 + n := n quo (10**lower::N) + while n >= 10 repeat + n:= n quo 10 + lower := lower + 1 + lower + 1 - useNagFunctions():Boolean == useNagFunctionsFlag - useNagFunctions(v:Boolean):Boolean == - old := useNagFunctionsFlag - useNagFunctionsFlag := v - old - - log10(x:$):$ == - kernel(operator log10,x) + chop10(x,p) == + e : I := floorLength10 x.mantissa - p + if e > 0 then x := [x.mantissa quo 10**e::N,x.exponent+e] + x - pi():$ == kernel(operator X01AAF,0) + normalize10(x,p) == + ma := x.mantissa + ex := x.exponent + e : I := length10 ma - p + if e > 0 then + ma := ma quo 10**(e-1)::N + ex := ex + e + (ma,r) := divide(ma, 10) + if r > 4 then + ma := ma + 1 + if ma = 10**p::N then (ma := 1; ex := ex + p) + [ma,ex] - coerce(u:$):EXPR R == u pretend EXPR(R) + times10(x,y,p) == normalize10(times(x,y),p) - retractIfCan(u:EXPR R):Union($,"failed") == - if (extraSymbols? u) then - m := fixUpSymbols(u) - m case "failed" => return "failed" - u := m::EXPR(R) - extraOperators? u => "failed" - checkForNagOperators(u) + quotient10(x,y,p) == + ew := floorLength10 y.mantissa - ceilLength10 x.mantissa + p + 2 + if ew < 0 then ew := 0 + mw := (x.mantissa * 10**ew::N) quo y.mantissa + ew := x.exponent - y.exponent - ew + normalize10([mw,ew],p) - retract(u:EXPR R):$ == - u:=checkSymbols(u) - checkOperators(u) - checkForNagOperators(u) + power10(x,n,d) == + x = 0 => 0 + n = 0 => 1 + n = 1 => x + x = 1 => 1 + p:I := d + LENGTH n + 1 + e:I := n + y:% := 1 + z:% := x + repeat + if odd? e then y := chop10(times(y,z),p) + if (e := e quo 2) = 0 then return y + z := chop10(times(z,z),p) - retractIfCan(u:Symbol):Union($,"failed") == - not (member?(u,basicSymbols) or - scripted?(u) and member?(name u,subscriptedSymbols)) => "failed" - (((u::EXPR(R))$(EXPR R))pretend Rep)::$ + -------------------------------- + -- Output routines for Floats -- + -------------------------------- + zero ==> char("0") - retract(u:Symbol):$ == - res : Union($,"failed") := retractIfCan(u) - res case "failed" => error("Illegal Symbol Detected:",u::String) - res::$ + separator ==> space()$Character -\end{chunk} + SPACING : Reference(N) := ref 10 + + OUTMODE : Reference(S) := ref "general" + + OUTPREC : Reference(I) := ref(-1) + + fixed : % -> S + + floating : % -> S + + general : % -> S + + padFromLeft(s:S):S == + zero? SPACING() => s + n:I := #s - 1 + t := new( (n + 1 + n quo SPACING()) :: N , separator ) + for i in 0..n for j in minIndex t .. repeat + t.j := s.(i + minIndex s) + if (i+1) rem SPACING() = 0 then j := j+1 + t + padFromRight(s:S):S == + SPACING() = 0 => s + n:I := #s - 1 + t := new( (n + 1 + n quo SPACING()) :: N , separator ) + for i in n..0 by -1 for j in maxIndex t .. by -1 repeat + t.j := s.(i + minIndex s) + if (n-i+1) rem SPACING() = 0 then j := j-1 + t + + fixed f == + d := if OUTPREC() = -1 then digits::I else OUTPREC() + dpos:N:= if (d > 0) then d::N else 1::N + zero? f => + OUTPREC() = -1 => "0.0" + concat("0",concat(".",padFromLeft new(dpos,zero))) + zero? exponent f => + concat(padFromRight convert(mantissa f)@S, + concat(".",padFromLeft new(dpos,zero))) + negative? f => concat("-", fixed abs f) + bl := LENGTH(f.mantissa) + f.exponent + dd := + OUTPREC() = -1 => d + bl > 0 => (146*bl) quo 485 + 1 + d + d + g := convert10(abs f,dd) + m := g.mantissa + e := g.exponent + if OUTPREC() ^= -1 then + -- round g to OUTPREC digits after the decimal point + l := length10 m + if -e > OUTPREC() and -e < 2*digits::I then + g := normalize10(g,l+e+OUTPREC()) + m := g.mantissa; e := g.exponent + s := convert(m)@S; n := #s; o := e+n + p := if OUTPREC() = -1 then n::I else OUTPREC() + t:S + if e >= 0 then + s := concat(s, new(e::N, zero)) + t := "" + else if o <= 0 then + t := concat(new((-o)::N,zero), s) + s := "0" + else + t := s(o + minIndex s .. n + minIndex s - 1) + s := s(minIndex s .. o + minIndex s - 1) + n := #t + if OUTPREC() = -1 then + t := rightTrim(t,zero) + if t = "" then t := "0" + else if n > p then t := t(minIndex t .. p + minIndex t- 1) + else t := concat(t, new((p-n)::N,zero)) + concat(padFromRight s, concat(".", padFromLeft t)) + + floating f == + zero? f => "0.0" + negative? f => concat("-", floating abs f) + t:S := if zero? SPACING() then "E" else " E " + zero? exponent f => + s := convert(mantissa f)@S + concat ["0.", padFromLeft s, t, convert(#s)@S] + -- base conversion to decimal rounded to the requested precision + d := if OUTPREC() = -1 then digits::I else OUTPREC() + g := convert10(f,d); m := g.mantissa; e := g.exponent + -- I'm assuming that length10 m = # s given n > 0 + s := convert(m)@S; n := #s; o := e+n + s := padFromLeft s + concat ["0.", s, t, convert(o)@S] + + general(f) == + zero? f => "0.0" + negative? f => concat("-", general abs f) + d := if OUTPREC() = -1 then digits::I else OUTPREC() + zero? exponent f => + d := d + 1 + s := convert(mantissa f)@S + OUTPREC() ^= -1 and (e := #s) > d => + t:S := if zero? SPACING() then "E" else " E " + concat ["0.", padFromLeft s, t, convert(e)@S] + padFromRight concat(s, ".0") + -- base conversion to decimal rounded to the requested precision + g := convert10(f,d); m := g.mantissa; e := g.exponent + -- I'm assuming that length10 m = # s given n > 0 + s := convert(m)@S; n := #s; o := n + e + -- Note: at least one digit is displayed after the decimal point + -- and trailing zeroes after the decimal point are dropped + if o > 0 and o <= max(n,d) then + -- fixed format: add trailing zeroes before the decimal point + if o > n then s := concat(s, new((o-n)::N,zero)) + t := rightTrim(s(o + minIndex s .. n + minIndex s - 1), zero) + if t = "" then t := "0" else t := padFromLeft t + s := padFromRight s(minIndex s .. o + minIndex s - 1) + concat(s, concat(".", t)) + else if o <= 0 and o >= -5 then + -- fixed format: up to 5 leading zeroes after the decimal point + concat("0.",padFromLeft concat(new((-o)::N,zero),rightTrim(s,zero))) + else + -- print using E format written 0.mantissa E exponent + t := padFromLeft rightTrim(s,zero) + s := if zero? SPACING() then "E" else " E " + concat ["0.", t, s, convert(e+n)@S] + + outputSpacing n == SPACING() := n + + outputFixed() == (OUTMODE() := "fixed"; OUTPREC() := -1) + + outputFixed n == (OUTMODE() := "fixed"; OUTPREC() := n::I) + + outputGeneral() == (OUTMODE() := "general"; OUTPREC() := -1) + + outputGeneral n == (OUTMODE() := "general"; OUTPREC() := n::I) + + outputFloating() == (OUTMODE() := "floating"; OUTPREC() := -1) + + outputFloating n == (OUTMODE() := "floating"; OUTPREC() := n::I) + + convert(f):S == + b:Integer := + OUTPREC() = -1 and not zero? f => + bits(length(abs mantissa f)::PositiveInteger) + 0 + s := + OUTMODE() = "fixed" => fixed f + OUTMODE() = "floating" => floating f + OUTMODE() = "general" => general f + empty()$String + if b > 0 then bits(b::PositiveInteger) + s = empty()$String => error "bad output mode" + s + + coerce(f):OutputForm == + f >= 0 => message(convert(f)@S) + - (coerce(-f)@OutputForm) + + convert(f):InputForm == + convert [convert("float"::Symbol), convert mantissa f, + convert exponent f, convert base()]$List(InputForm) + + -- Conversion routines + + convert(x:%):Float == x pretend Float + + convert(x:%):SF == makeSF(x.mantissa,x.exponent)$Lisp + + coerce(x:%):SF == convert(x)@SF + + convert(sf:SF):% == float(mantissa sf,exponent sf,base()$SF) + + retract(f:%):RN == rationalApproximation(f,(bits()-1)::N,BASE) + + retractIfCan(f:%):Union(RN, "failed") == + rationalApproximation(f,(bits()-1)::N,BASE) + + retract(f:%):I == + (f = (n := wholePart f)::%) => n + error "Not an integer" + + retractIfCan(f:%):Union(I, "failed") == + (f = (n := wholePart f)::%) => n + "failed" + + rationalApproximation(f,d) == rationalApproximation(f,d,10) + + rationalApproximation(f,d,b) == + t: Integer + nu := f.mantissa; ex := f.exponent + if ex >= 0 then return ((nu*BASE**(ex::N))/1) + de := BASE**((-ex)::N) + if b < 2 then error "base must be > 1" + tol := b**d + s := nu; t := de + p0,p1,q0,q1 : Integer + p0 := 0; p1 := 1; q0 := 1; q1 := 0 + repeat + (q,r) := divide(s, t) + p2 := q*p1+p0 + q2 := q*q1+q0 + if r = 0 or tol*abs(nu*q2-de*p2) < de*abs(p2) then return (p2/q2) + (p0,p1) := (p1,p2) + (q0,q1) := (q1,q2) + (s,t) := (t,r) -\begin{chunk}{COQ FEXPR} -(* domain FEXPR *) -(* *) \end{chunk} -\begin{chunk}{FEXPR.dotabb} -"FEXPR" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FEXPR"] +\begin{chunk}{FLOAT.dotabb} +"FLOAT" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FLOAT"] "ALIST" [color="#88FF44",href="bookvol10.3.pdf#nameddest=ALIST"] -"FEXPR" -> "ALIST" +"FLOAT" -> "ALIST" \end{chunk} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain FORTRAN FortranProgram} +\section{domain FC FortranCode} -\begin{chunk}{FortranProgram.input} +\begin{chunk}{FortranCode.input} )set break resume -)sys rm -f FortranProgram.output -)spool FortranProgram.output +)sys rm -f FortranCode.output +)spool FortranCode.output )set message test on )set message auto off )clear all --S 1 of 1 -)show FortranProgram +)show FortranCode --R ---R FortranProgram(name: Symbol,returnType: Union(fst: FortranScalarType,void: void),arguments: List(Symbol),symbols: SymbolTable) is a domain constructor ---R Abbreviation for FortranProgram is FORTRAN +--R FortranCode is a domain constructor +--R Abbreviation for FortranCode is FC --R This constructor is exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for FORTRAN +--R Issue )edit bookvol10.3.pamphlet to see algebra source code for FC --R --R------------------------------- Operations -------------------------------- ---R coerce : Expression(Float) -> % coerce : Expression(Integer) -> % ---R coerce : List(FortranCode) -> % coerce : FortranCode -> % ---R coerce : % -> OutputForm outputAsFortran : % -> Void ---R coerce : Equation(Expression(Complex(Float))) -> % ---R coerce : Equation(Expression(Float)) -> % ---R coerce : Equation(Expression(Integer)) -> % ---R coerce : Expression(Complex(Float)) -> % ---R coerce : Equation(Expression(MachineComplex)) -> % ---R coerce : Equation(Expression(MachineFloat)) -> % ---R coerce : Equation(Expression(MachineInteger)) -> % ---R coerce : Expression(MachineComplex) -> % ---R coerce : Expression(MachineFloat) -> % ---R coerce : Expression(MachineInteger) -> % ---R coerce : Record(localSymbols: SymbolTable,code: List(FortranCode)) -> % +--R ?=? : (%,%) -> Boolean assign : (Symbol,String) -> % +--R block : List(%) -> % call : String -> % +--R coerce : % -> OutputForm comment : List(String) -> % +--R comment : String -> % common : (Symbol,List(Symbol)) -> % +--R cond : (Switch,%,%) -> % cond : (Switch,%) -> % +--R continue : SingleInteger -> % getCode : % -> SExpression +--R goto : SingleInteger -> % hash : % -> SingleInteger +--R latex : % -> String printCode : % -> Void +--R repeatUntilLoop : (Switch,%) -> % returns : Expression(Integer) -> % +--R returns : Expression(Float) -> % returns : () -> % +--R save : () -> % stop : () -> % +--R whileLoop : (Switch,%) -> % ?~=? : (%,%) -> Boolean +--R assign : (Symbol,List(Polynomial(Integer)),Expression(Complex(Float))) -> % +--R assign : (Symbol,List(Polynomial(Integer)),Expression(Float)) -> % +--R assign : (Symbol,List(Polynomial(Integer)),Expression(Integer)) -> % +--R assign : (Symbol,Vector(Expression(Complex(Float)))) -> % +--R assign : (Symbol,Vector(Expression(Float))) -> % +--R assign : (Symbol,Vector(Expression(Integer))) -> % +--R assign : (Symbol,Matrix(Expression(Complex(Float)))) -> % +--R assign : (Symbol,Matrix(Expression(Float))) -> % +--R assign : (Symbol,Matrix(Expression(Integer))) -> % +--R assign : (Symbol,Expression(Complex(Float))) -> % +--R assign : (Symbol,Expression(Float)) -> % +--R assign : (Symbol,Expression(Integer)) -> % +--R assign : (Symbol,List(Polynomial(Integer)),Expression(MachineComplex)) -> % +--R assign : (Symbol,List(Polynomial(Integer)),Expression(MachineFloat)) -> % +--R assign : (Symbol,List(Polynomial(Integer)),Expression(MachineInteger)) -> % +--R assign : (Symbol,Vector(Expression(MachineComplex))) -> % +--R assign : (Symbol,Vector(Expression(MachineFloat))) -> % +--R assign : (Symbol,Vector(Expression(MachineInteger))) -> % +--R assign : (Symbol,Matrix(Expression(MachineComplex))) -> % +--R assign : (Symbol,Matrix(Expression(MachineFloat))) -> % +--R assign : (Symbol,Matrix(Expression(MachineInteger))) -> % +--R assign : (Symbol,Vector(MachineComplex)) -> % +--R assign : (Symbol,Vector(MachineFloat)) -> % +--R assign : (Symbol,Vector(MachineInteger)) -> % +--R assign : (Symbol,Matrix(MachineComplex)) -> % +--R assign : (Symbol,Matrix(MachineFloat)) -> % +--R assign : (Symbol,Matrix(MachineInteger)) -> % +--R assign : (Symbol,Expression(MachineComplex)) -> % +--R assign : (Symbol,Expression(MachineFloat)) -> % +--R assign : (Symbol,Expression(MachineInteger)) -> % +--R code : % -> Union(nullBranch: null,assignmentBranch: Record(var: Symbol,arrayIndex: List(Polynomial(Integer)),rand: Record(ints2Floats?: Boolean,expr: OutputForm)),arrayAssignmentBranch: Record(var: Symbol,rand: OutputForm,ints2Floats?: Boolean),conditionalBranch: Record(switch: Switch,thenClause: %,elseClause: %),returnBranch: Record(empty?: Boolean,value: Record(ints2Floats?: Boolean,expr: OutputForm)),blockBranch: List(%),commentBranch: List(String),callBranch: String,forBranch: Record(range: SegmentBinding(Polynomial(Integer)),span: Polynomial(Integer),body: %),labelBranch: SingleInteger,loopBranch: Record(switch: Switch,body: %),commonBranch: Record(name: Symbol,contents: List(Symbol)),printBranch: List(OutputForm)) +--R forLoop : (SegmentBinding(Polynomial(Integer)),Polynomial(Integer),%) -> % +--R forLoop : (SegmentBinding(Polynomial(Integer)),%) -> % +--R operation : % -> Union(Null: null,Assignment: assignment,Conditional: conditional,Return: return,Block: block,Comment: comment,Call: call,For: for,While: while,Repeat: repeat,Goto: goto,Continue: continue,ArrayAssignment: arrayAssignment,Save: save,Stop: stop,Common: common,Print: print) +--R printStatement : List(OutputForm) -> % +--R returns : Expression(Complex(Float)) -> % +--R returns : Expression(MachineComplex) -> % +--R returns : Expression(MachineInteger) -> % +--R returns : Expression(MachineFloat) -> % +--R setLabelValue : SingleInteger -> SingleInteger --R --E 1 )spool )lisp (bye) \end{chunk} -\begin{chunk}{FortranProgram.help} +\begin{chunk}{FortranCode.help} ==================================================================== -FortranProgram examples +FortranCode examples ==================================================================== -FortranProgram allows the user to build and manipulate simple models of -FORTRAN subprograms. These can then be transformed into actual FORTRAN -notation. +This domain builds representations of program code segments for use with +the FortranProgram domain. See Also: -o )show FortranProgram +o )show FortranCode \end{chunk} -\pagehead{FortranProgram}{FORTRAN} -\pagepic{ps/v103fortranprogram.ps}{FORTRAN}{1.00} +\pagehead{FortranCode}{FC} +\pagepic{ps/v103fortrancode.ps}{FC}{1.00} {\bf See}\\ \pageto{Result}{RESULT} -\pageto{FortranCode}{FC} +\pageto{FortranProgram}{FORTRAN} \pageto{ThreeDimensionalMatrix}{M3D} \pageto{SimpleFortranProgram}{SFORT} \pageto{Switch}{SWITCH} @@ -61865,1001 +69574,1098 @@ o )show FortranProgram \pageto{FortranExpression}{FEXPR} {\bf Exports:}\\ -\begin{tabular}{ll} -\cross{FORTRAN}{coerce} & -\cross{FORTRAN}{outputAsFortran} +\begin{tabular}{lllll} +\cross{FC}{assign} & +\cross{FC}{block} & +\cross{FC}{call} & +\cross{FC}{code} & +\cross{FC}{coerce} \\ +\cross{FC}{comment} & +\cross{FC}{common} & +\cross{FC}{cond} & +\cross{FC}{continue} & +\cross{FC}{forLoop} \\ +\cross{FC}{getCode} & +\cross{FC}{goto} & +\cross{FC}{hash} & +\cross{FC}{latex} & +\cross{FC}{operation} \\ +\cross{FC}{printCode} & +\cross{FC}{printStatement} & +\cross{FC}{repeatUntilLoop} & +\cross{FC}{returns} & +\cross{FC}{save} \\ +\cross{FC}{setLabelValue} & +\cross{FC}{stop} & +\cross{FC}{whileLoop} & +\cross{FC}{?=?} & +\cross{FC}{?~=?} \end{tabular} -\begin{chunk}{domain FORTRAN FortranProgram} -)abbrev domain FORTRAN FortranProgram +\begin{chunk}{domain FC FortranCode} +)abbrev domain FC FortranCode ++ Author: Mike Dewar -++ Date Created: October 1992 -++ Date Last Updated: 23 January 1995 Added support for intrinsic functions +++ Date Created: April 1991 +++ Date Last Updated: 9 January 1995 Added fortran2Lines to getCall, MCD ++ Description: -++ \axiomType{FortranProgram} allows the user to build and manipulate simple -++ models of FORTRAN subprograms. These can then be transformed into -++ actual FORTRAN notation. +++ This domain builds representations of program code segments for use with +++ the FortranProgram domain. -FortranProgram(name,returnType,arguments,symbols): Exports == Implement where - name : Symbol - returnType : Union(fst:FortranScalarType,void:"void") - arguments : List Symbol - symbols : SymbolTable +FortranCode(): public == private where + L ==> List + PI ==> PositiveInteger + PIN ==> Polynomial Integer + SEX ==> SExpression + O ==> OutputForm + OP ==> Union(Null:"null", + Assignment:"assignment", + Conditional:"conditional", + Return:"return", + Block:"block", + Comment:"comment", + Call:"call", + For:"for", + While:"while", + Repeat:"repeat", + Goto:"goto", + Continue:"continue", + ArrayAssignment:"arrayAssignment", + Save:"save", + Stop:"stop", + Common:"common", + Print:"print") + ARRAYASS ==> Record(var:Symbol, rand:O, ints2Floats?:Boolean) + EXPRESSION ==> Record(ints2Floats?:Boolean,expr:O) + ASS ==> Record(var:Symbol, + arrayIndex:L PIN, + rand:EXPRESSION + ) + COND ==> Record(switch: Switch(), + thenClause: $, + elseClause: $ + ) + RETURN ==> Record(empty?:Boolean,value:EXPRESSION) + BLOCK ==> List $ + COMMENT ==> List String + COMMON ==> Record(name:Symbol,contents:List Symbol) + CALL ==> String + FOR ==> Record(range:SegmentBinding PIN, span:PIN, body:$) + LABEL ==> SingleInteger + LOOP ==> Record(switch:Switch(),body:$) + PRINTLIST ==> List O + OPREC ==> Union(nullBranch:"null", assignmentBranch:ASS, + arrayAssignmentBranch:ARRAYASS, + conditionalBranch:COND, returnBranch:RETURN, + blockBranch:BLOCK, commentBranch:COMMENT, callBranch:CALL, + forBranch:FOR, labelBranch:LABEL, loopBranch:LOOP, + commonBranch:COMMON, printBranch:PRINTLIST) - FC ==> FortranCode - EXPR ==> Expression - INT ==> Integer - CMPX ==> Complex - MINT ==> MachineInteger - MFLOAT ==> MachineFloat - MCMPLX ==> MachineComplex - REP ==> Record(localSymbols : SymbolTable, code : List FortranCode) + public == SetCategory with + coerce: $ -> O + ++ coerce(f) returns an object of type OutputForm. + forLoop: (SegmentBinding PIN,$) -> $ + ++ forLoop(i=1..10,c) creates a representation of a FORTRAN DO loop with + ++ \spad{i} ranging over the values 1 to 10. + forLoop: (SegmentBinding PIN,PIN,$) -> $ + ++ forLoop(i=1..10,n,c) creates a representation of a FORTRAN DO loop with + ++ \spad{i} ranging over the values 1 to 10 by n. + whileLoop: (Switch,$) -> $ + ++ whileLoop(s,c) creates a while loop in FORTRAN. + repeatUntilLoop: (Switch,$) -> $ + ++ repeatUntilLoop(s,c) creates a repeat ... until loop in FORTRAN. + goto: SingleInteger -> $ + ++ goto(l) creates a representation of a FORTRAN GOTO statement + continue: SingleInteger -> $ + ++ continue(l) creates a representation of a FORTRAN CONTINUE labelled + ++ with l + comment: String -> $ + ++ comment(s) creates a representation of the String s as a single FORTRAN + ++ comment. + comment: List String -> $ + ++ comment(s) creates a representation of the Strings s as a multi-line + ++ FORTRAN comment. + call: String -> $ + ++ call(s) creates a representation of a FORTRAN CALL statement + returns: () -> $ + ++ returns() creates a representation of a FORTRAN RETURN statement. + returns: Expression MachineFloat -> $ + ++ returns(e) creates a representation of a FORTRAN RETURN statement + ++ with a returned value. + returns: Expression MachineInteger -> $ + ++ returns(e) creates a representation of a FORTRAN RETURN statement + ++ with a returned value. + returns: Expression MachineComplex -> $ + ++ returns(e) creates a representation of a FORTRAN RETURN statement + ++ with a returned value. + returns: Expression Float -> $ + ++ returns(e) creates a representation of a FORTRAN RETURN statement + ++ with a returned value. + returns: Expression Integer -> $ + ++ returns(e) creates a representation of a FORTRAN RETURN statement + ++ with a returned value. + returns: Expression Complex Float -> $ + ++ returns(e) creates a representation of a FORTRAN RETURN statement + ++ with a returned value. + cond: (Switch,$) -> $ + ++ cond(s,e) creates a representation of the FORTRAN expression + ++ IF (s) THEN e. + cond: (Switch,$,$) -> $ + ++ cond(s,e,f) creates a representation of the FORTRAN expression + ++ IF (s) THEN e ELSE f. + assign: (Symbol,String) -> $ + ++ assign(x,y) creates a representation of the FORTRAN expression + ++ x=y. + assign: (Symbol,Expression MachineInteger) -> $ + ++ assign(x,y) creates a representation of the FORTRAN expression + ++ x=y. + assign: (Symbol,Expression MachineFloat) -> $ + ++ assign(x,y) creates a representation of the FORTRAN expression + ++ x=y. + assign: (Symbol,Expression MachineComplex) -> $ + ++ assign(x,y) creates a representation of the FORTRAN expression + ++ x=y. + assign: (Symbol,Matrix MachineInteger) -> $ + ++ assign(x,y) creates a representation of the FORTRAN expression + ++ x=y. + assign: (Symbol,Matrix MachineFloat) -> $ + ++ assign(x,y) creates a representation of the FORTRAN expression + ++ x=y. + assign: (Symbol,Matrix MachineComplex) -> $ + ++ assign(x,y) creates a representation of the FORTRAN expression + ++ x=y. + assign: (Symbol,Vector MachineInteger) -> $ + ++ assign(x,y) creates a representation of the FORTRAN expression + ++ x=y. + assign: (Symbol,Vector MachineFloat) -> $ + ++ assign(x,y) creates a representation of the FORTRAN expression + ++ x=y. + assign: (Symbol,Vector MachineComplex) -> $ + ++ assign(x,y) creates a representation of the FORTRAN expression + ++ x=y. + assign: (Symbol,Matrix Expression MachineInteger) -> $ + ++ assign(x,y) creates a representation of the FORTRAN expression + ++ x=y. + assign: (Symbol,Matrix Expression MachineFloat) -> $ + ++ assign(x,y) creates a representation of the FORTRAN expression + ++ x=y. + assign: (Symbol,Matrix Expression MachineComplex) -> $ + ++ assign(x,y) creates a representation of the FORTRAN expression + ++ x=y. + assign: (Symbol,Vector Expression MachineInteger) -> $ + ++ assign(x,y) creates a representation of the FORTRAN expression + ++ x=y. + assign: (Symbol,Vector Expression MachineFloat) -> $ + ++ assign(x,y) creates a representation of the FORTRAN expression + ++ x=y. + assign: (Symbol,Vector Expression MachineComplex) -> $ + ++ assign(x,y) creates a representation of the FORTRAN expression + ++ x=y. + assign: (Symbol,L PIN,Expression MachineInteger) -> $ + ++ assign(x,l,y) creates a representation of the assignment of \spad{y} + ++ to the \spad{l}'th element of array \spad{x} (\spad{l} is a list of + ++ indices). + assign: (Symbol,L PIN,Expression MachineFloat) -> $ + ++ assign(x,l,y) creates a representation of the assignment of \spad{y} + ++ to the \spad{l}'th element of array \spad{x} (\spad{l} is a list of + ++ indices). + assign: (Symbol,L PIN,Expression MachineComplex) -> $ + ++ assign(x,l,y) creates a representation of the assignment of \spad{y} + ++ to the \spad{l}'th element of array \spad{x} (\spad{l} is a list of + ++ indices). + assign: (Symbol,Expression Integer) -> $ + ++ assign(x,y) creates a representation of the FORTRAN expression + ++ x=y. + assign: (Symbol,Expression Float) -> $ + ++ assign(x,y) creates a representation of the FORTRAN expression + ++ x=y. + assign: (Symbol,Expression Complex Float) -> $ + ++ assign(x,y) creates a representation of the FORTRAN expression + ++ x=y. + assign: (Symbol,Matrix Expression Integer) -> $ + ++ assign(x,y) creates a representation of the FORTRAN expression + ++ x=y. + assign: (Symbol,Matrix Expression Float) -> $ + ++ assign(x,y) creates a representation of the FORTRAN expression + ++ x=y. + assign: (Symbol,Matrix Expression Complex Float) -> $ + ++ assign(x,y) creates a representation of the FORTRAN expression + ++ x=y. + assign: (Symbol,Vector Expression Integer) -> $ + ++ assign(x,y) creates a representation of the FORTRAN expression + ++ x=y. + assign: (Symbol,Vector Expression Float) -> $ + ++ assign(x,y) creates a representation of the FORTRAN expression + ++ x=y. + assign: (Symbol,Vector Expression Complex Float) -> $ + ++ assign(x,y) creates a representation of the FORTRAN expression + ++ x=y. + assign: (Symbol,L PIN,Expression Integer) -> $ + ++ assign(x,l,y) creates a representation of the assignment of \spad{y} + ++ to the \spad{l}'th element of array \spad{x} (\spad{l} is a list of + ++ indices). + assign: (Symbol,L PIN,Expression Float) -> $ + ++ assign(x,l,y) creates a representation of the assignment of \spad{y} + ++ to the \spad{l}'th element of array \spad{x} (\spad{l} is a list of + ++ indices). + assign: (Symbol,L PIN,Expression Complex Float) -> $ + ++ assign(x,l,y) creates a representation of the assignment of \spad{y} + ++ to the \spad{l}'th element of array \spad{x} (\spad{l} is a list of + ++ indices). + block: List($) -> $ + ++ block(l) creates a representation of the statements in l as a block. + stop: () -> $ + ++ stop() creates a representation of a STOP statement. + save: () -> $ + ++ save() creates a representation of a SAVE statement. + printStatement: List O -> $ + ++ printStatement(l) creates a representation of a PRINT statement. + common: (Symbol,List Symbol) -> $ + ++ common(name,contents) creates a representation a named common block. + operation: $ -> OP + ++ operation(f) returns the name of the operation represented by \spad{f}. + code: $ -> OPREC + ++ code(f) returns the internal representation of the object represented + ++ by \spad{f}. + printCode: $ -> Void + ++ printCode(f) prints out \spad{f} in FORTRAN notation. + getCode: $ -> SEX + ++ getCode(f) returns a Lisp list of strings representing \spad{f} + ++ in Fortran notation. This is used by the FortranProgram domain. + setLabelValue:SingleInteger -> SingleInteger + ++ setLabelValue(i) resets the counter which produces labels to i - Exports ==> FortranProgramCategory with - coerce : FortranCode -> $ - ++ coerce(fc) is not documented - coerce : List FortranCode -> $ - ++ coerce(lfc) is not documented - coerce : REP -> $ - ++ coerce(r) is not documented - coerce : EXPR MINT -> $ - ++ coerce(e) is not documented - coerce : EXPR MFLOAT -> $ - ++ coerce(e) is not documented - coerce : EXPR MCMPLX -> $ - ++ coerce(e) is not documented - coerce : Equation EXPR MINT -> $ - ++ coerce(eq) is not documented - coerce : Equation EXPR MFLOAT -> $ - ++ coerce(eq) is not documented - coerce : Equation EXPR MCMPLX -> $ - ++ coerce(eq) is not documented - coerce : EXPR INT -> $ - ++ coerce(e) is not documented - coerce : EXPR Float -> $ - ++ coerce(e) is not documented - coerce : EXPR CMPX Float -> $ - ++ coerce(e) is not documented - coerce : Equation EXPR INT -> $ - ++ coerce(eq) is not documented - coerce : Equation EXPR Float -> $ - ++ coerce(eq) is not documented - coerce : Equation EXPR CMPX Float -> $ - ++ coerce(eq) is not documented + private == add + import Void + import ASS + import COND + import RETURN + import L PIN + import O + import SEX + import FortranType + import TheSymbolTable - Implement ==> add + Rep := Record(op: OP, data: OPREC) - Rep := REP + -- We need to be able to generate unique labels + labelValue:SingleInteger := 25000::SingleInteger - import SExpression - import TheSymbolTable - import FortranCode + setLabelValue(u:SingleInteger):SingleInteger == labelValue := u - makeRep(b:List FortranCode):$ == - construct(empty()$SymbolTable,b)$REP + newLabel():SingleInteger == + labelValue := labelValue + 1$SingleInteger + labelValue - codeFrom(u:$):List FortranCode == - elt(u::Rep,code)$REP + commaSep(l:List String):List(String) == + [(l.1),:[:[",",u] for u in rest(l)]] - outputAsFortran(p:$):Void == - setLabelValue(25000::SingleInteger)$FC - -- Do this first to catch any extra type declarations: - tempName := "FPTEMP"::Symbol - newSubProgram(tempName) - initialiseIntrinsicList()$Lisp - body : List SExpression := [getCode(l)$FortranCode for l in codeFrom(p)] - intrinsics : SExpression := getIntrinsicList()$Lisp - endSubProgram() - fortFormatHead(returnType::OutputForm, name::OutputForm, _ - arguments::OutputForm)$Lisp - printTypes(symbols)$SymbolTable - printTypes((p::Rep).localSymbols)$SymbolTable - printTypes(tempName)$TheSymbolTable - fortFormatIntrinsics(intrinsics)$Lisp - clearTheSymbolTable(tempName) - for expr in body repeat displayLines1(expr)$Lisp - dispStatement(END::OutputForm)$Lisp - void()$Void + getReturn(rec:RETURN):SEX == + returnToken : SEX := convert("RETURN"::Symbol::O)$SEX + elt(rec,empty?)$RETURN => + getStatement(returnToken,NIL$Lisp)$Lisp + rt : EXPRESSION := elt(rec,value)$RETURN + rv : O := elt(rt,expr)$EXPRESSION + getStatement([returnToken,convert(rv)$SEX]$Lisp, + elt(rt,ints2Floats?)$EXPRESSION )$Lisp - mkString(l:List Symbol):String == - unparse(convert(l::OutputForm)@InputForm)$InputForm + getStop():SEX == + fortran2Lines(LIST("STOP")$Lisp)$Lisp - checkVariables(user:List Symbol,target:List Symbol):Void == - -- We don't worry about whether the user has subscripted the - -- variables or not. - setDifference(map(name$Symbol,user),target) ^= empty()$List(Symbol) => - s1 : String := mkString(user) - s2 : String := mkString(target) - error ["Incompatible variable lists:", s1, s2] - void()$Void + getSave():SEX == + fortran2Lines(LIST("SAVE")$Lisp)$Lisp - coerce(u:EXPR MINT) : $ == - checkVariables(variables(u)$EXPR(MINT),arguments) - l : List(FC) := [assign(name,u)$FC,returns()$FC] - makeRep l + getCommon(u:COMMON):SEX == + fortran2Lines(APPEND(LIST("COMMON"," /",string (u.name),"/ ")$Lisp,_ + addCommas(u.contents)$Lisp)$Lisp)$Lisp + + getPrint(l:PRINTLIST):SEX == + ll : SEX := LIST("PRINT*")$Lisp + for i in l repeat + ll := APPEND(ll,CONS(",",expression2Fortran(i)$Lisp)$Lisp)$Lisp + fortran2Lines(ll)$Lisp - coerce(u:Equation EXPR MINT) : $ == - retractIfCan(lhs u)@Union(Kernel(EXPR MINT),"failed") case "failed" => - error "left hand side is not a kernel" - vList : List Symbol := variables lhs u - #vList ^= #arguments => - error "Incorrect number of arguments" - veList : List EXPR MINT := [w::EXPR(MINT) for w in vList] - aeList : List EXPR MINT := [w::EXPR(MINT) for w in arguments] - eList : List Equation EXPR MINT := - [equation(w,v) for w in veList for v in aeList] - (subst(rhs u,eList))::$ + getBlock(rec:BLOCK):SEX == + indentFortLevel(convert(1@Integer)$SEX)$Lisp + expr : SEX := LIST()$Lisp + for u in rec repeat + expr := APPEND(expr,getCode(u))$Lisp + indentFortLevel(convert(-1@Integer)$SEX)$Lisp + expr - coerce(u:EXPR MFLOAT) : $ == - checkVariables(variables(u)$EXPR(MFLOAT),arguments) - l : List(FC) := [assign(name,u)$FC,returns()$FC] - makeRep l + getBody(f:$):SEX == + operation(f) case Block => getCode f + indentFortLevel(convert(1@Integer)$SEX)$Lisp + expr := getCode f + indentFortLevel(convert(-1@Integer)$SEX)$Lisp + expr - coerce(u:Equation EXPR MFLOAT) : $ == - retractIfCan(lhs u)@Union(Kernel(EXPR MFLOAT),"failed") case "failed" => - error "left hand side is not a kernel" - vList : List Symbol := variables lhs u - #vList ^= #arguments => - error "Incorrect number of arguments" - veList : List EXPR MFLOAT := [w::EXPR(MFLOAT) for w in vList] - aeList : List EXPR MFLOAT := [w::EXPR(MFLOAT) for w in arguments] - eList : List Equation EXPR MFLOAT := - [equation(w,v) for w in veList for v in aeList] - (subst(rhs u,eList))::$ + getElseIf(f:$):SEX == + rec := code f + expr := + fortFormatElseIf(elt(rec.conditionalBranch,switch)$COND::O)$Lisp + expr := + APPEND(expr,getBody elt(rec.conditionalBranch,thenClause)$COND)$Lisp + elseBranch := elt(rec.conditionalBranch,elseClause)$COND + not(operation(elseBranch) case Null) => + operation(elseBranch) case Conditional => + APPEND(expr,getElseIf elseBranch)$Lisp + expr := APPEND(expr, getStatement(ELSE::O,NIL$Lisp)$Lisp)$Lisp + expr := APPEND(expr, getBody elseBranch)$Lisp + expr - coerce(u:EXPR MCMPLX) : $ == - checkVariables(variables(u)$EXPR(MCMPLX),arguments) - l : List(FC) := [assign(name,u)$FC,returns()$FC] - makeRep l + getContinue(label:SingleInteger):SEX == + lab : O := label::O + if (width(lab) > 6) then error "Label too big" + cnt : O := "CONTINUE"::O + --sp : O := hspace(6-width lab) + sp : O := hspace(_$fortIndent$Lisp -width lab) + LIST(STRCONC(PRINC_-TO_-STRING(lab)$Lisp,sp,cnt)$Lisp)$Lisp - coerce(u:Equation EXPR MCMPLX) : $ == - retractIfCan(lhs u)@Union(Kernel EXPR MCMPLX,"failed") case "failed"=> - error "left hand side is not a kernel" - vList : List Symbol := variables lhs u - #vList ^= #arguments => - error "Incorrect number of arguments" - veList : List EXPR MCMPLX := [w::EXPR(MCMPLX) for w in vList] - aeList : List EXPR MCMPLX := [w::EXPR(MCMPLX) for w in arguments] - eList : List Equation EXPR MCMPLX := - [equation(w,v) for w in veList for v in aeList] - (subst(rhs u,eList))::$ + getGoto(label:SingleInteger):SEX == + fortran2Lines( + LIST(STRCONC("GOTO ",PRINC_-TO_-STRING(label::O)$Lisp)$Lisp)$Lisp)$Lisp + getRepeat(repRec:LOOP):SEX == + sw : Switch := NOT elt(repRec,switch)$LOOP + lab := newLabel() + bod := elt(repRec,body)$LOOP + APPEND(getContinue lab,getBody bod, + fortFormatIfGoto(sw::O,lab)$Lisp)$Lisp - coerce(u:REP):$ == - u@Rep + getWhile(whileRec:LOOP):SEX == + sw := NOT elt(whileRec,switch)$LOOP + lab1 := newLabel() + lab2 := newLabel() + bod := elt(whileRec,body)$LOOP + APPEND(fortFormatLabelledIfGoto(sw::O,lab1,lab2)$Lisp, + getBody bod, getBody goto(lab1), getContinue lab2)$Lisp - coerce(u:$):OutputForm == - coerce(name)$Symbol + getArrayAssign(rec:ARRAYASS):SEX == + getfortarrayexp((rec.var)::O,rec.rand,rec.ints2Floats?)$Lisp - coerce(c:List FortranCode):$ == - makeRep c + getAssign(rec:ASS):SEX == + indices : L PIN := elt(rec,arrayIndex)$ASS + if indices = []::(L PIN) then + lhs := elt(rec,var)$ASS::O + else + lhs := cons(elt(rec,var)$ASS::PIN,indices)::O + -- Must get the index brackets correct: + lhs := (cdr car cdr convert(lhs)$SEX::SEX)::O -- Yuck! + elt(elt(rec,rand)$ASS,ints2Floats?)$EXPRESSION => + assignment2Fortran1(lhs,elt(elt(rec,rand)$ASS,expr)$EXPRESSION)$Lisp + integerAssignment2Fortran1(lhs,_ + elt(elt(rec,rand)$ASS,expr)$EXPRESSION)$Lisp - coerce(c:FortranCode):$ == - makeRep [c] + getCond(rec:COND):SEX == + expr := APPEND(fortFormatIf(elt(rec,switch)$COND::O)$Lisp, + getBody elt(rec,thenClause)$COND)$Lisp + elseBranch := elt(rec,elseClause)$COND + if not(operation(elseBranch) case Null) then + operation(elseBranch) case Conditional => + expr := APPEND(expr,getElseIf elseBranch)$Lisp + expr := APPEND(expr,getStatement(ELSE::O,NIL$Lisp)$Lisp, + getBody elseBranch)$Lisp + APPEND(expr,getStatement(ENDIF::O,NIL$Lisp)$Lisp)$Lisp - coerce(u:EXPR INT) : $ == - checkVariables(variables(u)$EXPR(INT),arguments) - l : List(FC) := [assign(name,u)$FC,returns()$FC] - makeRep l + getComment(rec:COMMENT):SEX == + convert([convert(concat("C ",c)$String)@SEX for c in rec])@SEX - coerce(u:Equation EXPR INT) : $ == - retractIfCan(lhs u)@Union(Kernel(EXPR INT),"failed") case "failed" => - error "left hand side is not a kernel" - vList : List Symbol := variables lhs u - #vList ^= #arguments => - error "Incorrect number of arguments" - veList : List EXPR INT := [w::EXPR(INT) for w in vList] - aeList : List EXPR INT := [w::EXPR(INT) for w in arguments] - eList : List Equation EXPR INT := - [equation(w,v) for w in veList for v in aeList] - (subst(rhs u,eList))::$ + getCall(rec:CALL):SEX == + expr := concat("CALL ",rec)$String + #expr > 1320 => error "Fortran CALL too large" + fortran2Lines(convert([convert(expr)@SEX ])@SEX)$Lisp - coerce(u:EXPR Float) : $ == - checkVariables(variables(u)$EXPR(Float),arguments) - l : List(FC) := [assign(name,u)$FC,returns()$FC] - makeRep l + getFor(rec:FOR):SEX == + rnge : SegmentBinding PIN := elt(rec,range)$FOR + increment : PIN := elt(rec,span)$FOR + lab : SingleInteger := newLabel() + declare!(variable rnge,fortranInteger()) + expr := fortFormatDo(variable rnge, (lo segment rnge)::O,_ + (hi segment rnge)::O,increment::O,lab)$Lisp + APPEND(expr, getBody elt(rec,body)$FOR, getContinue(lab))$Lisp + + getCode(f:$):SEX == + opp:OP := operation f + rec:OPREC:= code f + opp case Assignment => getAssign(rec.assignmentBranch) + opp case ArrayAssignment => getArrayAssign(rec.arrayAssignmentBranch) + opp case Conditional => getCond(rec.conditionalBranch) + opp case Return => getReturn(rec.returnBranch) + opp case Block => getBlock(rec.blockBranch) + opp case Comment => getComment(rec.commentBranch) + opp case Call => getCall(rec.callBranch) + opp case For => getFor(rec.forBranch) + opp case Continue => getContinue(rec.labelBranch) + opp case Goto => getGoto(rec.labelBranch) + opp case Repeat => getRepeat(rec.loopBranch) + opp case While => getWhile(rec.loopBranch) + opp case Save => getSave() + opp case Stop => getStop() + opp case Print => getPrint(rec.printBranch) + opp case Common => getCommon(rec.commonBranch) + error "Unsupported program construct." + convert(0)@SEX - coerce(u:Equation EXPR Float) : $ == - retractIfCan(lhs u)@Union(Kernel(EXPR Float),"failed") case "failed" => - error "left hand side is not a kernel" - vList : List Symbol := variables lhs u - #vList ^= #arguments => - error "Incorrect number of arguments" - veList : List EXPR Float := [w::EXPR(Float) for w in vList] - aeList : List EXPR Float := [w::EXPR(Float) for w in arguments] - eList : List Equation EXPR Float := - [equation(w,v) for w in veList for v in aeList] - (subst(rhs u,eList))::$ + printCode(f:$):Void == + displayLines1$Lisp getCode f + void()$Void - coerce(u:EXPR Complex Float) : $ == - checkVariables(variables(u)$EXPR(Complex Float),arguments) - l : List(FC) := [assign(name,u)$FC,returns()$FC] - makeRep l + code (f:$):OPREC == + elt(f,data)$Rep - coerce(u:Equation EXPR CMPX Float) : $ == - retractIfCan(lhs u)@Union(Kernel EXPR CMPX Float,"failed") case "failed"=> - error "left hand side is not a kernel" - vList : List Symbol := variables lhs u - #vList ^= #arguments => - error "Incorrect number of arguments" - veList : List EXPR CMPX Float := [w::EXPR(CMPX Float) for w in vList] - aeList : List EXPR CMPX Float := [w::EXPR(CMPX Float) for w in arguments] - eList : List Equation EXPR CMPX Float := - [equation(w,v) for w in veList for v in aeList] - (subst(rhs u,eList))::$ + operation (f:$):OP == + elt(f,op)$Rep -\end{chunk} + common(name:Symbol,contents:List Symbol):$ == + [["common"]$OP,[[name,contents]$COMMON]$OPREC]$Rep -\begin{chunk}{COQ FORTRAN} -(* domain FORTRAN *) -(* -*) + stop():$ == + [["stop"]$OP,["null"]$OPREC]$Rep -\end{chunk} + save():$ == + [["save"]$OP,["null"]$OPREC]$Rep -\begin{chunk}{FORTRAN.dotabb} -"FORTRAN" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FORTRAN"] -"COMPCAT" [color="#4488FF",href="bookvol10.2.pdf#nameddest=COMPCAT"] -"FORTRAN" -> "COMPCAT" + printStatement(l:List O):$ == + [["print"]$OP,[l]$OPREC]$Rep -\end{chunk} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain FST FortranScalarType} + comment(s:List String):$ == + [["comment"]$OP,[s]$OPREC]$Rep -\begin{chunk}{FortranScalarType.input} -)set break resume -)sys rm -f FortranScalarType.output -)spool FortranScalarType.output -)set message test on -)set message auto off -)clear all + comment(s:String):$ == + [["comment"]$OP,[list s]$OPREC]$Rep ---S 1 of 1 -)show FortranScalarType ---R ---R FortranScalarType is a domain constructor ---R Abbreviation for FortranScalarType is FST ---R This constructor is exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for FST ---R ---R------------------------------- Operations -------------------------------- ---R ?=? : (%,%) -> Boolean character? : % -> Boolean ---R coerce : % -> SExpression coerce : % -> Symbol ---R coerce : Symbol -> % coerce : String -> % ---R coerce : % -> OutputForm complex? : % -> Boolean ---R double? : % -> Boolean doubleComplex? : % -> Boolean ---R integer? : % -> Boolean logical? : % -> Boolean ---R real? : % -> Boolean ---R ---E 1 + forLoop(r:SegmentBinding PIN,body:$):$ == + [["for"]$OP,[[r,(incr segment r)::PIN,body]$FOR]$OPREC]$Rep -)spool -)lisp (bye) -\end{chunk} -\begin{chunk}{FortranScalarType.help} -==================================================================== -FortranScalarType examples -==================================================================== + forLoop(r:SegmentBinding PIN,increment:PIN,body:$):$ == + [["for"]$OP,[[r,increment,body]$FOR]$OPREC]$Rep -Creates and manipulates objects which correspond to the -basic FORTRAN data types: REAL, INTEGER, COMPLEX, LOGICAL and CHARACTER + goto(l:SingleInteger):$ == + [["goto"]$OP,[l]$OPREC]$Rep -See Also: -o )show FortranScalarType + continue(l:SingleInteger):$ == + [["continue"]$OP,[l]$OPREC]$Rep -\end{chunk} + whileLoop(sw:Switch,b:$):$ == + [["while"]$OP,[[sw,b]$LOOP]$OPREC]$Rep -\pagehead{FortranScalarType}{FST} -\pagepic{ps/v103fortranscalartype.ps}{FST}{1.00} -{\bf See}\\ -\pageto{FortranType}{FT} -\pageto{SymbolTable}{SYMTAB} -\pageto{TheSymbolTable}{SYMS} + repeatUntilLoop(sw:Switch,b:$):$ == + [["repeat"]$OP,[[sw,b]$LOOP]$OPREC]$Rep -{\bf Exports:}\\ -\begin{tabular}{lllllllll} -\cross{FST}{character?} & -\cross{FST}{coerce} & -\cross{FST}{complex?} & -\cross{FST}{double?} & -\cross{FST}{doubleComplex?} & -\cross{FST}{integer?} & -\cross{FST}{logical?} & -\cross{FST}{real?} & -\cross{FST}{?=?} -\end{tabular} + returns():$ == + v := [false,0::O]$EXPRESSION + [["return"]$OP,[[true,v]$RETURN]$OPREC]$Rep -\begin{chunk}{domain FST FortranScalarType} -)abbrev domain FST FortranScalarType -++ Author: Mike Dewar -++ Date Created: October 1992 -++ Description: -++ Creates and manipulates objects which correspond to the -++ basic FORTRAN data types: REAL, INTEGER, COMPLEX, LOGICAL and CHARACTER + returns(v:Expression MachineInteger):$ == + [["return"]$OP,[[false,[false,v::O]$EXPRESSION]$RETURN]$OPREC]$Rep -FortranScalarType() : exports == implementation where + returns(v:Expression MachineFloat):$ == + [["return"]$OP,[[false,[false,v::O]$EXPRESSION]$RETURN]$OPREC]$Rep - exports == CoercibleTo OutputForm with - coerce : String -> $ - ++ coerce(s) transforms the string s into an element of - ++ FortranScalarType provided s is one of "real", "double precision", - ++ "complex", "logical", "integer", "character", "REAL", - ++ "COMPLEX", "LOGICAL", "INTEGER", "CHARACTER", - ++ "DOUBLE PRECISION" - coerce : Symbol -> $ - ++ coerce(s) transforms the symbol s into an element of - ++ FortranScalarType provided s is one of real, complex,double precision, - ++ logical, integer, character, REAL, COMPLEX, LOGICAL, - ++ INTEGER, CHARACTER, DOUBLE PRECISION - coerce : $ -> Symbol - ++ coerce(x) returns the symbol associated with x - coerce : $ -> SExpression - ++ coerce(x) returns the s-expression associated with x - real? : $ -> Boolean - ++ real?(t) tests whether t is equivalent to the FORTRAN type REAL. - double? : $ -> Boolean - ++ double?(t) tests whether t is equivalent to the FORTRAN type - ++ DOUBLE PRECISION - integer? : $ -> Boolean - ++ integer?(t) tests whether t is equivalent to the FORTRAN type INTEGER. - complex? : $ -> Boolean - ++ complex?(t) tests whether t is equivalent to the FORTRAN type COMPLEX. - doubleComplex? : $ -> Boolean - ++ doubleComplex?(t) tests whether t is equivalent to the (non-standard) - ++ FORTRAN type DOUBLE COMPLEX. - character? : $ -> Boolean - ++ character?(t) tests whether t is equivalent to the FORTRAN type - ++ CHARACTER. - logical? : $ -> Boolean - ++ logical?(t) tests whether t is equivalent to the FORTRAN type LOGICAL. - "=" : ($,$) -> Boolean - ++ x=y tests for equality + returns(v:Expression MachineComplex):$ == + [["return"]$OP,[[false,[false,v::O]$EXPRESSION]$RETURN]$OPREC]$Rep - implementation == add + returns(v:Expression Integer):$ == + [["return"]$OP,[[false,[false,v::O]$EXPRESSION]$RETURN]$OPREC]$Rep - U == Union(RealThing:"real", - IntegerThing:"integer", - ComplexThing:"complex", - CharacterThing:"character", - LogicalThing:"logical", - DoublePrecisionThing:"double precision", - DoubleComplexThing:"double complex") - Rep := U + returns(v:Expression Float):$ == + [["return"]$OP,[[false,[false,v::O]$EXPRESSION]$RETURN]$OPREC]$Rep - doubleSymbol : Symbol := "double precision"::Symbol - upperDoubleSymbol : Symbol := "DOUBLE PRECISION"::Symbol - doubleComplexSymbol : Symbol := "double complex"::Symbol - upperDoubleComplexSymbol : Symbol := "DOUBLE COMPLEX"::Symbol + returns(v:Expression Complex Float):$ == + [["return"]$OP,[[false,[false,v::O]$EXPRESSION]$RETURN]$OPREC]$Rep - u = v == - u case RealThing and v case RealThing => true - u case IntegerThing and v case IntegerThing => true - u case ComplexThing and v case ComplexThing => true - u case LogicalThing and v case LogicalThing => true - u case CharacterThing and v case CharacterThing => true - u case DoublePrecisionThing and v case DoublePrecisionThing => true - u case DoubleComplexThing and v case DoubleComplexThing => true - false + block(l:List $):$ == + [["block"]$OP,[l]$OPREC]$Rep + + cond(sw:Switch,thenC:$):$ == + [["conditional"]$OP, + [[sw,thenC,[["null"]$OP,["null"]$OPREC]$Rep]$COND]$OPREC]$Rep - coerce(t:$):OutputForm == - t case RealThing => coerce(REAL)$Symbol - t case IntegerThing => coerce(INTEGER)$Symbol - t case ComplexThing => coerce(COMPLEX)$Symbol - t case CharacterThing => coerce(CHARACTER)$Symbol - t case DoublePrecisionThing => coerce(upperDoubleSymbol)$Symbol - t case DoubleComplexThing => coerce(upperDoubleComplexSymbol)$Symbol - coerce(LOGICAL)$Symbol + cond(sw:Switch,thenC:$,elseC:$):$ == + [["conditional"]$OP,[[sw,thenC,elseC]$COND]$OPREC]$Rep - coerce(t:$):SExpression == - t case RealThing => convert(real::Symbol)@SExpression - t case IntegerThing => convert(integer::Symbol)@SExpression - t case ComplexThing => convert(complex::Symbol)@SExpression - t case CharacterThing => convert(character::Symbol)@SExpression - t case DoublePrecisionThing => convert(doubleSymbol)@SExpression - t case DoubleComplexThing => convert(doubleComplexSymbol)@SExpression - convert(logical::Symbol)@SExpression + coerce(f : $):O == + (f.op)::O - coerce(t:$):Symbol == - t case RealThing => real::Symbol - t case IntegerThing => integer::Symbol - t case ComplexThing => complex::Symbol - t case CharacterThing => character::Symbol - t case DoublePrecisionThing => doubleSymbol - t case DoublePrecisionThing => doubleComplexSymbol - logical::Symbol + assign(v:Symbol,rhs:String):$ == + [["assignment"]$OP,_ + [[v,nil()::L PIN,[false,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep - coerce(s:Symbol):$ == - s = real => ["real"]$Rep - s = REAL => ["real"]$Rep - s = integer => ["integer"]$Rep - s = INTEGER => ["integer"]$Rep - s = complex => ["complex"]$Rep - s = COMPLEX => ["complex"]$Rep - s = character => ["character"]$Rep - s = CHARACTER => ["character"]$Rep - s = logical => ["logical"]$Rep - s = LOGICAL => ["logical"]$Rep - s = doubleSymbol => ["double precision"]$Rep - s = upperDoubleSymbol => ["double precision"]$Rep - s = doubleComplexSymbol => ["double complex"]$Rep - s = upperDoubleCOmplexSymbol => ["double complex"]$Rep + assign(v:Symbol,rhs:Matrix MachineInteger):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,false]$ARRAYASS]$OPREC]$Rep - coerce(s:String):$ == - s = "real" => ["real"]$Rep - s = "integer" => ["integer"]$Rep - s = "complex" => ["complex"]$Rep - s = "character" => ["character"]$Rep - s = "logical" => ["logical"]$Rep - s = "double precision" => ["double precision"]$Rep - s = "double complex" => ["double complex"]$Rep - s = "REAL" => ["real"]$Rep - s = "INTEGER" => ["integer"]$Rep - s = "COMPLEX" => ["complex"]$Rep - s = "CHARACTER" => ["character"]$Rep - s = "LOGICAL" => ["logical"]$Rep - s = "DOUBLE PRECISION" => ["double precision"]$Rep - s = "DOUBLE COMPLEX" => ["double complex"]$Rep - error concat([s," is invalid as a Fortran Type"])$String + assign(v:Symbol,rhs:Matrix MachineFloat):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep - real?(t:$):Boolean == t case RealThing + assign(v:Symbol,rhs:Matrix MachineComplex):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep - double?(t:$):Boolean == t case DoublePrecisionThing + assign(v:Symbol,rhs:Vector MachineInteger):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,false]$ARRAYASS]$OPREC]$Rep - logical?(t:$):Boolean == t case LogicalThing + assign(v:Symbol,rhs:Vector MachineFloat):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep - integer?(t:$):Boolean == t case IntegerThing + assign(v:Symbol,rhs:Vector MachineComplex):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep - character?(t:$):Boolean == t case CharacterThing + assign(v:Symbol,rhs:Matrix Expression MachineInteger):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,false]$ARRAYASS]$OPREC]$Rep - complex?(t:$):Boolean == t case ComplexThing + assign(v:Symbol,rhs:Matrix Expression MachineFloat):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep - doubleComplex?(t:$):Boolean == t case DoubleComplexThing + assign(v:Symbol,rhs:Matrix Expression MachineComplex):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep -\end{chunk} + assign(v:Symbol,rhs:Vector Expression MachineInteger):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,false]$ARRAYASS]$OPREC]$Rep -\begin{chunk}{COQ FST} -(* domain FST *) -(* -*) + assign(v:Symbol,rhs:Vector Expression MachineFloat):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep -\end{chunk} + assign(v:Symbol,rhs:Vector Expression MachineComplex):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep -\begin{chunk}{FST.dotabb} -"FST" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FST"] -"ALIST" [color="#88FF44",href="bookvol10.3.pdf#nameddest=ALIST"] -"FST" -> "ALIST" + assign(v:Symbol,index:L PIN,rhs:Expression MachineInteger):$ == + [["assignment"]$OP,[[v,index,[false,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep -\end{chunk} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain FTEM FortranTemplate} + assign(v:Symbol,index:L PIN,rhs:Expression MachineFloat):$ == + [["assignment"]$OP,[[v,index,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep -\begin{chunk}{FortranTemplate.input} -)set break resume -)sys rm -f FortranTemplate.output -)spool FortranTemplate.output -)set message test on -)set message auto off -)clear all + assign(v:Symbol,index:L PIN,rhs:Expression MachineComplex):$ == + [["assignment"]$OP,[[v,index,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep ---S 1 of 1 -)show FortranTemplate ---R ---R FortranTemplate is a domain constructor ---R Abbreviation for FortranTemplate is FTEM ---R This constructor is exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for FTEM ---R ---R------------------------------- Operations -------------------------------- ---R ?=? : (%,%) -> Boolean close! : % -> % ---R coerce : % -> OutputForm flush : % -> Void ---R fortranCarriageReturn : () -> Void fortranLiteral : String -> Void ---R fortranLiteralLine : String -> Void hash : % -> SingleInteger ---R iomode : % -> String latex : % -> String ---R name : % -> FileName open : (FileName,String) -> % ---R open : FileName -> % read! : % -> String ---R reopen! : (%,String) -> % write! : (%,String) -> String ---R ?~=? : (%,%) -> Boolean ---R processTemplate : FileName -> FileName ---R processTemplate : (FileName,FileName) -> FileName ---R ---E 1 + assign(v:Symbol,rhs:Expression MachineInteger):$ == + [["assignment"]$OP,_ + [[v,nil()::L PIN,[false,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep -)spool -)lisp (bye) -\end{chunk} -\begin{chunk}{FortranTemplate.help} -==================================================================== -FortranTemplate examples -==================================================================== + assign(v:Symbol,rhs:Expression MachineFloat):$ == + [["assignment"]$OP,_ + [[v,nil()::L PIN,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep -Code to manipulate Fortran templates + assign(v:Symbol,rhs:Expression MachineComplex):$ == + [["assignment"]$OP,_ + [[v,nil()::L PIN,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep -See Also: -o )show FortranTemplate + assign(v:Symbol,rhs:Matrix Expression Integer):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,false]$ARRAYASS]$OPREC]$Rep -\end{chunk} + assign(v:Symbol,rhs:Matrix Expression Float):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep -\pagehead{FortranTemplate}{FTEM} -\pagepic{ps/v103fortrantemplate.ps}{FTEM}{1.00} -{\bf See}\\ -\pageto{Result}{RESULT} -\pageto{FortranCode}{FC} -\pageto{FortranProgram}{FORTRAN} -\pageto{ThreeDimensionalMatrix}{M3D} -\pageto{SimpleFortranProgram}{SFORT} -\pageto{Switch}{SWITCH} -\pageto{FortranExpression}{FEXPR} + assign(v:Symbol,rhs:Matrix Expression Complex Float):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep -{\bf Exports:}\\ -\begin{tabular}{lllll} -\cross{FTEM}{close!} & -\cross{FTEM}{coerce} & -\cross{FTEM}{fortranCarriageReturn} & -\cross{FTEM}{fortranLiteral} & -\cross{FTEM}{fortranLiteralLine} \\ -\cross{FTEM}{hash} & -\cross{FTEM}{iomode} & -\cross{FTEM}{latex} & -\cross{FTEM}{name} & -\cross{FTEM}{open} \\ -\cross{FTEM}{processTemplate} & -\cross{FTEM}{read!} & -\cross{FTEM}{reopen!} & -\cross{FTEM}{write!} & -\cross{FTEM}{?=?} \\ -\cross{FTEM}{?\~{}=?} &&&& -\end{tabular} + assign(v:Symbol,rhs:Vector Expression Integer):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,false]$ARRAYASS]$OPREC]$Rep -\begin{chunk}{domain FTEM FortranTemplate} -)abbrev domain FTEM FortranTemplate -++ Author: Mike Dewar -++ Date Created: October 1992 -++ Description: -++ Code to manipulate Fortran templates + assign(v:Symbol,rhs:Vector Expression Float):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep -FortranTemplate() : specification == implementation where + assign(v:Symbol,rhs:Vector Expression Complex Float):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep - specification == FileCategory(FileName, String) with + assign(v:Symbol,index:L PIN,rhs:Expression Integer):$ == + [["assignment"]$OP,[[v,index,[false,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep - processTemplate : (FileName, FileName) -> FileName - ++ processTemplate(tp,fn) processes the template tp, writing the - ++ result out to fn. - processTemplate : (FileName) -> FileName - ++ processTemplate(tp) processes the template tp, writing the - ++ result to the current FORTRAN output stream. - fortranLiteralLine : String -> Void - ++ fortranLiteralLine(s) writes s to the current Fortran output stream, - ++ followed by a carriage return - fortranLiteral : String -> Void - ++ fortranLiteral(s) writes s to the current Fortran output stream - fortranCarriageReturn : () -> Void - ++ fortranCarriageReturn() produces a carriage return on the current - ++ Fortran output stream + assign(v:Symbol,index:L PIN,rhs:Expression Float):$ == + [["assignment"]$OP,[[v,index,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep - implementation == TextFile add + assign(v:Symbol,index:L PIN,rhs:Expression Complex Float):$ == + [["assignment"]$OP,[[v,index,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep - import TemplateUtilities - import FortranOutputStackPackage + assign(v:Symbol,rhs:Expression Integer):$ == + [["assignment"]$OP,_ + [[v,nil()::L PIN,[false,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep - Rep := TextFile + assign(v:Symbol,rhs:Expression Float):$ == + [["assignment"]$OP,_ + [[v,nil()::L PIN,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep - fortranLiteralLine(s:String):Void == - PRINC(s,_$fortranOutputStream$Lisp)$Lisp - TERPRI(_$fortranOutputStream$Lisp)$Lisp + assign(v:Symbol,rhs:Expression Complex Float):$ == + [["assignment"]$OP,_ + [[v,nil()::L PIN,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep - fortranLiteral(s:String):Void == - PRINC(s,_$fortranOutputStream$Lisp)$Lisp + call(s:String):$ == + [["call"]$OP,[s]$OPREC]$Rep - fortranCarriageReturn():Void == - TERPRI(_$fortranOutputStream$Lisp)$Lisp +\end{chunk} - writePassiveLine!(line:String):Void == - -- We might want to be a bit clever here and look for new SubPrograms etc. - fortranLiteralLine line +\begin{chunk}{COQ FC} +(* domain FC *) +(* + import Void + import ASS + import COND + import RETURN + import L PIN + import O + import SEX + import FortranType + import TheSymbolTable - processTemplate(tp:FileName, fn:FileName):FileName == - pushFortranOutputStack(fn) - processTemplate(tp) - popFortranOutputStack() - fn + Rep := Record(op: OP, data: OPREC) - getLine(fp:TextFile):String == - line : String := stripCommentsAndBlanks readLine!(fp) - while not empty?(line) and elt(line,maxIndex line) = char "__" repeat - setelt(line,maxIndex line,char " ") - line := concat(line, stripCommentsAndBlanks readLine!(fp))$String - line + -- We need to be able to generate unique labels + labelValue:SingleInteger := 25000::SingleInteger - processTemplate(tp:FileName):FileName == - fp : TextFile := open(tp,"input") - active : Boolean := true - line : String - endInput : Boolean := false - while not (endInput or endOfFile? fp) repeat - if active then - line := getLine fp - line = "endInput" => endInput := true - if line = "beginVerbatim" then - active := false - else - not empty? line => interpretString line - else - line := readLine!(fp) - if line = "endVerbatim" then - active := true - else - writePassiveLine! line - close!(fp) - if not active then - error concat(["Missing `endVerbatim' line in ",tp::String])$String - string(_$fortranOutputFile$Lisp)::FileName + setLabelValue(u:SingleInteger):SingleInteger == labelValue := u -\end{chunk} + newLabel():SingleInteger == + labelValue := labelValue + 1$SingleInteger + labelValue -\begin{chunk}{COQ FTEM} -(* domain FTEM *) -(* -*) + commaSep(l:List String):List(String) == + [(l.1),:[:[",",u] for u in rest(l)]] -\end{chunk} + getReturn(rec:RETURN):SEX == + returnToken : SEX := convert("RETURN"::Symbol::O)$SEX + elt(rec,empty?)$RETURN => + getStatement(returnToken,NIL$Lisp)$Lisp + rt : EXPRESSION := elt(rec,value)$RETURN + rv : O := elt(rt,expr)$EXPRESSION + getStatement([returnToken,convert(rv)$SEX]$Lisp, + elt(rt,ints2Floats?)$EXPRESSION )$Lisp -\begin{chunk}{FTEM.dotabb} -"FTEM" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FTEM"] -"STRING" [color="#88FF44",href="bookvol10.3.pdf#nameddest=STRING"] -"FTEM" -> "STRING" + getStop():SEX == + fortran2Lines(LIST("STOP")$Lisp)$Lisp -\end{chunk} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain FT FortranType} + getSave():SEX == + fortran2Lines(LIST("SAVE")$Lisp)$Lisp -\begin{chunk}{FortranType.input} -)set break resume -)sys rm -f FortranType.output -)spool FortranType.output -)set message test on -)set message auto off -)clear all + getCommon(u:COMMON):SEX == + fortran2Lines(APPEND(LIST("COMMON"," /",string (u.name),"/ ")$Lisp,_ + addCommas(u.contents)$Lisp)$Lisp)$Lisp + + getPrint(l:PRINTLIST):SEX == + ll : SEX := LIST("PRINT*")$Lisp + for i in l repeat + ll := APPEND(ll,CONS(",",expression2Fortran(i)$Lisp)$Lisp)$Lisp + fortran2Lines(ll)$Lisp ---S 1 of 1 -)show FortranType ---R ---R FortranType is a domain constructor ---R Abbreviation for FortranType is FT ---R This constructor is exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for FT ---R ---R------------------------------- Operations -------------------------------- ---R ?=? : (%,%) -> Boolean coerce : FortranScalarType -> % ---R coerce : % -> OutputForm external? : % -> Boolean ---R fortranCharacter : () -> % fortranComplex : () -> % ---R fortranDouble : () -> % fortranDoubleComplex : () -> % ---R fortranInteger : () -> % fortranLogical : () -> % ---R fortranReal : () -> % hash : % -> SingleInteger ---R latex : % -> String ?~=? : (%,%) -> Boolean ---R construct : (Union(fst: FortranScalarType,void: void),List(Polynomial(Integer)),Boolean) -> % ---R construct : (Union(fst: FortranScalarType,void: void),List(Symbol),Boolean) -> % ---R dimensionsOf : % -> List(Polynomial(Integer)) ---R scalarTypeOf : % -> Union(fst: FortranScalarType,void: void) ---R ---E 1 + getBlock(rec:BLOCK):SEX == + indentFortLevel(convert(1@Integer)$SEX)$Lisp + expr : SEX := LIST()$Lisp + for u in rec repeat + expr := APPEND(expr,getCode(u))$Lisp + indentFortLevel(convert(-1@Integer)$SEX)$Lisp + expr -)spool -)lisp (bye) -\end{chunk} -\begin{chunk}{FortranType.help} -==================================================================== -FortranType examples -==================================================================== + getBody(f:$):SEX == + operation(f) case Block => getCode f + indentFortLevel(convert(1@Integer)$SEX)$Lisp + expr := getCode f + indentFortLevel(convert(-1@Integer)$SEX)$Lisp + expr -Creates and manipulates objects which correspond to FORTRAN data types, -including array dimensions. + getElseIf(f:$):SEX == + rec := code f + expr := + fortFormatElseIf(elt(rec.conditionalBranch,switch)$COND::O)$Lisp + expr := + APPEND(expr,getBody elt(rec.conditionalBranch,thenClause)$COND)$Lisp + elseBranch := elt(rec.conditionalBranch,elseClause)$COND + not(operation(elseBranch) case Null) => + operation(elseBranch) case Conditional => + APPEND(expr,getElseIf elseBranch)$Lisp + expr := APPEND(expr, getStatement(ELSE::O,NIL$Lisp)$Lisp)$Lisp + expr := APPEND(expr, getBody elseBranch)$Lisp + expr -See Also: -o )show FortranType + getContinue(label:SingleInteger):SEX == + lab : O := label::O + if (width(lab) > 6) then error "Label too big" + cnt : O := "CONTINUE"::O + --sp : O := hspace(6-width lab) + sp : O := hspace(_$fortIndent$Lisp -width lab) + LIST(STRCONC(PRINC_-TO_-STRING(lab)$Lisp,sp,cnt)$Lisp)$Lisp -\end{chunk} + getGoto(label:SingleInteger):SEX == + fortran2Lines( + LIST(STRCONC("GOTO ",PRINC_-TO_-STRING(label::O)$Lisp)$Lisp)$Lisp)$Lisp -\pagehead{FortranType}{FT} -\pagepic{ps/v103fortrantype.ps}{FT}{1.00} -{\bf See}\\ -\pageto{FortranScalarType}{FST} -\pageto{SymbolTable}{SYMTAB} -\pageto{TheSymbolTable}{SYMS} + getRepeat(repRec:LOOP):SEX == + sw : Switch := NOT elt(repRec,switch)$LOOP + lab := newLabel() + bod := elt(repRec,body)$LOOP + APPEND(getContinue lab,getBody bod, + fortFormatIfGoto(sw::O,lab)$Lisp)$Lisp -{\bf Exports:}\\ -\begin{tabular}{llll} -\cross{FT}{coerce} & -\cross{FT}{construct} & -\cross{FT}{dimensionsOf} & -\cross{FT}{external?} \\ -\cross{FT}{fortranCharacter} & -\cross{FT}{fortranComplex} & -\cross{FT}{fortranDouble} & -\cross{FT}{fortranDoubleComplex} \\ -\cross{FT}{fortranInteger} & -\cross{FT}{fortranLogical} & -\cross{FT}{fortranReal} & -\cross{FT}{hash} \\ -\cross{FT}{latex} & -\cross{FT}{scalarTypeOf} & -\cross{FT}{?=?} & -\cross{FT}{?\~{}=?} -\end{tabular} + getWhile(whileRec:LOOP):SEX == + sw := NOT elt(whileRec,switch)$LOOP + lab1 := newLabel() + lab2 := newLabel() + bod := elt(whileRec,body)$LOOP + APPEND(fortFormatLabelledIfGoto(sw::O,lab1,lab2)$Lisp, + getBody bod, getBody goto(lab1), getContinue lab2)$Lisp -\begin{chunk}{domain FT FortranType} -)abbrev domain FT FortranType -++ Author: Mike Dewar -++ Date Created: October 1992 -++ Description: -++ Creates and manipulates objects which correspond to FORTRAN -++ data types, including array dimensions. + getArrayAssign(rec:ARRAYASS):SEX == + getfortarrayexp((rec.var)::O,rec.rand,rec.ints2Floats?)$Lisp -FortranType() : exports == implementation where + getAssign(rec:ASS):SEX == + indices : L PIN := elt(rec,arrayIndex)$ASS + if indices = []::(L PIN) then + lhs := elt(rec,var)$ASS::O + else + lhs := cons(elt(rec,var)$ASS::PIN,indices)::O + -- Must get the index brackets correct: + lhs := (cdr car cdr convert(lhs)$SEX::SEX)::O -- Yuck! + elt(elt(rec,rand)$ASS,ints2Floats?)$EXPRESSION => + assignment2Fortran1(lhs,elt(elt(rec,rand)$ASS,expr)$EXPRESSION)$Lisp + integerAssignment2Fortran1(lhs,_ + elt(elt(rec,rand)$ASS,expr)$EXPRESSION)$Lisp - FST ==> FortranScalarType - FSTU ==> Union(fst:FST,void:"void") + getCond(rec:COND):SEX == + expr := APPEND(fortFormatIf(elt(rec,switch)$COND::O)$Lisp, + getBody elt(rec,thenClause)$COND)$Lisp + elseBranch := elt(rec,elseClause)$COND + if not(operation(elseBranch) case Null) then + operation(elseBranch) case Conditional => + expr := APPEND(expr,getElseIf elseBranch)$Lisp + expr := APPEND(expr,getStatement(ELSE::O,NIL$Lisp)$Lisp, + getBody elseBranch)$Lisp + APPEND(expr,getStatement(ENDIF::O,NIL$Lisp)$Lisp)$Lisp - exports == SetCategory with - coerce : $ -> OutputForm - ++ coerce(x) provides a printable form for x - coerce : FST -> $ - ++ coerce(t) creates an element from a scalar type - scalarTypeOf : $ -> FSTU - ++ scalarTypeOf(t) returns the FORTRAN data type of t - dimensionsOf : $ -> List Polynomial Integer - ++ dimensionsOf(t) returns the dimensions of t - external? : $ -> Boolean - ++ external?(u) returns true if u is declared to be EXTERNAL - construct : (FSTU,List Symbol,Boolean) -> $ - ++ construct(type,dims) creates an element of FortranType - construct : (FSTU,List Polynomial Integer,Boolean) -> $ - ++ construct(type,dims) creates an element of FortranType - fortranReal : () -> $ - ++ fortranReal() returns REAL, an element of FortranType - fortranDouble : () -> $ - ++ fortranDouble() returns DOUBLE PRECISION, an element of FortranType - fortranInteger : () -> $ - ++ fortranInteger() returns INTEGER, an element of FortranType - fortranLogical : () -> $ - ++ fortranLogical() returns LOGICAL, an element of FortranType - fortranComplex : () -> $ - ++ fortranComplex() returns COMPLEX, an element of FortranType - fortranDoubleComplex: () -> $ - ++ fortranDoubleComplex() returns DOUBLE COMPLEX, an element of - ++ FortranType - fortranCharacter : () -> $ - ++ fortranCharacter() returns CHARACTER, an element of FortranType + getComment(rec:COMMENT):SEX == + convert([convert(concat("C ",c)$String)@SEX for c in rec])@SEX - implementation == add + getCall(rec:CALL):SEX == + expr := concat("CALL ",rec)$String + #expr > 1320 => error "Fortran CALL too large" + fortran2Lines(convert([convert(expr)@SEX ])@SEX)$Lisp - Dims == List Polynomial Integer - Rep := Record(type : FSTU, dimensions : Dims, external : Boolean) + getFor(rec:FOR):SEX == + rnge : SegmentBinding PIN := elt(rec,range)$FOR + increment : PIN := elt(rec,span)$FOR + lab : SingleInteger := newLabel() + declare!(variable rnge,fortranInteger()) + expr := fortFormatDo(variable rnge, (lo segment rnge)::O,_ + (hi segment rnge)::O,increment::O,lab)$Lisp + APPEND(expr, getBody elt(rec,body)$FOR, getContinue(lab))$Lisp + + getCode(f:$):SEX == + opp:OP := operation f + rec:OPREC:= code f + opp case Assignment => getAssign(rec.assignmentBranch) + opp case ArrayAssignment => getArrayAssign(rec.arrayAssignmentBranch) + opp case Conditional => getCond(rec.conditionalBranch) + opp case Return => getReturn(rec.returnBranch) + opp case Block => getBlock(rec.blockBranch) + opp case Comment => getComment(rec.commentBranch) + opp case Call => getCall(rec.callBranch) + opp case For => getFor(rec.forBranch) + opp case Continue => getContinue(rec.labelBranch) + opp case Goto => getGoto(rec.labelBranch) + opp case Repeat => getRepeat(rec.loopBranch) + opp case While => getWhile(rec.loopBranch) + opp case Save => getSave() + opp case Stop => getStop() + opp case Print => getPrint(rec.printBranch) + opp case Common => getCommon(rec.commonBranch) + error "Unsupported program construct." + convert(0)@SEX - coerce(a:$):OutputForm == - t : OutputForm - if external?(a) then - if scalarTypeOf(a) case void then - t := "EXTERNAL"::OutputForm - else - t := blankSeparate(["EXTERNAL"::OutputForm, - coerce(scalarTypeOf a)$FSTU])$OutputForm - else - t := coerce(scalarTypeOf a)$FSTU - empty? dimensionsOf(a) => t - sub(t, - paren([u::OutputForm for u in dimensionsOf(a)])$OutputForm)$OutputForm + printCode(f:$):Void == + displayLines1$Lisp getCode f + void()$Void - scalarTypeOf(u:$):FSTU == - u.type + code (f:$):OPREC == + elt(f,data)$Rep - dimensionsOf(u:$):Dims == - u.dimensions + operation (f:$):OP == + elt(f,op)$Rep - external?(u:$):Boolean == - u.external + common(name:Symbol,contents:List Symbol):$ == + [["common"]$OP,[[name,contents]$COMMON]$OPREC]$Rep - construct(t:FSTU, d:List Symbol, e:Boolean):$ == - e and not empty? d => error "EXTERNAL objects cannot have dimensions" - not(e) and t case void => error "VOID objects must be EXTERNAL" - construct(t,[l::Polynomial(Integer) for l in d],e)$Rep + stop():$ == + [["stop"]$OP,["null"]$OPREC]$Rep - construct(t:FSTU, d:List Polynomial Integer, e:Boolean):$ == - e and not empty? d => error "EXTERNAL objects cannot have dimensions" - not(e) and t case void => error "VOID objects must be EXTERNAL" - construct(t,d,e)$Rep + save():$ == + [["save"]$OP,["null"]$OPREC]$Rep - coerce(u:FST):$ == - construct([u]$FSTU,[]@List Polynomial Integer,false) + printStatement(l:List O):$ == + [["print"]$OP,[l]$OPREC]$Rep - fortranReal():$ == ("real"::FST)::$ + comment(s:List String):$ == + [["comment"]$OP,[s]$OPREC]$Rep - fortranDouble():$ == ("double precision"::FST)::$ + comment(s:String):$ == + [["comment"]$OP,[list s]$OPREC]$Rep - fortranInteger():$ == ("integer"::FST)::$ + forLoop(r:SegmentBinding PIN,body:$):$ == + [["for"]$OP,[[r,(incr segment r)::PIN,body]$FOR]$OPREC]$Rep - fortranComplex():$ == ("complex"::FST)::$ + forLoop(r:SegmentBinding PIN,increment:PIN,body:$):$ == + [["for"]$OP,[[r,increment,body]$FOR]$OPREC]$Rep - fortranDoubleComplex():$ == ("double complex"::FST)::$ + goto(l:SingleInteger):$ == + [["goto"]$OP,[l]$OPREC]$Rep - fortranCharacter():$ == ("character"::FST)::$ + continue(l:SingleInteger):$ == + [["continue"]$OP,[l]$OPREC]$Rep - fortranLogical():$ == ("logical"::FST)::$ + whileLoop(sw:Switch,b:$):$ == + [["while"]$OP,[[sw,b]$LOOP]$OPREC]$Rep -\end{chunk} + repeatUntilLoop(sw:Switch,b:$):$ == + [["repeat"]$OP,[[sw,b]$LOOP]$OPREC]$Rep -\begin{chunk}{COQ FT} -(* domain FT *) -(* -*) + returns():$ == + v := [false,0::O]$EXPRESSION + [["return"]$OP,[[true,v]$RETURN]$OPREC]$Rep -\end{chunk} + returns(v:Expression MachineInteger):$ == + [["return"]$OP,[[false,[false,v::O]$EXPRESSION]$RETURN]$OPREC]$Rep -\begin{chunk}{FT.dotabb} -"FT" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FT"] -"PID" [color="#4488FF",href="bookvol10.2.pdf#nameddest=PID"] -"OAGROUP" [color="#4488FF",href="bookvol10.2.pdf#nameddest=OAGROUP"] -"FT" -> "PID" -"FT" -> "OAGROUP" + returns(v:Expression MachineFloat):$ == + [["return"]$OP,[[false,[false,v::O]$EXPRESSION]$RETURN]$OPREC]$Rep -\end{chunk} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain FCOMP FourierComponent} + returns(v:Expression MachineComplex):$ == + [["return"]$OP,[[false,[false,v::O]$EXPRESSION]$RETURN]$OPREC]$Rep -\begin{chunk}{FourierComponent.input} -)set break resume -)sys rm -f FourierComponent.output -)spool FourierComponent.output -)set message test on -)set message auto off -)clear all + returns(v:Expression Integer):$ == + [["return"]$OP,[[false,[false,v::O]$EXPRESSION]$RETURN]$OPREC]$Rep ---S 1 of 1 -)show FourierComponent ---R ---R FourierComponent(E: OrderedSet) is a domain constructor ---R Abbreviation for FourierComponent is FCOMP ---R This constructor is not exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for FCOMP ---R ---R------------------------------- Operations -------------------------------- ---R ? Boolean ?<=? : (%,%) -> Boolean ---R ?=? : (%,%) -> Boolean ?>? : (%,%) -> Boolean ---R ?>=? : (%,%) -> Boolean argument : % -> E ---R coerce : % -> OutputForm cos : E -> % ---R hash : % -> SingleInteger latex : % -> String ---R max : (%,%) -> % min : (%,%) -> % ---R sin : E -> % sin? : % -> Boolean ---R ?~=? : (%,%) -> Boolean ---R ---E 1 + returns(v:Expression Float):$ == + [["return"]$OP,[[false,[false,v::O]$EXPRESSION]$RETURN]$OPREC]$Rep -)spool -)lisp (bye) -\end{chunk} -\begin{chunk}{FourierComponent.help} -==================================================================== -FourierComponent examples -==================================================================== + returns(v:Expression Complex Float):$ == + [["return"]$OP,[[false,[false,v::O]$EXPRESSION]$RETURN]$OPREC]$Rep -This domain creates kernels for use in Fourier series + block(l:List $):$ == + [["block"]$OP,[l]$OPREC]$Rep + + cond(sw:Switch,thenC:$):$ == + [["conditional"]$OP, + [[sw,thenC,[["null"]$OP,["null"]$OPREC]$Rep]$COND]$OPREC]$Rep -See Also: -o )show FourierComponent + cond(sw:Switch,thenC:$,elseC:$):$ == + [["conditional"]$OP,[[sw,thenC,elseC]$COND]$OPREC]$Rep -\end{chunk} + coerce(f : $):O == + (f.op)::O -\pagehead{FourierComponent}{FCOMP} -\pagepic{ps/v103fouriercomponent.ps}{FCOMP}{1.00} -{\bf See}\\ -\pageto{FourierSeries}{FSERIES} + assign(v:Symbol,rhs:String):$ == + [["assignment"]$OP,_ + [[v,nil()::L PIN,[false,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep -{\bf Exports:}\\ -\begin{tabular}{lllll} -\cross{FCOMP}{argument} & -\cross{FCOMP}{coerce} & -\cross{FCOMP}{cos} & -\cross{FCOMP}{hash} & -\cross{FCOMP}{latex} \\ -\cross{FCOMP}{max} & -\cross{FCOMP}{min} & -\cross{FCOMP}{sin} & -\cross{FCOMP}{sin?} & -\cross{FCOMP}{?\~{}=?} \\ -\cross{FCOMP}{?$<$?} & -\cross{FCOMP}{?$<=$?} & -\cross{FCOMP}{?=?} & -\cross{FCOMP}{?$>$?} & -\cross{FCOMP}{?$>=$?} -\end{tabular} + assign(v:Symbol,rhs:Matrix MachineInteger):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,false]$ARRAYASS]$OPREC]$Rep -\begin{chunk}{domain FCOMP FourierComponent} -)abbrev domain FCOMP FourierComponent -++ Author: James Davenport -++ Date Created: 17 April 1992 -++ Date Last Updated: 12 June 1992 -++ Description: -++ This domain creates kernels for use in Fourier series + assign(v:Symbol,rhs:Matrix MachineFloat):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep -FourierComponent(E:OrderedSet): - OrderedSet with - sin: E -> $ - ++ sin(x) makes a sin kernel for use in Fourier series - cos: E -> $ - ++ cos(x) makes a cos kernel for use in Fourier series - sin?: $ -> Boolean - ++ sin?(x) returns true if term is a sin, otherwise false - argument: $ -> E - ++ argument(x) returns the argument of a given sin/cos expressions - == - add - --representations - Rep:=Record(SinIfTrue:Boolean, arg:E) - e:E - x,y:$ - sin e == [true,e] - cos e == [false,e] - sin? x == x.SinIfTrue - argument x == x.arg - coerce(x):OutputForm == - hconcat((if x.SinIfTrue then "sin" else "cos")::OutputForm, - bracket((x.arg)::OutputForm)) - x true - y.arg < x.arg => false - x.SinIfTrue => false - y.SinIfTrue + assign(v:Symbol,rhs:Matrix MachineComplex):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep -\end{chunk} + assign(v:Symbol,rhs:Vector MachineInteger):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,false]$ARRAYASS]$OPREC]$Rep + + assign(v:Symbol,rhs:Vector MachineFloat):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep + + assign(v:Symbol,rhs:Vector MachineComplex):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep + + assign(v:Symbol,rhs:Matrix Expression MachineInteger):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,false]$ARRAYASS]$OPREC]$Rep + + assign(v:Symbol,rhs:Matrix Expression MachineFloat):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep + + assign(v:Symbol,rhs:Matrix Expression MachineComplex):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep + + assign(v:Symbol,rhs:Vector Expression MachineInteger):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,false]$ARRAYASS]$OPREC]$Rep + + assign(v:Symbol,rhs:Vector Expression MachineFloat):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep + + assign(v:Symbol,rhs:Vector Expression MachineComplex):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep + + assign(v:Symbol,index:L PIN,rhs:Expression MachineInteger):$ == + [["assignment"]$OP,[[v,index,[false,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep + + assign(v:Symbol,index:L PIN,rhs:Expression MachineFloat):$ == + [["assignment"]$OP,[[v,index,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep + + assign(v:Symbol,index:L PIN,rhs:Expression MachineComplex):$ == + [["assignment"]$OP,[[v,index,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep + + assign(v:Symbol,rhs:Expression MachineInteger):$ == + [["assignment"]$OP,_ + [[v,nil()::L PIN,[false,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep + + assign(v:Symbol,rhs:Expression MachineFloat):$ == + [["assignment"]$OP,_ + [[v,nil()::L PIN,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep + + assign(v:Symbol,rhs:Expression MachineComplex):$ == + [["assignment"]$OP,_ + [[v,nil()::L PIN,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep + + assign(v:Symbol,rhs:Matrix Expression Integer):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,false]$ARRAYASS]$OPREC]$Rep + + assign(v:Symbol,rhs:Matrix Expression Float):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep + + assign(v:Symbol,rhs:Matrix Expression Complex Float):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep + + assign(v:Symbol,rhs:Vector Expression Integer):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,false]$ARRAYASS]$OPREC]$Rep + + assign(v:Symbol,rhs:Vector Expression Float):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep + + assign(v:Symbol,rhs:Vector Expression Complex Float):$ == + [["arrayAssignment"]$OP,[[v,rhs::O,true]$ARRAYASS]$OPREC]$Rep + + assign(v:Symbol,index:L PIN,rhs:Expression Integer):$ == + [["assignment"]$OP,[[v,index,[false,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep + + assign(v:Symbol,index:L PIN,rhs:Expression Float):$ == + [["assignment"]$OP,[[v,index,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep + + assign(v:Symbol,index:L PIN,rhs:Expression Complex Float):$ == + [["assignment"]$OP,[[v,index,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep + + assign(v:Symbol,rhs:Expression Integer):$ == + [["assignment"]$OP,_ + [[v,nil()::L PIN,[false,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep + + assign(v:Symbol,rhs:Expression Float):$ == + [["assignment"]$OP,_ + [[v,nil()::L PIN,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep + + assign(v:Symbol,rhs:Expression Complex Float):$ == + [["assignment"]$OP,_ + [[v,nil()::L PIN,[true,rhs::O]$EXPRESSION]$ASS]$OPREC]$Rep + + call(s:String):$ == + [["call"]$OP,[s]$OPREC]$Rep -\begin{chunk}{COQ FCOMP} -(* domain FCOMP *) -(* *) \end{chunk} -\begin{chunk}{FCOMP.dotabb} -"FCOMP" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FCOMP"] -"ORDSET" [color="#4488FF",href="bookvol10.2.pdf#nameddest=ORDSET"] -"FCOMP" -> "ORDSET" +\begin{chunk}{FC.dotabb} +"FC" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FC"] +"FS" [color="#4488FF",href="bookvol10.2.pdf#nameddest=FS"] +"COMPCAT" [color="#4488FF",href="bookvol10.2.pdf#nameddest=COMPCAT"] +"FC" -> "COMPCAT" +"FC" -> "FS" \end{chunk} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain FSERIES FourierSeries} +\section{domain FEXPR FortranExpression} -\begin{chunk}{FourierSeries.input} +\begin{chunk}{FortranExpression.input} )set break resume -)sys rm -f FourierSeries.output -)spool FourierSeries.output +)sys rm -f FortranExpression.output +)spool FortranExpression.output )set message test on )set message auto off )clear all --S 1 of 1 -)show FourierSeries +)show FortranExpression --R ---R FourierSeries(R: Join(CommutativeRing,Algebra(Fraction(Integer))),E: Join(OrderedSet,AbelianGroup)) is a domain constructor ---R Abbreviation for FourierSeries is FSERIES +--R FortranExpression(basicSymbols: List(Symbol),subscriptedSymbols: List(Symbol),R: FortranMachineTypeCategory) is a domain constructor +--R Abbreviation for FortranExpression is FEXPR --R This constructor is exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for FSERIES +--R Issue )edit bookvol10.3.pamphlet to see algebra source code for FEXPR --R --R------------------------------- Operations -------------------------------- ---R ?*? : (R,%) -> % ?*? : (%,R) -> % ---R ?*? : (%,%) -> % ?*? : (Integer,%) -> % ---R ?*? : (NonNegativeInteger,%) -> % ?*? : (PositiveInteger,%) -> % ---R ?**? : (%,NonNegativeInteger) -> % ?**? : (%,PositiveInteger) -> % ---R ?+? : (%,%) -> % ?-? : (%,%) -> % ---R -? : % -> % ?=? : (%,%) -> Boolean +--R ?*? : (PositiveInteger,%) -> % ?*? : (NonNegativeInteger,%) -> % +--R ?*? : (Integer,%) -> % ?*? : (%,%) -> % +--R ?*? : (%,R) -> % ?*? : (R,%) -> % +--R ?**? : (%,PositiveInteger) -> % ?**? : (%,NonNegativeInteger) -> % +--R ?+? : (%,%) -> % -? : % -> % +--R ?-? : (%,%) -> % ? Boolean +--R ?<=? : (%,%) -> Boolean ?=? : (%,%) -> Boolean +--R ?>? : (%,%) -> Boolean ?>=? : (%,%) -> Boolean +--R D : (%,Symbol) -> % D : (%,List(Symbol)) -> % --R 1 : () -> % 0 : () -> % ---R ?^? : (%,NonNegativeInteger) -> % ?^? : (%,PositiveInteger) -> % ---R coerce : FourierComponent(E) -> % coerce : R -> % ---R coerce : Integer -> % coerce : % -> OutputForm ---R hash : % -> SingleInteger latex : % -> String ---R makeCos : (E,R) -> % makeSin : (E,R) -> % ---R one? : % -> Boolean recip : % -> Union(%,"failed") ---R sample : () -> % zero? : % -> Boolean ---R ?~=? : (%,%) -> Boolean +--R ?^? : (%,PositiveInteger) -> % ?^? : (%,NonNegativeInteger) -> % +--R abs : % -> % acos : % -> % +--R asin : % -> % atan : % -> % +--R belong? : BasicOperator -> Boolean box : List(%) -> % +--R box : % -> % coerce : % -> Expression(R) +--R coerce : Integer -> % coerce : R -> % +--R coerce : Kernel(%) -> % coerce : % -> OutputForm +--R cos : % -> % cosh : % -> % +--R differentiate : (%,Symbol) -> % distribute : (%,%) -> % +--R distribute : % -> % elt : (BasicOperator,List(%)) -> % +--R elt : (BasicOperator,%,%,%) -> % elt : (BasicOperator,%,%) -> % +--R elt : (BasicOperator,%) -> % eval : (%,Symbol,(% -> %)) -> % +--R eval : (%,List(%),List(%)) -> % eval : (%,%,%) -> % +--R eval : (%,Equation(%)) -> % eval : (%,List(Equation(%))) -> % +--R eval : (%,Kernel(%),%) -> % exp : % -> % +--R freeOf? : (%,Symbol) -> Boolean freeOf? : (%,%) -> Boolean +--R hash : % -> SingleInteger height : % -> NonNegativeInteger +--R is? : (%,Symbol) -> Boolean is? : (%,BasicOperator) -> Boolean +--R kernel : (BasicOperator,%) -> % kernels : % -> List(Kernel(%)) +--R latex : % -> String log : % -> % +--R log10 : % -> % map : ((% -> %),Kernel(%)) -> % +--R max : (%,%) -> % min : (%,%) -> % +--R one? : % -> Boolean paren : List(%) -> % +--R paren : % -> % pi : () -> % +--R recip : % -> Union(%,"failed") retract : Symbol -> % +--R retract : Expression(R) -> % retract : % -> R +--R retract : % -> Kernel(%) sample : () -> % +--R sin : % -> % sinh : % -> % +--R sqrt : % -> % subst : (%,Equation(%)) -> % +--R tan : % -> % tanh : % -> % +--R tower : % -> List(Kernel(%)) useNagFunctions : Boolean -> Boolean +--R useNagFunctions : () -> Boolean variables : % -> List(Symbol) +--R zero? : % -> Boolean ?~=? : (%,%) -> Boolean +--R D : (%,Symbol,NonNegativeInteger) -> % +--R D : (%,List(Symbol),List(NonNegativeInteger)) -> % --R characteristic : () -> NonNegativeInteger +--R definingPolynomial : % -> % if $ has RING +--R differentiate : (%,List(Symbol)) -> % +--R differentiate : (%,Symbol,NonNegativeInteger) -> % +--R differentiate : (%,List(Symbol),List(NonNegativeInteger)) -> % +--R elt : (BasicOperator,%,%,%,%) -> % +--R eval : (%,BasicOperator,(% -> %)) -> % +--R eval : (%,BasicOperator,(List(%) -> %)) -> % +--R eval : (%,List(BasicOperator),List((List(%) -> %))) -> % +--R eval : (%,List(BasicOperator),List((% -> %))) -> % +--R eval : (%,Symbol,(List(%) -> %)) -> % +--R eval : (%,List(Symbol),List((List(%) -> %))) -> % +--R eval : (%,List(Symbol),List((% -> %))) -> % +--R eval : (%,List(Kernel(%)),List(%)) -> % +--R even? : % -> Boolean if $ has RETRACT(INT) +--R kernel : (BasicOperator,List(%)) -> % +--R mainKernel : % -> Union(Kernel(%),"failed") +--R minPoly : Kernel(%) -> SparseUnivariatePolynomial(%) if $ has RING +--R odd? : % -> Boolean if $ has RETRACT(INT) +--R operator : BasicOperator -> BasicOperator +--R operators : % -> List(BasicOperator) +--R retract : Polynomial(Float) -> % if R has RETRACT(FLOAT) +--R retract : Fraction(Polynomial(Float)) -> % if R has RETRACT(FLOAT) +--R retract : Expression(Float) -> % if R has RETRACT(FLOAT) +--R retract : Polynomial(Integer) -> % if R has RETRACT(INT) +--R retract : Fraction(Polynomial(Integer)) -> % if R has RETRACT(INT) +--R retract : Expression(Integer) -> % if R has RETRACT(INT) +--R retractIfCan : Polynomial(Float) -> Union(%,"failed") if R has RETRACT(FLOAT) +--R retractIfCan : Fraction(Polynomial(Float)) -> Union(%,"failed") if R has RETRACT(FLOAT) +--R retractIfCan : Expression(Float) -> Union(%,"failed") if R has RETRACT(FLOAT) +--R retractIfCan : Polynomial(Integer) -> Union(%,"failed") if R has RETRACT(INT) +--R retractIfCan : Fraction(Polynomial(Integer)) -> Union(%,"failed") if R has RETRACT(INT) +--R retractIfCan : Expression(Integer) -> Union(%,"failed") if R has RETRACT(INT) +--R retractIfCan : Symbol -> Union(%,"failed") +--R retractIfCan : Expression(R) -> Union(%,"failed") +--R retractIfCan : % -> Union(R,"failed") +--R retractIfCan : % -> Union(Kernel(%),"failed") +--R subst : (%,List(Kernel(%)),List(%)) -> % +--R subst : (%,List(Equation(%))) -> % --R subtractIfCan : (%,%) -> Union(%,"failed") --R --E 1 @@ -62867,2561 +70673,2084 @@ FourierComponent(E:OrderedSet): )spool )lisp (bye) \end{chunk} -\begin{chunk}{FourierSeries.help} +\begin{chunk}{FortranExpression.help} ==================================================================== -FourierSeries examples +FortranExpression examples ==================================================================== -This domain converts terms into Fourier series +A domain of expressions involving functions which can be translated into +standard Fortran-77, with some extra extensions from the NAG Fortran Library. See Also: -o )show FourierSeries +o )show FortranExpression \end{chunk} -\pagehead{FourierSeries}{FSERIES} -\pagepic{ps/v103fourierseries.ps}{FSERIES}{1.00} +\pagehead{FortranExpression}{FEXPR} +\pagepic{ps/v103fortranexpression.ps}{FEXPR}{1.00} {\bf See}\\ -\pageto{FourierComponent}{FCOMP} +\pageto{Result}{RESULT} +\pageto{FortranCode}{FC} +\pageto{FortranProgram}{FORTRAN} +\pageto{ThreeDimensionalMatrix}{M3D} +\pageto{SimpleFortranProgram}{SFORT} +\pageto{Switch}{SWITCH} +\pageto{FortranTemplate}{FTEM} {\bf Exports:}\\ \begin{tabular}{lllll} -\cross{FSERIES}{0} & -\cross{FSERIES}{1} & -\cross{FSERIES}{characteristic} & -\cross{FSERIES}{coerce} & -\cross{FSERIES}{hash} \\ -\cross{FSERIES}{latex} & -\cross{FSERIES}{makeCos} & -\cross{FSERIES}{makeSin} & -\cross{FSERIES}{one?} & -\cross{FSERIES}{recip} \\ -\cross{FSERIES}{sample} & -\cross{FSERIES}{subtractIfCan} & -\cross{FSERIES}{zero?} & -\cross{FSERIES}{?\~{}=?} & -\cross{FSERIES}{?*?} \\ -\cross{FSERIES}{?**?} & -\cross{FSERIES}{?\^{}?} & -\cross{FSERIES}{?+?} & -\cross{FSERIES}{?-?} & -\cross{FSERIES}{-?} \\ -\cross{FSERIES}{?=?} &&&& +\cross{FEXPR}{0} & +\cross{FEXPR}{1} & +\cross{FEXPR}{abs} & +\cross{FEXPR}{acos} & +\cross{FEXPR}{asin} \\ +\cross{FEXPR}{atan} & +\cross{FEXPR}{belong?} & +\cross{FEXPR}{box} & +\cross{FEXPR}{characteristic} & +\cross{FEXPR}{coerce} \\ +\cross{FEXPR}{cos} & +\cross{FEXPR}{cosh} & +\cross{FEXPR}{D} & +\cross{FEXPR}{definingPolynomial} & +\cross{FEXPR}{differentiate} \\ +\cross{FEXPR}{distribute} & +\cross{FEXPR}{elt} & +\cross{FEXPR}{eval} & +\cross{FEXPR}{even?} & +\cross{FEXPR}{exp} \\ +\cross{FEXPR}{freeOf?} & +\cross{FEXPR}{hash} & +\cross{FEXPR}{height} & +\cross{FEXPR}{is?} & +\cross{FEXPR}{kernel} \\ +\cross{FEXPR}{kernels} & +\cross{FEXPR}{latex} & +\cross{FEXPR}{log} & +\cross{FEXPR}{log10} & +\cross{FEXPR}{mainKernel} \\ +\cross{FEXPR}{map} & +\cross{FEXPR}{max} & +\cross{FEXPR}{min} & +\cross{FEXPR}{minPoly} & +\cross{FEXPR}{odd?} \\ +\cross{FEXPR}{one?} & +\cross{FEXPR}{operator} & +\cross{FEXPR}{operators} & +\cross{FEXPR}{paren} & +\cross{FEXPR}{pi} \\ +\cross{FEXPR}{recip} & +\cross{FEXPR}{retract} & +\cross{FEXPR}{retractIfCan} & +\cross{FEXPR}{sample} & +\cross{FEXPR}{sin} \\ +\cross{FEXPR}{sinh} & +\cross{FEXPR}{sqrt} & +\cross{FEXPR}{subst} & +\cross{FEXPR}{subtractIfCan} & +\cross{FEXPR}{tan} \\ +\cross{FEXPR}{tanh} & +\cross{FEXPR}{tower} & +\cross{FEXPR}{useNagFunctions} & +\cross{FEXPR}{variables} & +\cross{FEXPR}{zero?} \\ +\cross{FEXPR}{?*?} & +\cross{FEXPR}{?**?} & +\cross{FEXPR}{?+?} & +\cross{FEXPR}{-?} & +\cross{FEXPR}{?-?} \\ +\cross{FEXPR}{?$<$?} & +\cross{FEXPR}{?$<=$?} & +\cross{FEXPR}{?=?} & +\cross{FEXPR}{?$>$?} & +\cross{FEXPR}{?$>=$?} \\ +\cross{FEXPR}{?\^{}?} & +\cross{FEXPR}{?\~{}=?} &&& \end{tabular} -\begin{chunk}{domain FSERIES FourierSeries} -)abbrev domain FSERIES FourierSeries -++ Author: James Davenport -++ Date Created: 17 April 1992 -++ Description: -++ This domain converts terms into Fourier series - -FourierSeries(R:Join(CommutativeRing,Algebra(Fraction Integer)), - E:Join(OrderedSet,AbelianGroup)): - Algebra(R) with - if E has canonical and R has canonical then canonical - coerce: R -> $ - ++ coerce(r) converts coefficients into Fourier Series - coerce: FourierComponent(E) -> $ - ++ coerce(c) converts sin/cos terms into Fourier Series - makeSin: (E,R) -> $ - ++ makeSin(e,r) makes a sin expression with given - ++ argument and coefficient - makeCos: (E,R) -> $ - ++ makeCos(e,r) makes a sin expression with given - ++argument and coefficient - == FreeModule(R,FourierComponent(E)) - add - --representations - Term := Record(k:FourierComponent(E),c:R) - Rep := List Term - multiply : (Term,Term) -> $ - w,x1,x2:$ - t1,t2:Term - n:NonNegativeInteger - z:Integer - e:FourierComponent(E) - a:E - r:R - 1 == [[cos 0,1]] - coerce e == - sin? e and zero? argument e => 0 - if argument e < 0 then - not sin? e => e:=cos(- argument e) - return [[sin(- argument e),-1]] - [[e,1]] - multiply(t1,t2) == - r:=(t1.c*t2.c)*(1/2) - s1:=argument t1.k - s2:=argument t2.k - sum:=s1+s2 - diff:=s1-s2 - sin? t1.k => - sin? t2.k => - makeCos(diff,r) + makeCos(sum,-r) - makeSin(sum,r) + makeSin(diff,r) - sin? t2.k => - makeSin(sum,r) + makeSin(diff,r) - makeCos(diff,r) + makeCos(sum,r) - x1*x2 == - null x1 => 0 - null x2 => 0 - +/[+/[multiply(t1,t2) for t2 in x2] for t1 in x1] - makeCos(a,r) == - a<0 => [[cos(-a),r]] - [[cos a,r]] - makeSin(a,r) == - zero? a => [] - a<0 => [[sin(-a),-r]] - [[sin a,r]] - -\end{chunk} - -\begin{chunk}{COQ FSERIES} -(* domain FSERIES *) -(* -*) - -\end{chunk} - -\begin{chunk}{FSERIES.dotabb} -"FSERIES" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FSERIES"] -"PID" [color="#4488FF",href="bookvol10.2.pdf#nameddest=PID"] -"OAGROUP" [color="#4488FF",href="bookvol10.2.pdf#nameddest=OAGROUP"] -"FSERIES" -> "PID" -"FSERIES" -> "OAGROUP" - -\end{chunk} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain FRAC Fraction} +\begin{chunk}{domain FEXPR FortranExpression} +)abbrev domain FEXPR FortranExpression +++ Author: Mike Dewar +++ Date Created: December 1993 +++ Date Last Updated: 12 July 1994 added RetractableTo(R) +++ Description: +++ A domain of expressions involving functions which can be +++ translated into standard Fortran-77, with some extra extensions from +++ the NAG Fortran Library. -\begin{chunk}{Fraction.input} -)set break resume -)sys rm -f Fraction.output -)spool Fraction.output -)set message test on -)set message auto off -)clear all +FortranExpression(basicSymbols,subscriptedSymbols,R): + Exports==Implementation where + basicSymbols : List Symbol + subscriptedSymbols : List Symbol + R : FortranMachineTypeCategory ---S 1 of 13 -a := 11/12 ---R ---R ---R 11 ---R (1) -- ---R 12 ---R Type: Fraction(Integer) ---E 1 + EXPR ==> Expression + EXF2 ==> ExpressionFunctions2 + S ==> Symbol + L ==> List + BO ==> BasicOperator + FRAC ==> Fraction + POLY ==> Polynomial ---S 2 of 13 -b := 23/24 ---R ---R ---R 23 ---R (2) -- ---R 24 ---R Type: Fraction(Integer) ---E 2 + Exports ==> Join(ExpressionSpace,Algebra(R),RetractableTo(R), + PartialDifferentialRing(Symbol)) with + retract : EXPR R -> $ + ++ retract(e) takes e and transforms it into a + ++ FortranExpression checking that it contains no non-Fortran + ++ functions, and that it only contains the given basic symbols + ++ and subscripted symbols which correspond to scalar and array + ++ parameters respectively. + retractIfCan : EXPR R -> Union($,"failed") + ++ retractIfCan(e) takes e and tries to transform it into a + ++ FortranExpression checking that it contains no non-Fortran + ++ functions, and that it only contains the given basic symbols + ++ and subscripted symbols which correspond to scalar and array + ++ parameters respectively. + retract : S -> $ + ++ retract(e) takes e and transforms it into a FortranExpression + ++ checking that it is one of the given basic symbols + ++ or subscripted symbols which correspond to scalar and array + ++ parameters respectively. + retractIfCan : S -> Union($,"failed") + ++ retractIfCan(e) takes e and tries to transform it into a + ++ FortranExpression checking that it is one of the given basic symbols + ++ or subscripted symbols which correspond to scalar and array + ++ parameters respectively. + coerce : $ -> EXPR R + ++ coerce(x) is not documented + if (R has RetractableTo(Integer)) then + retract : EXPR Integer -> $ + ++ retract(e) takes e and transforms it into a + ++ FortranExpression checking that it contains no non-Fortran + ++ functions, and that it only contains the given basic symbols + ++ and subscripted symbols which correspond to scalar and array + ++ parameters respectively. + retractIfCan : EXPR Integer -> Union($,"failed") + ++ retractIfCan(e) takes e and tries to transform it into a + ++ FortranExpression checking that it contains no non-Fortran + ++ functions, and that it only contains the given basic symbols + ++ and subscripted symbols which correspond to scalar and array + ++ parameters respectively. + retract : FRAC POLY Integer -> $ + ++ retract(e) takes e and transforms it into a + ++ FortranExpression checking that it contains no non-Fortran + ++ functions, and that it only contains the given basic symbols + ++ and subscripted symbols which correspond to scalar and array + ++ parameters respectively. + retractIfCan : FRAC POLY Integer -> Union($,"failed") + ++ retractIfCan(e) takes e and tries to transform it into a + ++ FortranExpression checking that it contains no non-Fortran + ++ functions, and that it only contains the given basic symbols + ++ and subscripted symbols which correspond to scalar and array + ++ parameters respectively. + retract : POLY Integer -> $ + ++ retract(e) takes e and transforms it into a + ++ FortranExpression checking that it contains no non-Fortran + ++ functions, and that it only contains the given basic symbols + ++ and subscripted symbols which correspond to scalar and array + ++ parameters respectively. + retractIfCan : POLY Integer -> Union($,"failed") + ++ retractIfCan(e) takes e and tries to transform it into a + ++ FortranExpression checking that it contains no non-Fortran + ++ functions, and that it only contains the given basic symbols + ++ and subscripted symbols which correspond to scalar and array + ++ parameters respectively. + if (R has RetractableTo(Float)) then + retract : EXPR Float -> $ + ++ retract(e) takes e and transforms it into a + ++ FortranExpression checking that it contains no non-Fortran + ++ functions, and that it only contains the given basic symbols + ++ and subscripted symbols which correspond to scalar and array + ++ parameters respectively. + retractIfCan : EXPR Float -> Union($,"failed") + ++ retractIfCan(e) takes e and tries to transform it into a + ++ FortranExpression checking that it contains no non-Fortran + ++ functions, and that it only contains the given basic symbols + ++ and subscripted symbols which correspond to scalar and array + ++ parameters respectively. + retract : FRAC POLY Float -> $ + ++ retract(e) takes e and transforms it into a + ++ FortranExpression checking that it contains no non-Fortran + ++ functions, and that it only contains the given basic symbols + ++ and subscripted symbols which correspond to scalar and array + ++ parameters respectively. + retractIfCan : FRAC POLY Float -> Union($,"failed") + ++ retractIfCan(e) takes e and tries to transform it into a + ++ FortranExpression checking that it contains no non-Fortran + ++ functions, and that it only contains the given basic symbols + ++ and subscripted symbols which correspond to scalar and array + ++ parameters respectively. + retract : POLY Float -> $ + ++ retract(e) takes e and transforms it into a + ++ FortranExpression checking that it contains no non-Fortran + ++ functions, and that it only contains the given basic symbols + ++ and subscripted symbols which correspond to scalar and array + ++ parameters respectively. + retractIfCan : POLY Float -> Union($,"failed") + ++ retractIfCan(e) takes e and tries to transform it into a + ++ FortranExpression checking that it contains no non-Fortran + ++ functions, and that it only contains the given basic symbols + ++ and subscripted symbols which correspond to scalar and array + ++ parameters respectively. + abs : $ -> $ + ++ abs(x) represents the Fortran intrinsic function ABS + sqrt : $ -> $ + ++ sqrt(x) represents the Fortran intrinsic function SQRT + exp : $ -> $ + ++ exp(x) represents the Fortran intrinsic function EXP + log : $ -> $ + ++ log(x) represents the Fortran intrinsic function LOG + log10 : $ -> $ + ++ log10(x) represents the Fortran intrinsic function LOG10 + sin : $ -> $ + ++ sin(x) represents the Fortran intrinsic function SIN + cos : $ -> $ + ++ cos(x) represents the Fortran intrinsic function COS + tan : $ -> $ + ++ tan(x) represents the Fortran intrinsic function TAN + asin : $ -> $ + ++ asin(x) represents the Fortran intrinsic function ASIN + acos : $ -> $ + ++ acos(x) represents the Fortran intrinsic function ACOS + atan : $ -> $ + ++ atan(x) represents the Fortran intrinsic function ATAN + sinh : $ -> $ + ++ sinh(x) represents the Fortran intrinsic function SINH + cosh : $ -> $ + ++ cosh(x) represents the Fortran intrinsic function COSH + tanh : $ -> $ + ++ tanh(x) represents the Fortran intrinsic function TANH + pi : () -> $ + ++ pi(x) represents the NAG Library function X01AAF which returns + ++ an approximation to the value of pi + variables : $ -> L S + ++ variables(e) return a list of all the variables in \spad{e}. + useNagFunctions : () -> Boolean + ++ useNagFunctions() indicates whether NAG functions are being used + ++ for mathematical and machine constants. + useNagFunctions : Boolean -> Boolean + ++ useNagFunctions(v) sets the flag which controls whether NAG functions + ++ are being used for mathematical and machine constants. The previous + ++ value is returned. ---S 3 of 13 -3 - a*b**2 + a + b/a ---R ---R ---R 313271 ---R (3) ------ ---R 76032 ---R Type: Fraction(Integer) ---E 3 + Implementation ==> EXPR R add ---S 4 of 13 -numer(a) ---R ---R ---R (4) 11 ---R Type: PositiveInteger ---E 4 + -- The standard FORTRAN-77 intrinsic functions, plus nthRoot which + -- can be translated into an arithmetic expression: + f77Functions : L S := [abs,sqrt,exp,log,log10,sin,cos,tan,asin,acos, + atan,sinh,cosh,tanh,nthRoot,%power] ---S 5 of 13 -denom(b) ---R ---R ---R (5) 24 ---R Type: PositiveInteger ---E 5 + nagFunctions : L S := [pi, X01AAF] ---S 6 of 13 -r := (x**2 + 2*x + 1)/(x**2 - 2*x + 1) ---R ---R ---R 2 ---R x + 2x + 1 ---R (6) ----------- ---R 2 ---R x - 2x + 1 ---R Type: Fraction(Polynomial(Integer)) ---E 6 + useNagFunctionsFlag : Boolean := true ---S 7 of 13 -factor(r) ---R ---R ---R 2 ---R x + 2x + 1 ---R (7) ----------- ---R 2 ---R x - 2x + 1 ---R Type: Factored(Fraction(Polynomial(Integer))) ---E 7 + -- Local functions to check for "unassigned" symbols etc. ---S 8 of 13 -map(factor,r) ---R ---R ---R 2 ---R (x + 1) ---R (8) -------- ---R 2 ---R (x - 1) ---R Type: Fraction(Factored(Polynomial(Integer))) ---E 8 + mkEqn(s1:Symbol,s2:Symbol):Equation EXPR(R) == + equation(s2::EXPR(R),script(s1,scripts(s2))::EXPR(R)) ---S 9 of 13 -continuedFraction(7/12) ---R ---R ---R 1 | 1 | 1 | 1 | ---R (9) +---+ + +---+ + +---+ + +---+ ---R | 1 | 1 | 2 | 2 ---R Type: ContinuedFraction(Integer) ---E 9 + fixUpSymbols(u:EXPR R):Union(EXPR R,"failed") == + -- If its a univariate expression then just fix it up: + syms : L S := variables(u) + (#basicSymbols = 1) and zero?(#subscriptedSymbols) => + not (#syms = 1) => "failed" + subst(u,equation(first(syms)::EXPR(R),first(basicSymbols)::EXPR(R))) + -- We have one variable but it is subscripted: + zero?(#basicSymbols) and (#subscriptedSymbols = 1) => + -- Make sure we don't have both X and X_i + for s in syms repeat + not scripted?(s) => return "failed" + not ((#(syms:=removeDuplicates! [name(s) for s in syms]))=1)=> "failed" + sym : Symbol := first subscriptedSymbols + subst(u,[mkEqn(sym,i) for i in variables(u)]) + "failed" ---S 10 of 13 -partialFraction(7,12) ---R ---R ---R 3 1 ---R (10) 1 - -- + - ---R 2 3 ---R 2 ---R Type: PartialFraction(Integer) ---E 10 + extraSymbols?(u:EXPR R):Boolean == + syms : L S := [name(v) for v in variables(u)] + extras : L S := setDifference(syms, + setUnion(basicSymbols,subscriptedSymbols)) + not empty? extras ---S 11 of 13 -g := 2/3 + 4/5*%i ---R ---R ---R 2 4 ---R (11) - + - %i ---R 3 5 ---R Type: Complex(Fraction(Integer)) ---E 11 + checkSymbols(u:EXPR R):EXPR(R) == + syms : L S := [name(v) for v in variables(u)] + extras : L S := setDifference(syms, + setUnion(basicSymbols,subscriptedSymbols)) + not empty? extras => + m := fixUpSymbols(u) + m case EXPR(R) => m::EXPR(R) + error("Extra symbols detected:",[string(v) for v in extras]$L(String)) + u ---S 12 of 13 -g :: FRAC COMPLEX INT ---R ---R ---R 10 + 12%i ---R (12) --------- ---R 15 ---R Type: Fraction(Complex(Integer)) ---E 12 + notSymbol?(v:BO):Boolean == + s : S := name v + member?(s,basicSymbols) or + scripted?(s) and member?(name s,subscriptedSymbols) => false + true ---S 13 of 13 -)show Fraction ---R ---R Fraction(S: IntegralDomain) is a domain constructor ---R Abbreviation for Fraction is FRAC ---R This constructor is exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for FRAC ---R ---R------------------------------- Operations -------------------------------- ---R ?*? : (%,S) -> % ?*? : (S,%) -> % ---R ?*? : (Fraction(Integer),%) -> % ?*? : (%,Fraction(Integer)) -> % ---R ?*? : (%,%) -> % ?*? : (Integer,%) -> % ---R ?*? : (NonNegativeInteger,%) -> % ?*? : (PositiveInteger,%) -> % ---R ?**? : (%,Integer) -> % ?**? : (%,NonNegativeInteger) -> % ---R ?**? : (%,PositiveInteger) -> % ?+? : (%,%) -> % ---R ?-? : (%,%) -> % -? : % -> % ---R ?/? : (S,S) -> % ?/? : (%,%) -> % ---R ?=? : (%,%) -> Boolean D : (%,(S -> S)) -> % ---R D : % -> % if S has DIFRING 1 : () -> % ---R 0 : () -> % ?^? : (%,Integer) -> % ---R ?^? : (%,NonNegativeInteger) -> % ?^? : (%,PositiveInteger) -> % ---R abs : % -> % if S has OINTDOM associates? : (%,%) -> Boolean ---R ceiling : % -> S if S has INS coerce : S -> % ---R coerce : Fraction(Integer) -> % coerce : % -> % ---R coerce : Integer -> % coerce : % -> OutputForm ---R convert : % -> Float if S has REAL denom : % -> S ---R denominator : % -> % differentiate : (%,(S -> S)) -> % ---R factor : % -> Factored(%) floor : % -> S if S has INS ---R gcd : List(%) -> % gcd : (%,%) -> % ---R hash : % -> SingleInteger init : () -> % if S has STEP ---R inv : % -> % latex : % -> String ---R lcm : List(%) -> % lcm : (%,%) -> % ---R map : ((S -> S),%) -> % max : (%,%) -> % if S has ORDSET ---R min : (%,%) -> % if S has ORDSET numer : % -> S ---R numerator : % -> % one? : % -> Boolean ---R prime? : % -> Boolean ?quo? : (%,%) -> % ---R random : () -> % if S has INS recip : % -> Union(%,"failed") ---R ?rem? : (%,%) -> % retract : % -> S ---R sample : () -> % sizeLess? : (%,%) -> Boolean ---R squareFree : % -> Factored(%) squareFreePart : % -> % ---R unit? : % -> Boolean unitCanonical : % -> % ---R wholePart : % -> S if S has EUCDOM zero? : % -> Boolean ---R ?~=? : (%,%) -> Boolean ---R ? Boolean if S has ORDSET ---R ?<=? : (%,%) -> Boolean if S has ORDSET ---R ?>? : (%,%) -> Boolean if S has ORDSET ---R ?>=? : (%,%) -> Boolean if S has ORDSET ---R D : (%,(S -> S),NonNegativeInteger) -> % ---R D : (%,List(Symbol),List(NonNegativeInteger)) -> % if S has PDRING(SYMBOL) ---R D : (%,Symbol,NonNegativeInteger) -> % if S has PDRING(SYMBOL) ---R D : (%,List(Symbol)) -> % if S has PDRING(SYMBOL) ---R D : (%,Symbol) -> % if S has PDRING(SYMBOL) ---R D : (%,NonNegativeInteger) -> % if S has DIFRING ---R OMwrite : (OpenMathDevice,%,Boolean) -> Void if S has INS and S has OM ---R OMwrite : (OpenMathDevice,%) -> Void if S has INS and S has OM ---R OMwrite : (%,Boolean) -> String if S has INS and S has OM ---R OMwrite : % -> String if S has INS and S has OM ---R characteristic : () -> NonNegativeInteger ---R charthRoot : % -> Union(%,"failed") if $ has CHARNZ and S has PFECAT or S has CHARNZ ---R coerce : Symbol -> % if S has RETRACT(SYMBOL) ---R conditionP : Matrix(%) -> Union(Vector(%),"failed") if $ has CHARNZ and S has PFECAT ---R convert : % -> DoubleFloat if S has REAL ---R convert : % -> InputForm if S has KONVERT(INFORM) ---R convert : % -> Pattern(Float) if S has KONVERT(PATTERN(FLOAT)) ---R convert : % -> Pattern(Integer) if S has KONVERT(PATTERN(INT)) ---R differentiate : (%,(S -> S),NonNegativeInteger) -> % ---R differentiate : (%,List(Symbol),List(NonNegativeInteger)) -> % if S has PDRING(SYMBOL) ---R differentiate : (%,Symbol,NonNegativeInteger) -> % if S has PDRING(SYMBOL) ---R differentiate : (%,List(Symbol)) -> % if S has PDRING(SYMBOL) ---R differentiate : (%,Symbol) -> % if S has PDRING(SYMBOL) ---R differentiate : (%,NonNegativeInteger) -> % if S has DIFRING ---R differentiate : % -> % if S has DIFRING ---R divide : (%,%) -> Record(quotient: %,remainder: %) ---R ?.? : (%,S) -> % if S has ELTAB(S,S) ---R euclideanSize : % -> NonNegativeInteger ---R eval : (%,Symbol,S) -> % if S has IEVALAB(SYMBOL,S) ---R eval : (%,List(Symbol),List(S)) -> % if S has IEVALAB(SYMBOL,S) ---R eval : (%,List(Equation(S))) -> % if S has EVALAB(S) ---R eval : (%,Equation(S)) -> % if S has EVALAB(S) ---R eval : (%,S,S) -> % if S has EVALAB(S) ---R eval : (%,List(S),List(S)) -> % if S has EVALAB(S) ---R expressIdealMember : (List(%),%) -> Union(List(%),"failed") ---R exquo : (%,%) -> Union(%,"failed") ---R extendedEuclidean : (%,%,%) -> Union(Record(coef1: %,coef2: %),"failed") ---R extendedEuclidean : (%,%) -> Record(coef1: %,coef2: %,generator: %) ---R factorPolynomial : SparseUnivariatePolynomial(%) -> Factored(SparseUnivariatePolynomial(%)) if S has PFECAT ---R factorSquareFreePolynomial : SparseUnivariatePolynomial(%) -> Factored(SparseUnivariatePolynomial(%)) if S has PFECAT ---R fractionPart : % -> % if S has EUCDOM ---R gcdPolynomial : (SparseUnivariatePolynomial(%),SparseUnivariatePolynomial(%)) -> SparseUnivariatePolynomial(%) ---R lcmCoef : (%,%) -> Record(llcmres: %,coeff1: %,coeff2: %) ---R multiEuclidean : (List(%),%) -> Union(List(%),"failed") ---R negative? : % -> Boolean if S has OINTDOM ---R nextItem : % -> Union(%,"failed") if S has STEP ---R patternMatch : (%,Pattern(Float),PatternMatchResult(Float,%)) -> PatternMatchResult(Float,%) if S has PATMAB(FLOAT) ---R patternMatch : (%,Pattern(Integer),PatternMatchResult(Integer,%)) -> PatternMatchResult(Integer,%) if S has PATMAB(INT) ---R positive? : % -> Boolean if S has OINTDOM ---R principalIdeal : List(%) -> Record(coef: List(%),generator: %) ---R reducedSystem : Matrix(%) -> Matrix(S) ---R reducedSystem : (Matrix(%),Vector(%)) -> Record(mat: Matrix(S),vec: Vector(S)) ---R reducedSystem : (Matrix(%),Vector(%)) -> Record(mat: Matrix(Integer),vec: Vector(Integer)) if S has LINEXP(INT) ---R reducedSystem : Matrix(%) -> Matrix(Integer) if S has LINEXP(INT) ---R retract : % -> Integer if S has RETRACT(INT) ---R retract : % -> Fraction(Integer) if S has RETRACT(INT) ---R retract : % -> Symbol if S has RETRACT(SYMBOL) ---R retractIfCan : % -> Union(Integer,"failed") if S has RETRACT(INT) ---R retractIfCan : % -> Union(Fraction(Integer),"failed") if S has RETRACT(INT) ---R retractIfCan : % -> Union(Symbol,"failed") if S has RETRACT(SYMBOL) ---R retractIfCan : % -> Union(S,"failed") ---R sign : % -> Integer if S has OINTDOM ---R solveLinearPolynomialEquation : (List(SparseUnivariatePolynomial(%)),SparseUnivariatePolynomial(%)) -> Union(List(SparseUnivariatePolynomial(%)),"failed") if S has PFECAT ---R squareFreePolynomial : SparseUnivariatePolynomial(%) -> Factored(SparseUnivariatePolynomial(%)) if S has PFECAT ---R subtractIfCan : (%,%) -> Union(%,"failed") ---R unitNormal : % -> Record(unit: %,canonical: %,associate: %) ---R ---E 13 + extraOperators?(u:EXPR R):Boolean == + ops : L S := [name v for v in operators(u) | notSymbol?(v)] + if useNagFunctionsFlag then + fortranFunctions : L S := append(f77Functions,nagFunctions) + else + fortranFunctions : L S := f77Functions + extras : L S := setDifference(ops,fortranFunctions) + not empty? extras -)spool -)lisp (bye) -\end{chunk} -\begin{chunk}{Fraction.help} -==================================================================== -Fraction examples -==================================================================== + checkOperators(u:EXPR R):Void == + ops : L S := [name v for v in operators(u) | notSymbol?(v)] + if useNagFunctionsFlag then + fortranFunctions : L S := append(f77Functions,nagFunctions) + else + fortranFunctions : L S := f77Functions + extras : L S := setDifference(ops,fortranFunctions) + not empty? extras => + error("Non FORTRAN-77 functions detected:",[string(v) for v in extras]) + void() -The Fraction domain implements quotients. The elements must -belong to a domain of category IntegralDomain: multiplication -must be commutative and the product of two non-zero elements must not -be zero. This allows you to make fractions of most things you would -think of, but don't expect to create a fraction of two matrices! The -abbreviation for Fraction is FRAC. + checkForNagOperators(u:EXPR R):$ == + useNagFunctionsFlag => + import Pi + import PiCoercions(R) + piOp : BasicOperator := operator X01AAF + piSub : Equation EXPR R := + equation(pi()$Pi::EXPR(R),kernel(piOp,0::EXPR(R))$EXPR(R)) + subst(u,piSub) pretend $ + u pretend $ -Use / to create a fraction. + -- Conditional retractions: - a := 11/12 - 11 - -- - 12 - Type: Fraction Integer + if R has RetractableTo(Integer) then - b := 23/24 - 23 - -- - 24 - Type: Fraction Integer + retractIfCan(u:POLY Integer):Union($,"failed") == + retractIfCan((u::EXPR Integer)$EXPR(Integer))@Union($,"failed") -The standard arithmetic operations are available. + retract(u:POLY Integer):$ == + retract((u::EXPR Integer)$EXPR(Integer))@$ - 3 - a*b**2 + a + b/a - 313271 - ------ - 76032 - Type: Fraction Integer + retractIfCan(u:FRAC POLY Integer):Union($,"failed") == + retractIfCan((u::EXPR Integer)$EXPR(Integer))@Union($,"failed") -Extract the numerator and denominator by using numer and denom, -respectively. + retract(u:FRAC POLY Integer):$ == + retract((u::EXPR Integer)$EXPR(Integer))@$ - numer(a) - 11 - Type: PositiveInteger + int2R(u:Integer):R == u::R - denom(b) - 24 - Type: PositiveInteger + retractIfCan(u:EXPR Integer):Union($,"failed") == + retractIfCan(map(int2R,u)$EXF2(Integer,R))@Union($,"failed") -Operations like max, min, negative?, positive? and zero? -are all available if they are provided for the numerators and -denominators. + retract(u:EXPR Integer):$ == + retract(map(int2R,u)$EXF2(Integer,R))@$ -Don't expect a useful answer from factor, gcd or lcm if you apply -them to fractions. + if R has RetractableTo(Float) then - r := (x**2 + 2*x + 1)/(x**2 - 2*x + 1) - 2 - x + 2x + 1 - ----------- - 2 - x - 2x + 1 - Type: Fraction Polynomial Integer + retractIfCan(u:POLY Float):Union($,"failed") == + retractIfCan((u::EXPR Float)$EXPR(Float))@Union($,"failed") -Since all non-zero fractions are invertible, these operations have trivial -definitions. + retract(u:POLY Float):$ == + retract((u::EXPR Float)$EXPR(Float))@$ - factor(r) - 2 - x + 2x + 1 - ----------- - 2 - x - 2x + 1 - Type: Factored Fraction Polynomial Integer + retractIfCan(u:FRAC POLY Float):Union($,"failed") == + retractIfCan((u::EXPR Float)$EXPR(Float))@Union($,"failed") -Use map to apply factor to the numerator and denominator, which is -probably what you mean. + retract(u:FRAC POLY Float):$ == + retract((u::EXPR Float)$EXPR(Float))@$ - map(factor,r) - 2 - (x + 1) - -------- - 2 - (x - 1) - Type: Fraction Factored Polynomial Integer + float2R(u:Float):R == (u::R) -Other forms of fractions are available. Use continuedFraction to -create a continued fraction. + retractIfCan(u:EXPR Float):Union($,"failed") == + retractIfCan(map(float2R,u)$EXF2(Float,R))@Union($,"failed") - continuedFraction(7/12) - 1 | 1 | 1 | 1 | - +---+ + +---+ + +---+ + +---+ - | 1 | 1 | 2 | 2 - Type: ContinuedFraction Integer + retract(u:EXPR Float):$ == + retract(map(float2R,u)$EXF2(Float,R))@$ -Use partialFraction to create a partial fraction. + -- Exported Functions - partialFraction(7,12) - 3 1 - 1 - -- + - - 2 3 - 2 - Type: PartialFraction Integer + useNagFunctions():Boolean == useNagFunctionsFlag -Use conversion to create alternative views of fractions with objects -moved in and out of the numerator and denominator. + useNagFunctions(v:Boolean):Boolean == + old := useNagFunctionsFlag + useNagFunctionsFlag := v + old + + log10(x:$):$ == + kernel(operator log10,x) - g := 2/3 + 4/5*%i - 2 4 - - + - %i - 3 5 - Type: Complex Fraction Integer + pi():$ == kernel(operator X01AAF,0) - g :: FRAC COMPLEX INT - 10 + 12%i - --------- - 15 - Type: Fraction Complex Integer + coerce(u:$):EXPR R == u pretend EXPR(R) -See Also: -o )help ContinuedFraction -o )help PartialFraction -o )help Integer -o )show Fraction + retractIfCan(u:EXPR R):Union($,"failed") == + if (extraSymbols? u) then + m := fixUpSymbols(u) + m case "failed" => return "failed" + u := m::EXPR(R) + extraOperators? u => "failed" + checkForNagOperators(u) -\end{chunk} -\pagehead{Fraction}{FRAC} -\pagepic{ps/v103fraction.ps}{FRAC}{1.00} -{\bf See}\\ -\pageto{Localize}{LO} -\pageto{LocalAlgebra}{LA} + retract(u:EXPR R):$ == + u:=checkSymbols(u) + checkOperators(u) + checkForNagOperators(u) -{\bf Exports:}\\ -\begin{tabular}{lll} -\cross{FRAC}{0} & -\cross{FRAC}{1} & -\cross{FRAC}{abs} \\ -\cross{FRAC}{associates?} & -\cross{FRAC}{characteristic} & -\cross{FRAC}{charthRoot} \\ -\cross{FRAC}{ceiling} & -\cross{FRAC}{coerce} & -\cross{FRAC}{conditionP} \\ -\cross{FRAC}{convert} & -\cross{FRAC}{D} & -\cross{FRAC}{denom} \\ -\cross{FRAC}{denominator} & -\cross{FRAC}{differentiate} & -\cross{FRAC}{divide} \\ -\cross{FRAC}{euclideanSize} & -\cross{FRAC}{eval} & -\cross{FRAC}{expressIdealMember} \\ -\cross{FRAC}{exquo} & -\cross{FRAC}{extendedEuclidean} & -\cross{FRAC}{factor} \\ -\cross{FRAC}{factorPolynomial} & -\cross{FRAC}{factorSquareFreePolynomial} & -\cross{FRAC}{floor} \\ -\cross{FRAC}{fractionPart} & -\cross{FRAC}{gcd} & -\cross{FRAC}{gcdPolynomial} \\ -\cross{FRAC}{hash} & -\cross{FRAC}{init} & -\cross{FRAC}{inv} \\ -\cross{FRAC}{latex} & -\cross{FRAC}{lcm} & -\cross{FRAC}{map} \\ -\cross{FRAC}{max} & -\cross{FRAC}{min} & -\cross{FRAC}{multiEuclidean} \\ -\cross{FRAC}{negative?} & -\cross{FRAC}{nextItem} & -\cross{FRAC}{numer} \\ -\cross{FRAC}{numerator} & -\cross{FRAC}{OMwrite} & -\cross{FRAC}{one?} \\ -\cross{FRAC}{patternMatch} & -\cross{FRAC}{positive?} & -\cross{FRAC}{prime?} \\ -\cross{FRAC}{principalIdeal} & -\cross{FRAC}{random} & -\cross{FRAC}{recip} \\ -\cross{FRAC}{reducedSystem} & -\cross{FRAC}{retract} & -\cross{FRAC}{retractIfCan} \\ -\cross{FRAC}{sample} & -\cross{FRAC}{sign} & -\cross{FRAC}{sizeLess?} \\ -\cross{FRAC}{solveLinearPolynomialEquation} & -\cross{FRAC}{squareFree} & -\cross{FRAC}{squareFreePart} \\ -\cross{FRAC}{squareFreePolynomial} & -\cross{FRAC}{subtractIfCan} & -\cross{FRAC}{unit?} \\ -\cross{FRAC}{unitCanonical} & -\cross{FRAC}{unitNormal} & -\cross{FRAC}{wholePart} \\ -\cross{FRAC}{zero?} & -\cross{FRAC}{?*?} & -\cross{FRAC}{?**?} \\ -\cross{FRAC}{?+?} & -\cross{FRAC}{?-?} & -\cross{FRAC}{-?} \\ -\cross{FRAC}{?/?} & -\cross{FRAC}{?=?} & -\cross{FRAC}{?\^{}?} \\ -\cross{FRAC}{?\~{}=?} & -\cross{FRAC}{?$<$?} & -\cross{FRAC}{?$<=$?} \\ -\cross{FRAC}{?$>$?} & -\cross{FRAC}{?$>=$?} & -\cross{FRAC}{?.?} \\ -\cross{FRAC}{?quo?} & -\cross{FRAC}{?rem?} & -\end{tabular} + retractIfCan(u:Symbol):Union($,"failed") == + not (member?(u,basicSymbols) or + scripted?(u) and member?(name u,subscriptedSymbols)) => "failed" + (((u::EXPR(R))$(EXPR R))pretend Rep)::$ -\begin{chunk}{domain FRAC Fraction} -)abbrev domain FRAC Fraction -++ Author: Mark Botch -++ Date Last Updated: 12 February 1992 -++ Basic Functions: Field, numer, denom -++ Description: -++ Fraction takes an IntegralDomain S and produces -++ the domain of Fractions with numerators and denominators from S. -++ If S is also a GcdDomain, then gcd's between numerator and -++ denominator will be cancelled during all operations. + retract(u:Symbol):$ == + res : Union($,"failed") := retractIfCan(u) + res case "failed" => error("Illegal Symbol Detected:",u::String) + res::$ -Fraction(S: IntegralDomain): QuotientFieldCategory S with - if S has IntegerNumberSystem and S has OpenMath then OpenMath - if S has canonical and S has GcdDomain and S has canonicalUnitNormal - then canonical - ++ \spad{canonical} means that equal elements are in fact identical. - == LocalAlgebra(S, S, S) add - Rep:= Record(num:S, den:S) - coerce(d:S):% == [d,1] - zero?(x:%) == zero? x.num +\end{chunk} +\begin{chunk}{COQ FEXPR} +(* domain FEXPR *) +(* + EXPR R add - if S has GcdDomain and S has canonicalUnitNormal then - retract(x:%):S == --- one?(x.den) => x.num - ((x.den) = 1) => x.num - error "Denominator not equal to 1" + -- The standard FORTRAN-77 intrinsic functions, plus nthRoot which + -- can be translated into an arithmetic expression: + f77Functions : L S := [abs,sqrt,exp,log,log10,sin,cos,tan,asin,acos, + atan,sinh,cosh,tanh,nthRoot,%power] - retractIfCan(x:%):Union(S, "failed") == --- one?(x.den) => x.num - ((x.den) = 1) => x.num - "failed" - else - retract(x:%):S == - (a:= x.num exquo x.den) case "failed" => - error "Denominator not equal to 1" - a - retractIfCan(x:%):Union(S,"failed") == x.num exquo x.den + nagFunctions : L S := [pi, X01AAF] - if S has EuclideanDomain then - wholePart x == --- one?(x.den) => x.num - ((x.den) = 1) => x.num - x.num quo x.den + useNagFunctionsFlag : Boolean := true - if S has IntegerNumberSystem then + -- Local functions to check for "unassigned" symbols etc. - floor x == --- one?(x.den) => x.num - ((x.den) = 1) => x.num - x < 0 => -ceiling(-x) - wholePart x + mkEqn(s1:Symbol,s2:Symbol):Equation EXPR(R) == + equation(s2::EXPR(R),script(s1,scripts(s2))::EXPR(R)) - ceiling x == --- one?(x.den) => x.num - ((x.den) = 1) => x.num - x < 0 => -floor(-x) - 1 + wholePart x + fixUpSymbols(u:EXPR R):Union(EXPR R,"failed") == + -- If its a univariate expression then just fix it up: + syms : L S := variables(u) + (#basicSymbols = 1) and zero?(#subscriptedSymbols) => + not (#syms = 1) => "failed" + subst(u,equation(first(syms)::EXPR(R),first(basicSymbols)::EXPR(R))) + -- We have one variable but it is subscripted: + zero?(#basicSymbols) and (#subscriptedSymbols = 1) => + -- Make sure we don't have both X and X_i + for s in syms repeat + not scripted?(s) => return "failed" + not ((#(syms:=removeDuplicates! [name(s) for s in syms]))=1)=> "failed" + sym : Symbol := first subscriptedSymbols + subst(u,[mkEqn(sym,i) for i in variables(u)]) + "failed" - if S has OpenMath then - -- TODO: somwhere this file does something which redefines the division - -- operator. Doh! + extraSymbols?(u:EXPR R):Boolean == + syms : L S := [name(v) for v in variables(u)] + extras : L S := setDifference(syms, + setUnion(basicSymbols,subscriptedSymbols)) + not empty? extras - writeOMFrac(dev: OpenMathDevice, x: %): Void == - OMputApp(dev) - OMputSymbol(dev, "nums1", "rational") - OMwrite(dev, x.num, false) - OMwrite(dev, x.den, false) - OMputEndApp(dev) + checkSymbols(u:EXPR R):EXPR(R) == + syms : L S := [name(v) for v in variables(u)] + extras : L S := setDifference(syms, + setUnion(basicSymbols,subscriptedSymbols)) + not empty? extras => + m := fixUpSymbols(u) + m case EXPR(R) => m::EXPR(R) + error("Extra symbols detected:",[string(v) for v in extras]$L(String)) + u - OMwrite(x: %): String == - s: String := "" - sp := OM_-STRINGTOSTRINGPTR(s)$Lisp - dev: OpenMathDevice := OMopenString(sp pretend String, OMencodingXML) - OMputObject(dev) - writeOMFrac(dev, x) - OMputEndObject(dev) - OMclose(dev) - s := OM_-STRINGPTRTOSTRING(sp)$Lisp pretend String - s + notSymbol?(v:BO):Boolean == + s : S := name v + member?(s,basicSymbols) or + scripted?(s) and member?(name s,subscriptedSymbols) => false + true - OMwrite(x: %, wholeObj: Boolean): String == - s: String := "" - sp := OM_-STRINGTOSTRINGPTR(s)$Lisp - dev: OpenMathDevice := OMopenString(sp pretend String, OMencodingXML) - if wholeObj then - OMputObject(dev) - writeOMFrac(dev, x) - if wholeObj then - OMputEndObject(dev) - OMclose(dev) - s := OM_-STRINGPTRTOSTRING(sp)$Lisp pretend String - s + extraOperators?(u:EXPR R):Boolean == + ops : L S := [name v for v in operators(u) | notSymbol?(v)] + if useNagFunctionsFlag then + fortranFunctions : L S := append(f77Functions,nagFunctions) + else + fortranFunctions : L S := f77Functions + extras : L S := setDifference(ops,fortranFunctions) + not empty? extras - OMwrite(dev: OpenMathDevice, x: %): Void == - OMputObject(dev) - writeOMFrac(dev, x) - OMputEndObject(dev) + checkOperators(u:EXPR R):Void == + ops : L S := [name v for v in operators(u) | notSymbol?(v)] + if useNagFunctionsFlag then + fortranFunctions : L S := append(f77Functions,nagFunctions) + else + fortranFunctions : L S := f77Functions + extras : L S := setDifference(ops,fortranFunctions) + not empty? extras => + error("Non FORTRAN-77 functions detected:",[string(v) for v in extras]) + void() - OMwrite(dev: OpenMathDevice, x: %, wholeObj: Boolean): Void == - if wholeObj then - OMputObject(dev) - writeOMFrac(dev, x) - if wholeObj then - OMputEndObject(dev) + checkForNagOperators(u:EXPR R):$ == + useNagFunctionsFlag => + import Pi + import PiCoercions(R) + piOp : BasicOperator := operator X01AAF + piSub : Equation EXPR R := + equation(pi()$Pi::EXPR(R),kernel(piOp,0::EXPR(R))$EXPR(R)) + subst(u,piSub) pretend $ + u pretend $ - if S has GcdDomain then - cancelGcd: % -> S - normalize: % -> % + -- Conditional retractions: - normalize x == - zero?(x.num) => 0 --- one?(x.den) => x - ((x.den) = 1) => x - uca := unitNormal(x.den) - zero?(x.den := uca.canonical) => error "division by zero" - x.num := x.num * uca.associate - x + if R has RetractableTo(Integer) then - recip x == - zero?(x.num) => "failed" - normalize [x.den, x.num] + retractIfCan(u:POLY Integer):Union($,"failed") == + retractIfCan((u::EXPR Integer)$EXPR(Integer))@Union($,"failed") - cancelGcd x == --- one?(x.den) => x.den - ((x.den) = 1) => x.den - d := gcd(x.num, x.den) - xn := x.num exquo d - xn case "failed" => - error "gcd not gcd in QF cancelGcd (numerator)" - xd := x.den exquo d - xd case "failed" => - error "gcd not gcd in QF cancelGcd (denominator)" - x.num := xn :: S - x.den := xd :: S - d + retract(u:POLY Integer):$ == + retract((u::EXPR Integer)$EXPR(Integer))@$ - nn:S / dd:S == - zero? dd => error "division by zero" - cancelGcd(z := [nn, dd]) - normalize z + retractIfCan(u:FRAC POLY Integer):Union($,"failed") == + retractIfCan((u::EXPR Integer)$EXPR(Integer))@Union($,"failed") - x + y == - zero? y => x - zero? x => y - z := [x.den,y.den] - d := cancelGcd z - g := [z.den * x.num + z.num * y.num, d] - cancelGcd g - g.den := g.den * z.num * z.den - normalize g + retract(u:FRAC POLY Integer):$ == + retract((u::EXPR Integer)$EXPR(Integer))@$ - -- We can not rely on the defaulting mechanism - -- to supply a definition for -, even though this - -- definition would do, for thefollowing reasons: - -- 1) The user could have defined a subtraction - -- in Localize, which would not work for - -- QuotientField; - -- 2) even if he doesn't, the system currently - -- places a default definition in Localize, - -- which uses Localize's +, which does not - -- cancel gcds - x - y == - zero? y => x - z := [x.den, y.den] - d := cancelGcd z - g := [z.den * x.num - z.num * y.num, d] - cancelGcd g - g.den := g.den * z.num * z.den - normalize g + int2R(u:Integer):R == u::R - x:% * y:% == - zero? x or zero? y => 0 --- one? x => y - (x = 1) => y --- one? y => x - (y = 1) => x - (x, y) := ([x.num, y.den], [y.num, x.den]) - cancelGcd x; cancelGcd y; - normalize [x.num * y.num, x.den * y.den] + retractIfCan(u:EXPR Integer):Union($,"failed") == + retractIfCan(map(int2R,u)$EXF2(Integer,R))@Union($,"failed") - n:Integer * x:% == - y := [n::S, x.den] - cancelGcd y - normalize [x.num * y.num, y.den] + retract(u:EXPR Integer):$ == + retract(map(int2R,u)$EXF2(Integer,R))@$ - nn:S * x:% == - y := [nn, x.den] - cancelGcd y - normalize [x.num * y.num, y.den] + if R has RetractableTo(Float) then - differentiate(x:%, deriv:S -> S) == - y := [deriv(x.den), x.den] - d := cancelGcd(y) - y.num := deriv(x.num) * y.den - x.num * y.num - (d, y.den) := (y.den, d) - cancelGcd y - y.den := y.den * d * d - normalize y + retractIfCan(u:POLY Float):Union($,"failed") == + retractIfCan((u::EXPR Float)$EXPR(Float))@Union($,"failed") - if S has canonicalUnitNormal then - x = y == (x.num = y.num) and (x.den = y.den) - --x / dd == (cancelGcd (z:=[x.num,dd*x.den]); normalize z) + retract(u:POLY Float):$ == + retract((u::EXPR Float)$EXPR(Float))@$ --- one? x == one? (x.num) and one? (x.den) - one? x == ((x.num) = 1) and ((x.den) = 1) - -- again assuming canonical nature of representation + retractIfCan(u:FRAC POLY Float):Union($,"failed") == + retractIfCan((u::EXPR Float)$EXPR(Float))@Union($,"failed") - else - nn:S/dd:S == if zero? dd then error "division by zero" else [nn,dd] + retract(u:FRAC POLY Float):$ == + retract((u::EXPR Float)$EXPR(Float))@$ - recip x == - zero?(x.num) => "failed" - [x.den, x.num] + float2R(u:Float):R == (u::R) - if (S has RetractableTo Fraction Integer) then - retract(x:%):Fraction(Integer) == retract(retract(x)@S) + retractIfCan(u:EXPR Float):Union($,"failed") == + retractIfCan(map(float2R,u)$EXF2(Float,R))@Union($,"failed") - retractIfCan(x:%):Union(Fraction Integer, "failed") == - (u := retractIfCan(x)@Union(S, "failed")) case "failed" => "failed" - retractIfCan(u::S) + retract(u:EXPR Float):$ == + retract(map(float2R,u)$EXF2(Float,R))@$ - else if (S has RetractableTo Integer) then - retract(x:%):Fraction(Integer) == - retract(numer x) / retract(denom x) + -- Exported Functions - retractIfCan(x:%):Union(Fraction Integer, "failed") == - (n := retractIfCan numer x) case "failed" => "failed" - (d := retractIfCan denom x) case "failed" => "failed" - (n::Integer) / (d::Integer) + useNagFunctions():Boolean == useNagFunctionsFlag - QFP ==> SparseUnivariatePolynomial % - DP ==> SparseUnivariatePolynomial S - import UnivariatePolynomialCategoryFunctions2(%,QFP,S,DP) - import UnivariatePolynomialCategoryFunctions2(S,DP,%,QFP) + useNagFunctions(v:Boolean):Boolean == + old := useNagFunctionsFlag + useNagFunctionsFlag := v + old + + log10(x:$):$ == + kernel(operator log10,x) - if S has GcdDomain then - gcdPolynomial(pp,qq) == - zero? pp => qq - zero? qq => pp - zero? degree pp or zero? degree qq => 1 - denpp:="lcm"/[denom u for u in coefficients pp] - ppD:DP:=map(x+->retract(x*denpp),pp) - denqq:="lcm"/[denom u for u in coefficients qq] - qqD:DP:=map(x+->retract(x*denqq),qq) - g:=gcdPolynomial(ppD,qqD) - zero? degree g => 1 --- one? (lc:=leadingCoefficient g) => map(#1::%,g) - ((lc:=leadingCoefficient g) = 1) => map(x+->x::%,g) - map(x+->x/lc,g) + pi():$ == kernel(operator X01AAF,0) - if (S has PolynomialFactorizationExplicit) then - -- we'll let the solveLinearPolynomialEquations operator - -- default from Field - pp,qq: QFP - lpp: List QFP - import Factored SparseUnivariatePolynomial % - if S has CharacteristicNonZero then - if S has canonicalUnitNormal and S has GcdDomain then - charthRoot x == - n:= charthRoot x.num - n case "failed" => "failed" - d:=charthRoot x.den - d case "failed" => "failed" - n/d - else - charthRoot x == - -- to find x = p-th root of n/d - -- observe that xd is p-th root of n*d**(p-1) - ans:=charthRoot(x.num * - (x.den)**(characteristic()$%-1)::NonNegativeInteger) - ans case "failed" => "failed" - ans / x.den - clear: List % -> List S - clear l == - d:="lcm"/[x.den for x in l] - [ x.num * (d exquo x.den)::S for x in l] - mat: Matrix % - conditionP mat == - matD: Matrix S - matD:= matrix [ clear l for l in listOfLists mat ] - ansD := conditionP matD - ansD case "failed" => "failed" - ansDD:=ansD :: Vector(S) - [ ansDD(i)::% for i in 1..#ansDD]$Vector(%) + coerce(u:$):EXPR R == u pretend EXPR(R) - factorPolynomial(pp) == - zero? pp => 0 - denpp:="lcm"/[denom u for u in coefficients pp] - ppD:DP:=map(x+->retract(x*denpp),pp) - ff:=factorPolynomial ppD - den1:%:=denpp::% - lfact:List Record(flg:Union("nil", "sqfr", "irred", "prime"), - fctr:QFP, xpnt:Integer) - lfact:= [[w.flg, - if leadingCoefficient w.fctr =1 then - map(x+->x::%,w.fctr) - else (lc:=(leadingCoefficient w.fctr)::%; - den1:=den1/lc**w.xpnt; - map(x+->x::%/lc,w.fctr)), - w.xpnt] for w in factorList ff] - makeFR(map(x+->x::%/den1,unit(ff)),lfact) - factorSquareFreePolynomial(pp) == - zero? pp => 0 - degree pp = 0 => makeFR(pp,empty()) - lcpp:=leadingCoefficient pp - pp:=pp/lcpp - denpp:="lcm"/[denom u for u in coefficients pp] - ppD:DP:=map(x+->retract(x*denpp),pp) - ff:=factorSquareFreePolynomial ppD - den1:%:=denpp::%/lcpp - lfact:List Record(flg:Union("nil", "sqfr", "irred", "prime"), - fctr:QFP, xpnt:Integer) - lfact:= [[w.flg, - if leadingCoefficient w.fctr =1 then - map(x+->x::%,w.fctr) - else (lc:=(leadingCoefficient w.fctr)::%; - den1:=den1/lc**w.xpnt; - map(x+->x::%/lc,w.fctr)), - w.xpnt] for w in factorList ff] - makeFR(map(x+->x::%/den1,unit(ff)),lfact) + retractIfCan(u:EXPR R):Union($,"failed") == + if (extraSymbols? u) then + m := fixUpSymbols(u) + m case "failed" => return "failed" + u := m::EXPR(R) + extraOperators? u => "failed" + checkForNagOperators(u) -\end{chunk} + retract(u:EXPR R):$ == + u:=checkSymbols(u) + checkOperators(u) + checkForNagOperators(u) + + retractIfCan(u:Symbol):Union($,"failed") == + not (member?(u,basicSymbols) or + scripted?(u) and member?(name u,subscriptedSymbols)) => "failed" + (((u::EXPR(R))$(EXPR R))pretend Rep)::$ + + retract(u:Symbol):$ == + res : Union($,"failed") := retractIfCan(u) + res case "failed" => error("Illegal Symbol Detected:",u::String) + res::$ -\begin{chunk}{COQ FRAC} -(* domain FRAC *) -(* *) \end{chunk} -\begin{chunk}{FRAC.dotabb} -"FRAC" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FRAC"] -"PFECAT" [color="#4488FF",href="bookvol10.2.pdf#nameddest=PFECAT"] -"FRAC" -> "PFECAT" +\begin{chunk}{FEXPR.dotabb} +"FEXPR" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FEXPR"] +"ALIST" [color="#88FF44",href="bookvol10.3.pdf#nameddest=ALIST"] +"FEXPR" -> "ALIST" \end{chunk} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain FRIDEAL FractionalIdeal} +\section{domain FORTRAN FortranProgram} -\begin{chunk}{FractionalIdeal.input} +\begin{chunk}{FortranProgram.input} )set break resume -)sys rm -f FractionalIdeal.output -)spool FractionalIdeal.output +)sys rm -f FortranProgram.output +)spool FortranProgram.output )set message test on )set message auto off )clear all --S 1 of 1 -)show FractionalIdeal +)show FortranProgram --R ---R FractionalIdeal(R: EuclideanDomain,F: QuotientFieldCategory(R),UP: UnivariatePolynomialCategory(F),A: Join(FramedAlgebra(F,UP),RetractableTo(F))) is a domain constructor ---R Abbreviation for FractionalIdeal is FRIDEAL ---R This constructor is not exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for FRIDEAL +--R FortranProgram(name: Symbol,returnType: Union(fst: FortranScalarType,void: void),arguments: List(Symbol),symbols: SymbolTable) is a domain constructor +--R Abbreviation for FortranProgram is FORTRAN +--R This constructor is exposed in this frame. +--R Issue )edit bookvol10.3.pamphlet to see algebra source code for FORTRAN --R --R------------------------------- Operations -------------------------------- ---R ?*? : (%,%) -> % ?**? : (%,Integer) -> % ---R ?**? : (%,NonNegativeInteger) -> % ?**? : (%,PositiveInteger) -> % ---R ?/? : (%,%) -> % ?=? : (%,%) -> Boolean ---R 1 : () -> % ?^? : (%,Integer) -> % ---R ?^? : (%,NonNegativeInteger) -> % ?^? : (%,PositiveInteger) -> % ---R basis : % -> Vector(A) coerce : % -> OutputForm ---R commutator : (%,%) -> % conjugate : (%,%) -> % ---R denom : % -> R hash : % -> SingleInteger ---R ideal : Vector(A) -> % inv : % -> % ---R latex : % -> String minimize : % -> % ---R norm : % -> F numer : % -> Vector(A) ---R one? : % -> Boolean recip : % -> Union(%,"failed") ---R sample : () -> % ?~=? : (%,%) -> Boolean ---R randomLC : (NonNegativeInteger,Vector(A)) -> A +--R coerce : Expression(Float) -> % coerce : Expression(Integer) -> % +--R coerce : List(FortranCode) -> % coerce : FortranCode -> % +--R coerce : % -> OutputForm outputAsFortran : % -> Void +--R coerce : Equation(Expression(Complex(Float))) -> % +--R coerce : Equation(Expression(Float)) -> % +--R coerce : Equation(Expression(Integer)) -> % +--R coerce : Expression(Complex(Float)) -> % +--R coerce : Equation(Expression(MachineComplex)) -> % +--R coerce : Equation(Expression(MachineFloat)) -> % +--R coerce : Equation(Expression(MachineInteger)) -> % +--R coerce : Expression(MachineComplex) -> % +--R coerce : Expression(MachineFloat) -> % +--R coerce : Expression(MachineInteger) -> % +--R coerce : Record(localSymbols: SymbolTable,code: List(FortranCode)) -> % --R --E 1 )spool )lisp (bye) \end{chunk} -\begin{chunk}{FractionalIdeal.help} +\begin{chunk}{FortranProgram.help} ==================================================================== -FractionalIdeal examples +FortranProgram examples ==================================================================== -Fractional ideals in a framed algebra. +FortranProgram allows the user to build and manipulate simple models of +FORTRAN subprograms. These can then be transformed into actual FORTRAN +notation. See Also: -o )show FractionalIdeal +o )show FortranProgram \end{chunk} -\pagehead{FractionalIdeal}{FRIDEAL} -\pagepic{ps/v103fractionalideal.ps}{FRIDEAL}{1.00} +\pagehead{FortranProgram}{FORTRAN} +\pagepic{ps/v103fortranprogram.ps}{FORTRAN}{1.00} {\bf See}\\ -\pageto{FramedModule}{FRMOD} -\pageto{HyperellipticFiniteDivisor}{HELLFDIV} -\pageto{FiniteDivisor}{FDIV} +\pageto{Result}{RESULT} +\pageto{FortranCode}{FC} +\pageto{ThreeDimensionalMatrix}{M3D} +\pageto{SimpleFortranProgram}{SFORT} +\pageto{Switch}{SWITCH} +\pageto{FortranTemplate}{FTEM} +\pageto{FortranExpression}{FEXPR} {\bf Exports:}\\ -\begin{tabular}{lllll} -\cross{FRIDEAL}{1} & -\cross{FRIDEAL}{basis} & -\cross{FRIDEAL}{coerce} & -\cross{FRIDEAL}{commutator} & -\cross{FRIDEAL}{conjugate} \\ -\cross{FRIDEAL}{denom} & -\cross{FRIDEAL}{hash} & -\cross{FRIDEAL}{ideal} & -\cross{FRIDEAL}{inv} & -\cross{FRIDEAL}{latex} \\ -\cross{FRIDEAL}{minimize} & -\cross{FRIDEAL}{norm} & -\cross{FRIDEAL}{numer} & -\cross{FRIDEAL}{one?} & -\cross{FRIDEAL}{randomLC} \\ -\cross{FRIDEAL}{recip} & -\cross{FRIDEAL}{sample} & -\cross{FRIDEAL}{?\~{}=?} & -\cross{FRIDEAL}{?**?} & -\cross{FRIDEAL}{?\^{}?} \\ -\cross{FRIDEAL}{?*?} & -\cross{FRIDEAL}{?**?} & -\cross{FRIDEAL}{?/?} & -\cross{FRIDEAL}{?=?} & -\cross{FRIDEAL}{?\^{}?} +\begin{tabular}{ll} +\cross{FORTRAN}{coerce} & +\cross{FORTRAN}{outputAsFortran} \end{tabular} -\begin{chunk}{domain FRIDEAL FractionalIdeal} -)abbrev domain FRIDEAL FractionalIdeal -++ Author: Manuel Bronstein -++ Date Created: 27 Jan 1989 -++ Date Last Updated: 30 July 1993 +\begin{chunk}{domain FORTRAN FortranProgram} +)abbrev domain FORTRAN FortranProgram +++ Author: Mike Dewar +++ Date Created: October 1992 +++ Date Last Updated: 23 January 1995 Added support for intrinsic functions ++ Description: -++ Fractional ideals in a framed algebra. - -FractionalIdeal(R, F, UP, A): Exports == Implementation where - R : EuclideanDomain - F : QuotientFieldCategory R - UP: UnivariatePolynomialCategory F - A : Join(FramedAlgebra(F, UP), RetractableTo F) - - VF ==> Vector F - VA ==> Vector A - UPA ==> SparseUnivariatePolynomial A - QF ==> Fraction UP +++ \axiomType{FortranProgram} allows the user to build and manipulate simple +++ models of FORTRAN subprograms. These can then be transformed into +++ actual FORTRAN notation. - Exports ==> Group with - ideal : VA -> % - ++ ideal([f1,...,fn]) returns the ideal \spad{(f1,...,fn)}. - basis : % -> VA - ++ basis((f1,...,fn)) returns the vector \spad{[f1,...,fn]}. - norm : % -> F - ++ norm(I) returns the norm of the ideal I. - numer : % -> VA - ++ numer(1/d * (f1,...,fn)) = the vector \spad{[f1,...,fn]}. - denom : % -> R - ++ denom(1/d * (f1,...,fn)) returns d. - minimize: % -> % - ++ minimize(I) returns a reduced set of generators for \spad{I}. - randomLC: (NonNegativeInteger, VA) -> A - ++ randomLC(n,x) should be local but conditional. +FortranProgram(name,returnType,arguments,symbols): Exports == Implement where + name : Symbol + returnType : Union(fst:FortranScalarType,void:"void") + arguments : List Symbol + symbols : SymbolTable - Implementation ==> add - import CommonDenominator(R, F, VF) - import MatrixCommonDenominator(UP, QF) - import InnerCommonDenominator(R, F, List R, List F) - import MatrixCategoryFunctions2(F, Vector F, Vector F, Matrix F, - UP, Vector UP, Vector UP, Matrix UP) - import MatrixCategoryFunctions2(UP, Vector UP, Vector UP, - Matrix UP, F, Vector F, Vector F, Matrix F) - import MatrixCategoryFunctions2(UP, Vector UP, Vector UP, - Matrix UP, QF, Vector QF, Vector QF, Matrix QF) + FC ==> FortranCode + EXPR ==> Expression + INT ==> Integer + CMPX ==> Complex + MINT ==> MachineInteger + MFLOAT ==> MachineFloat + MCMPLX ==> MachineComplex + REP ==> Record(localSymbols : SymbolTable, code : List FortranCode) - Rep := Record(num:VA, den:R) + Exports ==> FortranProgramCategory with + coerce : FortranCode -> $ + ++ coerce(fc) is not documented + coerce : List FortranCode -> $ + ++ coerce(lfc) is not documented + coerce : REP -> $ + ++ coerce(r) is not documented + coerce : EXPR MINT -> $ + ++ coerce(e) is not documented + coerce : EXPR MFLOAT -> $ + ++ coerce(e) is not documented + coerce : EXPR MCMPLX -> $ + ++ coerce(e) is not documented + coerce : Equation EXPR MINT -> $ + ++ coerce(eq) is not documented + coerce : Equation EXPR MFLOAT -> $ + ++ coerce(eq) is not documented + coerce : Equation EXPR MCMPLX -> $ + ++ coerce(eq) is not documented + coerce : EXPR INT -> $ + ++ coerce(e) is not documented + coerce : EXPR Float -> $ + ++ coerce(e) is not documented + coerce : EXPR CMPX Float -> $ + ++ coerce(e) is not documented + coerce : Equation EXPR INT -> $ + ++ coerce(eq) is not documented + coerce : Equation EXPR Float -> $ + ++ coerce(eq) is not documented + coerce : Equation EXPR CMPX Float -> $ + ++ coerce(eq) is not documented - poly : % -> UPA - invrep : Matrix F -> A - upmat : (A, NonNegativeInteger) -> Matrix UP - summat : % -> Matrix UP - num2O : VA -> OutputForm - agcd : List A -> R - vgcd : VF -> R - mkIdeal : (VA, R) -> % - intIdeal: (List A, R) -> % - ret? : VA -> Boolean - tryRange: (NonNegativeInteger, VA, R, %) -> Union(%, "failed") + Implement ==> add - 1 == [[1]$VA, 1] - numer i == i.num - denom i == i.den - mkIdeal(v, d) == [v, d] - invrep m == represents(transpose(m) * coordinates(1$A)) - upmat(x, i) == map(s +-> monomial(s, i)$UP, regularRepresentation x) - ret? v == any?(s+->retractIfCan(s)@Union(F,"failed") case F, v) - x = y == denom(x) = denom(y) and numer(x) = numer(y) - agcd l == reduce("gcd", [vgcd coordinates a for a in l]$List(R), 0) + Rep := REP - norm i == - ("gcd"/[retract(u)@R for u in coefficients determinant summat i]) - / denom(i) ** rank()$A + import SExpression + import TheSymbolTable + import FortranCode - tryRange(range, nm, nrm, i) == - for j in 0..10 repeat - a := randomLC(10 * range, nm) - unit? gcd((retract(norm a)@R exquo nrm)::R, nrm) => - return intIdeal([nrm::F::A, a], denom i) - "failed" + makeRep(b:List FortranCode):$ == + construct(empty()$SymbolTable,b)$REP - summat i == - m := minIndex(v := numer i) - reduce("+", - [upmat(qelt(v, j + m), j) for j in 0..#v-1]$List(Matrix UP)) + codeFrom(u:$):List FortranCode == + elt(u::Rep,code)$REP - inv i == - m := inverse(map(s+->s::QF, summat i))::Matrix(QF) - cd := splitDenominator(denom(i)::F::UP::QF * m) - cd2 := splitDenominator coefficients(cd.den) - invd:= cd2.den / reduce("gcd", cd2.num) - d := reduce("max", [degree p for p in parts(cd.num)]) - ideal - [invd * invrep map(s+->coefficient(s, j), cd.num) for j in 0..d]$VA + outputAsFortran(p:$):Void == + setLabelValue(25000::SingleInteger)$FC + -- Do this first to catch any extra type declarations: + tempName := "FPTEMP"::Symbol + newSubProgram(tempName) + initialiseIntrinsicList()$Lisp + body : List SExpression := [getCode(l)$FortranCode for l in codeFrom(p)] + intrinsics : SExpression := getIntrinsicList()$Lisp + endSubProgram() + fortFormatHead(returnType::OutputForm, name::OutputForm, _ + arguments::OutputForm)$Lisp + printTypes(symbols)$SymbolTable + printTypes((p::Rep).localSymbols)$SymbolTable + printTypes(tempName)$TheSymbolTable + fortFormatIntrinsics(intrinsics)$Lisp + clearTheSymbolTable(tempName) + for expr in body repeat displayLines1(expr)$Lisp + dispStatement(END::OutputForm)$Lisp + void()$Void - ideal v == - d := reduce("lcm", [commonDenominator coordinates qelt(v, i) - for i in minIndex v .. maxIndex v]$List(R)) - intIdeal([d::F * qelt(v, i) for i in minIndex v .. maxIndex v], d) + mkString(l:List Symbol):String == + unparse(convert(l::OutputForm)@InputForm)$InputForm - intIdeal(l, d) == - lr := empty()$List(R) - nr := empty()$List(A) - for x in removeDuplicates l repeat - if (u := retractIfCan(x)@Union(F, "failed")) case F - then lr := concat(retract(u::F)@R, lr) - else nr := concat(x, nr) - r := reduce("gcd", lr, 0) - g := agcd nr - a := (r quo (b := gcd(gcd(d, r), g)))::F::A - d := d quo b - r ^= 0 and ((g exquo r) case R) => mkIdeal([a], d) - invb := inv(b::F) - va:VA := [invb * m for m in nr] - zero? a => mkIdeal(va, d) - mkIdeal(concat(a, va), d) + checkVariables(user:List Symbol,target:List Symbol):Void == + -- We don't worry about whether the user has subscripted the + -- variables or not. + setDifference(map(name$Symbol,user),target) ^= empty()$List(Symbol) => + s1 : String := mkString(user) + s2 : String := mkString(target) + error ["Incompatible variable lists:", s1, s2] + void()$Void - vgcd v == - reduce("gcd", - [retract(v.i)@R for i in minIndex v .. maxIndex v]$List(R)) + coerce(u:EXPR MINT) : $ == + checkVariables(variables(u)$EXPR(MINT),arguments) + l : List(FC) := [assign(name,u)$FC,returns()$FC] + makeRep l - poly i == - m := minIndex(v := numer i) - +/[monomial(qelt(v, i + m), i) for i in 0..#v-1] + coerce(u:Equation EXPR MINT) : $ == + retractIfCan(lhs u)@Union(Kernel(EXPR MINT),"failed") case "failed" => + error "left hand side is not a kernel" + vList : List Symbol := variables lhs u + #vList ^= #arguments => + error "Incorrect number of arguments" + veList : List EXPR MINT := [w::EXPR(MINT) for w in vList] + aeList : List EXPR MINT := [w::EXPR(MINT) for w in arguments] + eList : List Equation EXPR MINT := + [equation(w,v) for w in veList for v in aeList] + (subst(rhs u,eList))::$ - i1 * i2 == - intIdeal(coefficients(poly i1 * poly i2), denom i1 * denom i2) + coerce(u:EXPR MFLOAT) : $ == + checkVariables(variables(u)$EXPR(MFLOAT),arguments) + l : List(FC) := [assign(name,u)$FC,returns()$FC] + makeRep l - i:$ ** m:Integer == - m < 0 => inv(i) ** (-m) - n := m::NonNegativeInteger - v := numer i - intIdeal([qelt(v, j) ** n for j in minIndex v .. maxIndex v], - denom(i) ** n) + coerce(u:Equation EXPR MFLOAT) : $ == + retractIfCan(lhs u)@Union(Kernel(EXPR MFLOAT),"failed") case "failed" => + error "left hand side is not a kernel" + vList : List Symbol := variables lhs u + #vList ^= #arguments => + error "Incorrect number of arguments" + veList : List EXPR MFLOAT := [w::EXPR(MFLOAT) for w in vList] + aeList : List EXPR MFLOAT := [w::EXPR(MFLOAT) for w in arguments] + eList : List Equation EXPR MFLOAT := + [equation(w,v) for w in veList for v in aeList] + (subst(rhs u,eList))::$ - num2O v == - paren [qelt(v, i)::OutputForm - for i in minIndex v .. maxIndex v]$List(OutputForm) + coerce(u:EXPR MCMPLX) : $ == + checkVariables(variables(u)$EXPR(MCMPLX),arguments) + l : List(FC) := [assign(name,u)$FC,returns()$FC] + makeRep l - basis i == - v := numer i - d := inv(denom(i)::F) - [d * qelt(v, j) for j in minIndex v .. maxIndex v] + coerce(u:Equation EXPR MCMPLX) : $ == + retractIfCan(lhs u)@Union(Kernel EXPR MCMPLX,"failed") case "failed"=> + error "left hand side is not a kernel" + vList : List Symbol := variables lhs u + #vList ^= #arguments => + error "Incorrect number of arguments" + veList : List EXPR MCMPLX := [w::EXPR(MCMPLX) for w in vList] + aeList : List EXPR MCMPLX := [w::EXPR(MCMPLX) for w in arguments] + eList : List Equation EXPR MCMPLX := + [equation(w,v) for w in veList for v in aeList] + (subst(rhs u,eList))::$ - coerce(i:$):OutputForm == - nm := num2O numer i --- one? denom i => nm - (denom i = 1) => nm - (1::Integer::OutputForm) / (denom(i)::OutputForm) * nm + coerce(u:REP):$ == + u@Rep - if F has Finite then - randomLC(m, v) == - +/[random()$F * qelt(v, j) for j in minIndex v .. maxIndex v] - else - randomLC(m, v) == - +/[(random()$Integer rem m::Integer) * qelt(v, j) - for j in minIndex v .. maxIndex v] + coerce(u:$):OutputForm == + coerce(name)$Symbol - minimize i == - n := (#(nm := numer i)) --- one?(n) or (n < 3 and ret? nm) => i - (n = 1) or (n < 3 and ret? nm) => i - nrm := retract(norm mkIdeal(nm, 1))@R - for range in 1..5 repeat - (u := tryRange(range, nm, nrm, i)) case $ => return(u::$) - i + coerce(c:List FortranCode):$ == + makeRep c -\end{chunk} + coerce(c:FortranCode):$ == + makeRep [c] -\begin{chunk}{COQ FRIDEAL} -(* domain FRIDEAL *) -(* -*) + coerce(u:EXPR INT) : $ == + checkVariables(variables(u)$EXPR(INT),arguments) + l : List(FC) := [assign(name,u)$FC,returns()$FC] + makeRep l -\end{chunk} + coerce(u:Equation EXPR INT) : $ == + retractIfCan(lhs u)@Union(Kernel(EXPR INT),"failed") case "failed" => + error "left hand side is not a kernel" + vList : List Symbol := variables lhs u + #vList ^= #arguments => + error "Incorrect number of arguments" + veList : List EXPR INT := [w::EXPR(INT) for w in vList] + aeList : List EXPR INT := [w::EXPR(INT) for w in arguments] + eList : List Equation EXPR INT := + [equation(w,v) for w in veList for v in aeList] + (subst(rhs u,eList))::$ -\begin{chunk}{FRIDEAL.dotabb} -"FRIDEAL" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FRIDEAL"] -"FRAMALG" [color="#4488FF",href="bookvol10.2.pdf#nameddest=FRAMALG"] -"FRIDEAL" -> "FRAMALG" + coerce(u:EXPR Float) : $ == + checkVariables(variables(u)$EXPR(Float),arguments) + l : List(FC) := [assign(name,u)$FC,returns()$FC] + makeRep l -\end{chunk} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain FRMOD FramedModule} + coerce(u:Equation EXPR Float) : $ == + retractIfCan(lhs u)@Union(Kernel(EXPR Float),"failed") case "failed" => + error "left hand side is not a kernel" + vList : List Symbol := variables lhs u + #vList ^= #arguments => + error "Incorrect number of arguments" + veList : List EXPR Float := [w::EXPR(Float) for w in vList] + aeList : List EXPR Float := [w::EXPR(Float) for w in arguments] + eList : List Equation EXPR Float := + [equation(w,v) for w in veList for v in aeList] + (subst(rhs u,eList))::$ -\begin{chunk}{FramedModule.input} -)set break resume -)sys rm -f FramedModule.output -)spool FramedModule.output -)set message test on -)set message auto off -)clear all + coerce(u:EXPR Complex Float) : $ == + checkVariables(variables(u)$EXPR(Complex Float),arguments) + l : List(FC) := [assign(name,u)$FC,returns()$FC] + makeRep l ---S 1 of 1 -)show FramedModule ---R ---R FramedModule(R: EuclideanDomain,F: QuotientFieldCategory(R),UP: UnivariatePolynomialCategory(F),A: FramedAlgebra(F,UP),ibasis: Vector(A)) is a domain constructor ---R Abbreviation for FramedModule is FRMOD ---R This constructor is not exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for FRMOD ---R ---R------------------------------- Operations -------------------------------- ---R ?*? : (%,%) -> % ?**? : (%,NonNegativeInteger) -> % ---R ?**? : (%,PositiveInteger) -> % ?=? : (%,%) -> Boolean ---R 1 : () -> % ?^? : (%,NonNegativeInteger) -> % ---R ?^? : (%,PositiveInteger) -> % basis : % -> Vector(A) ---R coerce : % -> OutputForm hash : % -> SingleInteger ---R latex : % -> String module : Vector(A) -> % ---R norm : % -> F one? : % -> Boolean ---R recip : % -> Union(%,"failed") sample : () -> % ---R ?~=? : (%,%) -> Boolean ---R module : FractionalIdeal(R,F,UP,A) -> % if A has RETRACT(F) ---R ---E 1 + coerce(u:Equation EXPR CMPX Float) : $ == + retractIfCan(lhs u)@Union(Kernel EXPR CMPX Float,"failed")_ + case "failed"=> + error "left hand side is not a kernel" + vList : List Symbol := variables lhs u + #vList ^= #arguments => + error "Incorrect number of arguments" + veList : List EXPR CMPX Float := [w::EXPR(CMPX Float) for w in vList] + aeList : List EXPR CMPX Float := [w::EXPR(CMPX Float) for w in arguments] + eList : List Equation EXPR CMPX Float := + [equation(w,v) for w in veList for v in aeList] + (subst(rhs u,eList))::$ -)spool -)lisp (bye) \end{chunk} -\begin{chunk}{FramedModule.help} -==================================================================== -FramedModule examples -==================================================================== -Module representation of fractional ideals. +\begin{chunk}{COQ FORTRAN} +(* domain FORTRAN *) +(* -See Also: -o )show FramedModule + Rep := REP -\end{chunk} + import SExpression + import TheSymbolTable + import FortranCode -\pagehead{FramedModule}{FRMOD} -\pagepic{ps/v103framedmodule.ps}{FRMOD}{1.00} -{\bf See}\\ -\pageto{FractionalIdeal}{FRIDEAL} -\pageto{HyperellipticFiniteDivisor}{HELLFDIV} -\pageto{FiniteDivisor}{FDIV} + makeRep(b:List FortranCode):$ == + construct(empty()$SymbolTable,b)$REP -{\bf Exports:}\\ -\begin{tabular}{lllll} -\cross{FRMOD}{1} & -\cross{FRMOD}{basis} & -\cross{FRMOD}{coerce} & -\cross{FRMOD}{hash} & -\cross{FRMOD}{latex} \\ -\cross{FRMOD}{module} & -\cross{FRMOD}{norm} & -\cross{FRMOD}{one?} & -\cross{FRMOD}{recip} & -\cross{FRMOD}{sample} \\ -\cross{FRMOD}{?\~{}=?} & -\cross{FRMOD}{?**?} & -\cross{FRMOD}{?\^{}?} & -\cross{FRMOD}{?*?} & -\cross{FRMOD}{?**?} \\ -\cross{FRMOD}{?=?} &&&& -\end{tabular} + codeFrom(u:$):List FortranCode == + elt(u::Rep,code)$REP -\begin{chunk}{domain FRMOD FramedModule} -)abbrev domain FRMOD FramedModule -++ Author: Manuel Bronstein -++ Date Created: 27 Jan 1989 -++ Date Last Updated: 24 Jul 1990 -++ Description: -++ Module representation of fractional ideals. + outputAsFortran(p:$):Void == + setLabelValue(25000::SingleInteger)$FC + -- Do this first to catch any extra type declarations: + tempName := "FPTEMP"::Symbol + newSubProgram(tempName) + initialiseIntrinsicList()$Lisp + body : List SExpression := [getCode(l)$FortranCode for l in codeFrom(p)] + intrinsics : SExpression := getIntrinsicList()$Lisp + endSubProgram() + fortFormatHead(returnType::OutputForm, name::OutputForm, _ + arguments::OutputForm)$Lisp + printTypes(symbols)$SymbolTable + printTypes((p::Rep).localSymbols)$SymbolTable + printTypes(tempName)$TheSymbolTable + fortFormatIntrinsics(intrinsics)$Lisp + clearTheSymbolTable(tempName) + for expr in body repeat displayLines1(expr)$Lisp + dispStatement(END::OutputForm)$Lisp + void()$Void -FramedModule(R, F, UP, A, ibasis): Exports == Implementation where - R : EuclideanDomain - F : QuotientFieldCategory R - UP : UnivariatePolynomialCategory F - A : FramedAlgebra(F, UP) - ibasis: Vector A + mkString(l:List Symbol):String == + unparse(convert(l::OutputForm)@InputForm)$InputForm - VR ==> Vector R - VF ==> Vector F - VA ==> Vector A - M ==> Matrix F + checkVariables(user:List Symbol,target:List Symbol):Void == + -- We don't worry about whether the user has subscripted the + -- variables or not. + setDifference(map(name$Symbol,user),target) ^= empty()$List(Symbol) => + s1 : String := mkString(user) + s2 : String := mkString(target) + error ["Incompatible variable lists:", s1, s2] + void()$Void - Exports ==> Monoid with - basis : % -> VA - ++ basis((f1,...,fn)) = the vector \spad{[f1,...,fn]}. - norm : % -> F - ++ norm(f) returns the norm of the module f. - module: VA -> % - ++ module([f1,...,fn]) = the module generated by \spad{(f1,...,fn)} - ++ over R. - if A has RetractableTo F then - module: FractionalIdeal(R, F, UP, A) -> % - ++ module(I) returns I viewed has a module over R. + coerce(u:EXPR MINT) : $ == + checkVariables(variables(u)$EXPR(MINT),arguments) + l : List(FC) := [assign(name,u)$FC,returns()$FC] + makeRep l - Implementation ==> add - import MatrixCommonDenominator(R, F) - import ModularHermitianRowReduction(R) + coerce(u:Equation EXPR MINT) : $ == + retractIfCan(lhs u)@Union(Kernel(EXPR MINT),"failed") case "failed" => + error "left hand side is not a kernel" + vList : List Symbol := variables lhs u + #vList ^= #arguments => + error "Incorrect number of arguments" + veList : List EXPR MINT := [w::EXPR(MINT) for w in vList] + aeList : List EXPR MINT := [w::EXPR(MINT) for w in arguments] + eList : List Equation EXPR MINT := + [equation(w,v) for w in veList for v in aeList] + (subst(rhs u,eList))::$ - Rep := VA + coerce(u:EXPR MFLOAT) : $ == + checkVariables(variables(u)$EXPR(MFLOAT),arguments) + l : List(FC) := [assign(name,u)$FC,returns()$FC] + makeRep l - iflag?:Reference(Boolean) := ref true - wflag?:Reference(Boolean) := ref true - imat := new(#ibasis, #ibasis, 0)$M - wmat := new(#ibasis, #ibasis, 0)$M + coerce(u:Equation EXPR MFLOAT) : $ == + retractIfCan(lhs u)@Union(Kernel(EXPR MFLOAT),"failed") case "failed" => + error "left hand side is not a kernel" + vList : List Symbol := variables lhs u + #vList ^= #arguments => + error "Incorrect number of arguments" + veList : List EXPR MFLOAT := [w::EXPR(MFLOAT) for w in vList] + aeList : List EXPR MFLOAT := [w::EXPR(MFLOAT) for w in arguments] + eList : List Equation EXPR MFLOAT := + [equation(w,v) for w in veList for v in aeList] + (subst(rhs u,eList))::$ - rowdiv : (VR, R) -> VF - vectProd : (VA, VA) -> VA - wmatrix : VA -> M - W2A : VF -> A - intmat : () -> M - invintmat : () -> M - getintmat : () -> Boolean - getinvintmat: () -> Boolean + coerce(u:EXPR MCMPLX) : $ == + checkVariables(variables(u)$EXPR(MCMPLX),arguments) + l : List(FC) := [assign(name,u)$FC,returns()$FC] + makeRep l - 1 == ibasis - module(v:VA) == v - basis m == m pretend VA - rowdiv(r, f) == [r.i / f for i in minIndex r..maxIndex r] - coerce(m:%):OutputForm == coerce(basis m)$VA - W2A v == represents(v * intmat()) - wmatrix v == coordinates(v) * invintmat() + coerce(u:Equation EXPR MCMPLX) : $ == + retractIfCan(lhs u)@Union(Kernel EXPR MCMPLX,"failed") case "failed"=> + error "left hand side is not a kernel" + vList : List Symbol := variables lhs u + #vList ^= #arguments => + error "Incorrect number of arguments" + veList : List EXPR MCMPLX := [w::EXPR(MCMPLX) for w in vList] + aeList : List EXPR MCMPLX := [w::EXPR(MCMPLX) for w in arguments] + eList : List Equation EXPR MCMPLX := + [equation(w,v) for w in veList for v in aeList] + (subst(rhs u,eList))::$ - getinvintmat() == - m := inverse(intmat())::M - for i in minRowIndex m .. maxRowIndex m repeat - for j in minColIndex m .. maxColIndex m repeat - imat(i, j) := qelt(m, i, j) - false + coerce(u:REP):$ == + u@Rep - getintmat() == - m := coordinates ibasis - for i in minRowIndex m .. maxRowIndex m repeat - for j in minColIndex m .. maxColIndex m repeat - wmat(i, j) := qelt(m, i, j) - false + coerce(u:$):OutputForm == + coerce(name)$Symbol - invintmat() == - if iflag?() then iflag?() := getinvintmat() - imat + coerce(c:List FortranCode):$ == + makeRep c - intmat() == - if wflag?() then wflag?() := getintmat() - wmat + coerce(c:FortranCode):$ == + makeRep [c] - vectProd(v1, v2) == - k := minIndex(v := new(#v1 * #v2, 0)$VA) - for i in minIndex v1 .. maxIndex v1 repeat - for j in minIndex v2 .. maxIndex v2 repeat - qsetelt_!(v, k, qelt(v1, i) * qelt(v2, j)) - k := k + 1 - v pretend VA + coerce(u:EXPR INT) : $ == + checkVariables(variables(u)$EXPR(INT),arguments) + l : List(FC) := [assign(name,u)$FC,returns()$FC] + makeRep l - norm m == - #(basis m) ^= #ibasis => error "Module not of rank n" - determinant(coordinates(basis m) * invintmat()) + coerce(u:Equation EXPR INT) : $ == + retractIfCan(lhs u)@Union(Kernel(EXPR INT),"failed") case "failed" => + error "left hand side is not a kernel" + vList : List Symbol := variables lhs u + #vList ^= #arguments => + error "Incorrect number of arguments" + veList : List EXPR INT := [w::EXPR(INT) for w in vList] + aeList : List EXPR INT := [w::EXPR(INT) for w in arguments] + eList : List Equation EXPR INT := + [equation(w,v) for w in veList for v in aeList] + (subst(rhs u,eList))::$ - m1 * m2 == - m := rowEch((cd := splitDenominator wmatrix( - vectProd(basis m1, basis m2))).num) - module [u for i in minRowIndex m .. maxRowIndex m | - (u := W2A rowdiv(row(m, i), cd.den)) ^= 0]$VA + coerce(u:EXPR Float) : $ == + checkVariables(variables(u)$EXPR(Float),arguments) + l : List(FC) := [assign(name,u)$FC,returns()$FC] + makeRep l - if A has RetractableTo F then - module(i:FractionalIdeal(R, F, UP, A)) == - module(basis i) * module(ibasis) + coerce(u:Equation EXPR Float) : $ == + retractIfCan(lhs u)@Union(Kernel(EXPR Float),"failed") case "failed" => + error "left hand side is not a kernel" + vList : List Symbol := variables lhs u + #vList ^= #arguments => + error "Incorrect number of arguments" + veList : List EXPR Float := [w::EXPR(Float) for w in vList] + aeList : List EXPR Float := [w::EXPR(Float) for w in arguments] + eList : List Equation EXPR Float := + [equation(w,v) for w in veList for v in aeList] + (subst(rhs u,eList))::$ -\end{chunk} + coerce(u:EXPR Complex Float) : $ == + checkVariables(variables(u)$EXPR(Complex Float),arguments) + l : List(FC) := [assign(name,u)$FC,returns()$FC] + makeRep l + + coerce(u:Equation EXPR CMPX Float) : $ == + retractIfCan(lhs u)@Union(Kernel EXPR CMPX Float,"failed")_ + case "failed"=> + error "left hand side is not a kernel" + vList : List Symbol := variables lhs u + #vList ^= #arguments => + error "Incorrect number of arguments" + veList : List EXPR CMPX Float := [w::EXPR(CMPX Float) for w in vList] + aeList : List EXPR CMPX Float := [w::EXPR(CMPX Float) for w in arguments] + eList : List Equation EXPR CMPX Float := + [equation(w,v) for w in veList for v in aeList] + (subst(rhs u,eList))::$ -\begin{chunk}{COQ FRMOD} -(* domain FRMOD *) -(* *) \end{chunk} -\begin{chunk}{FRMOD.dotabb} -"FRMOD" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FRMOD"] -"FRAMALG" [color="#4488FF",href="bookvol10.2.pdf#nameddest=FRAMALG"] -"FRMOD" -> "FRAMALG" +\begin{chunk}{FORTRAN.dotabb} +"FORTRAN" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FORTRAN"] +"COMPCAT" [color="#4488FF",href="bookvol10.2.pdf#nameddest=COMPCAT"] +"FORTRAN" -> "COMPCAT" \end{chunk} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain FAGROUP FreeAbelianGroup} +\section{domain FST FortranScalarType} -\begin{chunk}{FreeAbelianGroup.input} +\begin{chunk}{FortranScalarType.input} )set break resume -)sys rm -f FreeAbelianGroup.output -)spool FreeAbelianGroup.output +)sys rm -f FortranScalarType.output +)spool FortranScalarType.output )set message test on )set message auto off )clear all --S 1 of 1 -)show FreeAbelianGroup +)show FortranScalarType --R ---R FreeAbelianGroup(S: SetCategory) is a domain constructor ---R Abbreviation for FreeAbelianGroup is FAGROUP ---R This constructor is not exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for FAGROUP +--R FortranScalarType is a domain constructor +--R Abbreviation for FortranScalarType is FST +--R This constructor is exposed in this frame. +--R Issue )edit bookvol10.3.pamphlet to see algebra source code for FST --R --R------------------------------- Operations -------------------------------- ---R ?*? : (Integer,S) -> % ?*? : (%,Integer) -> % ---R ?*? : (Integer,%) -> % ?*? : (NonNegativeInteger,%) -> % ---R ?*? : (PositiveInteger,%) -> % ?+? : (S,%) -> % ---R ?+? : (%,%) -> % ?-? : (%,%) -> % ---R -? : % -> % ?=? : (%,%) -> Boolean ---R 0 : () -> % coefficient : (S,%) -> Integer ---R coerce : S -> % coerce : % -> OutputForm ---R hash : % -> SingleInteger latex : % -> String ---R mapGen : ((S -> S),%) -> % max : (%,%) -> % if S has ORDSET ---R min : (%,%) -> % if S has ORDSET nthCoef : (%,Integer) -> Integer ---R nthFactor : (%,Integer) -> S retract : % -> S ---R sample : () -> % size : % -> NonNegativeInteger ---R zero? : % -> Boolean ?~=? : (%,%) -> Boolean ---R ? Boolean if S has ORDSET ---R ?<=? : (%,%) -> Boolean if S has ORDSET ---R ?>? : (%,%) -> Boolean if S has ORDSET ---R ?>=? : (%,%) -> Boolean if S has ORDSET ---R highCommonTerms : (%,%) -> % if Integer has OAMON ---R mapCoef : ((Integer -> Integer),%) -> % ---R retractIfCan : % -> Union(S,"failed") ---R subtractIfCan : (%,%) -> Union(%,"failed") ---R terms : % -> List(Record(gen: S,exp: Integer)) +--R ?=? : (%,%) -> Boolean character? : % -> Boolean +--R coerce : % -> SExpression coerce : % -> Symbol +--R coerce : Symbol -> % coerce : String -> % +--R coerce : % -> OutputForm complex? : % -> Boolean +--R double? : % -> Boolean doubleComplex? : % -> Boolean +--R integer? : % -> Boolean logical? : % -> Boolean +--R real? : % -> Boolean --R --E 1 )spool )lisp (bye) \end{chunk} -\begin{chunk}{FreeAbelianGroup.help} +\begin{chunk}{FortranScalarType.help} ==================================================================== -FreeAbelianGroup examples +FortranScalarType examples ==================================================================== -Free abelian group on any set of generators -The free abelian group on a set S is the monoid of finite sums of -the form reduce(+,[ni * si]) where the si's are in S, and the ni's -are integers. The operation is commutative. +Creates and manipulates objects which correspond to the +basic FORTRAN data types: REAL, INTEGER, COMPLEX, LOGICAL and CHARACTER See Also: -o )show FreeAbelianGroup +o )show FortranScalarType \end{chunk} -\pagehead{FreeAbelianGroup}{FAGROUP} -\pagepic{ps/v103freeabeliangroup.ps}{FAGROUP}{1.00} +\pagehead{FortranScalarType}{FST} +\pagepic{ps/v103fortranscalartype.ps}{FST}{1.00} {\bf See}\\ -\pageto{ListMonoidOps}{LMOPS} -\pageto{FreeMonoid}{FMONOID} -\pageto{FreeGroup}{FGROUP} -\pageto{InnerFreeAbelianMonoid}{IFAMON} -\pageto{FreeAbelianMonoid}{FAMONOID} +\pageto{FortranType}{FT} +\pageto{SymbolTable}{SYMTAB} +\pageto{TheSymbolTable}{SYMS} {\bf Exports:}\\ -\begin{tabular}{lllll} -\cross{FAGROUP}{0} & -\cross{FAGROUP}{coefficient} & -\cross{FAGROUP}{coerce} & -\cross{FAGROUP}{hash} & -\cross{FAGROUP}{highCommonTerms} \\ -\cross{FAGROUP}{latex} & -\cross{FAGROUP}{mapCoef} & -\cross{FAGROUP}{mapGen} & -\cross{FAGROUP}{max} & -\cross{FAGROUP}{min} \\ -\cross{FAGROUP}{nthCoef} & -\cross{FAGROUP}{nthFactor} & -\cross{FAGROUP}{retract} & -\cross{FAGROUP}{retractIfCan} & -\cross{FAGROUP}{sample} \\ -\cross{FAGROUP}{size} & -\cross{FAGROUP}{subtractIfCan} & -\cross{FAGROUP}{terms} & -\cross{FAGROUP}{zero?} & -\cross{FAGROUP}{?\~{}=?} \\ -\cross{FAGROUP}{?*?} & -\cross{FAGROUP}{?$<$?} & -\cross{FAGROUP}{?$<=$?} & -\cross{FAGROUP}{?$>$?} & -\cross{FAGROUP}{?$>=$?} \\ -\cross{FAGROUP}{?+?} & -\cross{FAGROUP}{?-?} & -\cross{FAGROUP}{-?} & -\cross{FAGROUP}{?=?} & +\begin{tabular}{lllllllll} +\cross{FST}{character?} & +\cross{FST}{coerce} & +\cross{FST}{complex?} & +\cross{FST}{double?} & +\cross{FST}{doubleComplex?} & +\cross{FST}{integer?} & +\cross{FST}{logical?} & +\cross{FST}{real?} & +\cross{FST}{?=?} \end{tabular} -\begin{chunk}{domain FAGROUP FreeAbelianGroup} -)abbrev domain FAGROUP FreeAbelianGroup -++ Author: Manuel Bronstein -++ Date Created: November 1989 -++ Date Last Updated: 6 June 1991 +\begin{chunk}{domain FST FortranScalarType} +)abbrev domain FST FortranScalarType +++ Author: Mike Dewar +++ Date Created: October 1992 ++ Description: -++ Free abelian group on any set of generators -++ The free abelian group on a set S is the monoid of finite sums of -++ the form \spad{reduce(+,[ni * si])} where the si's are in S, and the ni's -++ are integers. The operation is commutative. - -FreeAbelianGroup(S:SetCategory): Exports == Implementation where - Exports ==> Join(AbelianGroup, Module Integer, - FreeAbelianMonoidCategory(S, Integer)) with - if S has OrderedSet then OrderedSet +++ Creates and manipulates objects which correspond to the +++ basic FORTRAN data types: REAL, INTEGER, COMPLEX, LOGICAL and CHARACTER - Implementation ==> InnerFreeAbelianMonoid(S, Integer, 1) add - - f == mapCoef("-", f) +FortranScalarType() : exports == implementation where - if S has OrderedSet then - inmax: List Record(gen: S, exp: Integer) -> Record(gen: S, exp:Integer) + exports == CoercibleTo OutputForm with + coerce : String -> $ + ++ coerce(s) transforms the string s into an element of + ++ FortranScalarType provided s is one of "real", "double precision", + ++ "complex", "logical", "integer", "character", "REAL", + ++ "COMPLEX", "LOGICAL", "INTEGER", "CHARACTER", + ++ "DOUBLE PRECISION" + coerce : Symbol -> $ + ++ coerce(s) transforms the symbol s into an element of + ++ FortranScalarType provided s is one of real, complex,double precision, + ++ logical, integer, character, REAL, COMPLEX, LOGICAL, + ++ INTEGER, CHARACTER, DOUBLE PRECISION + coerce : $ -> Symbol + ++ coerce(x) returns the symbol associated with x + coerce : $ -> SExpression + ++ coerce(x) returns the s-expression associated with x + real? : $ -> Boolean + ++ real?(t) tests whether t is equivalent to the FORTRAN type REAL. + double? : $ -> Boolean + ++ double?(t) tests whether t is equivalent to the FORTRAN type + ++ DOUBLE PRECISION + integer? : $ -> Boolean + ++ integer?(t) tests whether t is equivalent to the FORTRAN type INTEGER. + complex? : $ -> Boolean + ++ complex?(t) tests whether t is equivalent to the FORTRAN type COMPLEX. + doubleComplex? : $ -> Boolean + ++ doubleComplex?(t) tests whether t is equivalent to the (non-standard) + ++ FORTRAN type DOUBLE COMPLEX. + character? : $ -> Boolean + ++ character?(t) tests whether t is equivalent to the FORTRAN type + ++ CHARACTER. + logical? : $ -> Boolean + ++ logical?(t) tests whether t is equivalent to the FORTRAN type LOGICAL. + "=" : ($,$) -> Boolean + ++ x=y tests for equality - inmax l == - mx := first l - for t in rest l repeat - if mx.gen < t.gen then mx := t - mx + implementation == add - -- lexicographic order - a < b == - zero? a => - zero? b => false - 0 < (inmax terms b).exp - ta := inmax terms a - zero? b => ta.exp < 0 - tb := inmax terms b - ta.gen < tb.gen => 0 < tb.exp - tb.gen < ta.gen => ta.exp < 0 - ta.exp < tb.exp => true - tb.exp < ta.exp => false - lc := ta.exp * ta.gen - (a - lc) < (b - lc) + U == Union(RealThing:"real", + IntegerThing:"integer", + ComplexThing:"complex", + CharacterThing:"character", + LogicalThing:"logical", + DoublePrecisionThing:"double precision", + DoubleComplexThing:"double complex") + Rep := U -\end{chunk} + doubleSymbol : Symbol := "double precision"::Symbol -\begin{chunk}{COQ FAGROUP} -(* domain FAGROUP *) -(* -*) + upperDoubleSymbol : Symbol := "DOUBLE PRECISION"::Symbol -\end{chunk} + doubleComplexSymbol : Symbol := "double complex"::Symbol -\begin{chunk}{FAGROUP.dotabb} -"FAGROUP" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FAGROUP"] -"PID" [color="#4488FF",href="bookvol10.2.pdf#nameddest=PID"] -"OAGROUP" [color="#4488FF",href="bookvol10.2.pdf#nameddest=OAGROUP"] -"FAGROUP" -> "PID" -"FAGROUP" -> "OAGROUP" + upperDoubleComplexSymbol : Symbol := "DOUBLE COMPLEX"::Symbol -\end{chunk} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain FAMONOID FreeAbelianMonoid} + u = v == + u case RealThing and v case RealThing => true + u case IntegerThing and v case IntegerThing => true + u case ComplexThing and v case ComplexThing => true + u case LogicalThing and v case LogicalThing => true + u case CharacterThing and v case CharacterThing => true + u case DoublePrecisionThing and v case DoublePrecisionThing => true + u case DoubleComplexThing and v case DoubleComplexThing => true + false -\begin{chunk}{FreeAbelianMonoid.input} -)set break resume -)sys rm -f FreeAbelianMonoid.output -)spool FreeAbelianMonoid.output -)set message test on -)set message auto off -)clear all + coerce(t:$):OutputForm == + t case RealThing => coerce(REAL)$Symbol + t case IntegerThing => coerce(INTEGER)$Symbol + t case ComplexThing => coerce(COMPLEX)$Symbol + t case CharacterThing => coerce(CHARACTER)$Symbol + t case DoublePrecisionThing => coerce(upperDoubleSymbol)$Symbol + t case DoubleComplexThing => coerce(upperDoubleComplexSymbol)$Symbol + coerce(LOGICAL)$Symbol ---S 1 of 1 -)show FreeAbelianMonoid ---R ---R FreeAbelianMonoid(S: SetCategory) is a domain constructor ---R Abbreviation for FreeAbelianMonoid is FAMONOID ---R This constructor is not exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for FAMONOID ---R ---R------------------------------- Operations -------------------------------- ---R ?*? : (NonNegativeInteger,S) -> % ?*? : (NonNegativeInteger,%) -> % ---R ?*? : (PositiveInteger,%) -> % ?+? : (S,%) -> % ---R ?+? : (%,%) -> % ?=? : (%,%) -> Boolean ---R 0 : () -> % coerce : S -> % ---R coerce : % -> OutputForm hash : % -> SingleInteger ---R latex : % -> String mapGen : ((S -> S),%) -> % ---R nthFactor : (%,Integer) -> S retract : % -> S ---R sample : () -> % size : % -> NonNegativeInteger ---R zero? : % -> Boolean ?~=? : (%,%) -> Boolean ---R coefficient : (S,%) -> NonNegativeInteger ---R highCommonTerms : (%,%) -> % if NonNegativeInteger has OAMON ---R mapCoef : ((NonNegativeInteger -> NonNegativeInteger),%) -> % ---R nthCoef : (%,Integer) -> NonNegativeInteger ---R retractIfCan : % -> Union(S,"failed") ---R subtractIfCan : (%,%) -> Union(%,"failed") ---R terms : % -> List(Record(gen: S,exp: NonNegativeInteger)) ---R ---E 1 + coerce(t:$):SExpression == + t case RealThing => convert(real::Symbol)@SExpression + t case IntegerThing => convert(integer::Symbol)@SExpression + t case ComplexThing => convert(complex::Symbol)@SExpression + t case CharacterThing => convert(character::Symbol)@SExpression + t case DoublePrecisionThing => convert(doubleSymbol)@SExpression + t case DoubleComplexThing => convert(doubleComplexSymbol)@SExpression + convert(logical::Symbol)@SExpression -)spool -)lisp (bye) -\end{chunk} -\begin{chunk}{FreeAbelianMonoid.help} -==================================================================== -FreeAbelianMonoid examples -==================================================================== + coerce(t:$):Symbol == + t case RealThing => real::Symbol + t case IntegerThing => integer::Symbol + t case ComplexThing => complex::Symbol + t case CharacterThing => character::Symbol + t case DoublePrecisionThing => doubleSymbol + t case DoublePrecisionThing => doubleComplexSymbol + logical::Symbol -Free abelian monoid on any set of generators -The free abelian monoid on a set S is the monoid of finite sums of -the form reduce(+,[ni * si]) where the si's are in S, and the ni's -are non-negative integers. The operation is commutative. + coerce(s:Symbol):$ == + s = real => ["real"]$Rep + s = REAL => ["real"]$Rep + s = integer => ["integer"]$Rep + s = INTEGER => ["integer"]$Rep + s = complex => ["complex"]$Rep + s = COMPLEX => ["complex"]$Rep + s = character => ["character"]$Rep + s = CHARACTER => ["character"]$Rep + s = logical => ["logical"]$Rep + s = LOGICAL => ["logical"]$Rep + s = doubleSymbol => ["double precision"]$Rep + s = upperDoubleSymbol => ["double precision"]$Rep + s = doubleComplexSymbol => ["double complex"]$Rep + s = upperDoubleCOmplexSymbol => ["double complex"]$Rep -See Also: -o )show FreeAbelianMonoid + coerce(s:String):$ == + s = "real" => ["real"]$Rep + s = "integer" => ["integer"]$Rep + s = "complex" => ["complex"]$Rep + s = "character" => ["character"]$Rep + s = "logical" => ["logical"]$Rep + s = "double precision" => ["double precision"]$Rep + s = "double complex" => ["double complex"]$Rep + s = "REAL" => ["real"]$Rep + s = "INTEGER" => ["integer"]$Rep + s = "COMPLEX" => ["complex"]$Rep + s = "CHARACTER" => ["character"]$Rep + s = "LOGICAL" => ["logical"]$Rep + s = "DOUBLE PRECISION" => ["double precision"]$Rep + s = "DOUBLE COMPLEX" => ["double complex"]$Rep + error concat([s," is invalid as a Fortran Type"])$String -\end{chunk} + real?(t:$):Boolean == t case RealThing -\pagehead{FreeAbelianMonoid}{FAMONOID} -\pagepic{ps/v103freeabelianmonoid.ps}{FAMONOID}{1.00} -{\bf See}\\ -\pageto{ListMonoidOps}{LMOPS} -\pageto{FreeMonoid}{FMONOID} -\pageto{FreeGroup}{FGROUP} -\pageto{InnerFreeAbelianMonoid}{IFAMON} -\pageto{FreeAbelianGroup}{FAGROUP} + double?(t:$):Boolean == t case DoublePrecisionThing -{\bf Exports:}\\ -\begin{tabular}{lllll} -\cross{FAMONOID}{0} & -\cross{FAMONOID}{coefficient} & -\cross{FAMONOID}{coerce} & -\cross{FAMONOID}{hash} & -\cross{FAMONOID}{highCommonTerms} \\ -\cross{FAMONOID}{latex} & -\cross{FAMONOID}{mapCoef} & -\cross{FAMONOID}{mapGen} & -\cross{FAMONOID}{nthCoef} & -\cross{FAMONOID}{nthFactor} \\ -\cross{FAMONOID}{retract} & -\cross{FAMONOID}{retractIfCan} & -\cross{FAMONOID}{sample} & -\cross{FAMONOID}{size} & -\cross{FAMONOID}{subtractIfCan} \\ -\cross{FAMONOID}{terms} & -\cross{FAMONOID}{zero?} & -\cross{FAMONOID}{?\~{}=?} & -\cross{FAMONOID}{?*?} & -\cross{FAMONOID}{?+?} \\ -\cross{FAMONOID}{?=?} &&&& -\end{tabular} + logical?(t:$):Boolean == t case LogicalThing -\begin{chunk}{domain FAMONOID FreeAbelianMonoid} -)abbrev domain FAMONOID FreeAbelianMonoid -++ Author: Manuel Bronstein -++ Date Created: November 1989 -++ Date Last Updated: 6 June 1991 -++ Description: -++ Free abelian monoid on any set of generators -++ The free abelian monoid on a set S is the monoid of finite sums of -++ the form \spad{reduce(+,[ni * si])} where the si's are in S, and the ni's -++ are non-negative integers. The operation is commutative. + integer?(t:$):Boolean == t case IntegerThing -FreeAbelianMonoid(S: SetCategory): - FreeAbelianMonoidCategory(S, NonNegativeInteger) - == InnerFreeAbelianMonoid(S, NonNegativeInteger, 1) + character?(t:$):Boolean == t case CharacterThing + + complex?(t:$):Boolean == t case ComplexThing + + doubleComplex?(t:$):Boolean == t case DoubleComplexThing \end{chunk} -\begin{chunk}{COQ FAMONOID} -(* domain FAMONOID *) +\begin{chunk}{COQ FST} +(* domain FST *) (* + + U == Union(RealThing:"real", + IntegerThing:"integer", + ComplexThing:"complex", + CharacterThing:"character", + LogicalThing:"logical", + DoublePrecisionThing:"double precision", + DoubleComplexThing:"double complex") + Rep := U + + doubleSymbol : Symbol := "double precision"::Symbol + + upperDoubleSymbol : Symbol := "DOUBLE PRECISION"::Symbol + + doubleComplexSymbol : Symbol := "double complex"::Symbol + + upperDoubleComplexSymbol : Symbol := "DOUBLE COMPLEX"::Symbol + + u = v == + u case RealThing and v case RealThing => true + u case IntegerThing and v case IntegerThing => true + u case ComplexThing and v case ComplexThing => true + u case LogicalThing and v case LogicalThing => true + u case CharacterThing and v case CharacterThing => true + u case DoublePrecisionThing and v case DoublePrecisionThing => true + u case DoubleComplexThing and v case DoubleComplexThing => true + false + + coerce(t:$):OutputForm == + t case RealThing => coerce(REAL)$Symbol + t case IntegerThing => coerce(INTEGER)$Symbol + t case ComplexThing => coerce(COMPLEX)$Symbol + t case CharacterThing => coerce(CHARACTER)$Symbol + t case DoublePrecisionThing => coerce(upperDoubleSymbol)$Symbol + t case DoubleComplexThing => coerce(upperDoubleComplexSymbol)$Symbol + coerce(LOGICAL)$Symbol + + coerce(t:$):SExpression == + t case RealThing => convert(real::Symbol)@SExpression + t case IntegerThing => convert(integer::Symbol)@SExpression + t case ComplexThing => convert(complex::Symbol)@SExpression + t case CharacterThing => convert(character::Symbol)@SExpression + t case DoublePrecisionThing => convert(doubleSymbol)@SExpression + t case DoubleComplexThing => convert(doubleComplexSymbol)@SExpression + convert(logical::Symbol)@SExpression + + coerce(t:$):Symbol == + t case RealThing => real::Symbol + t case IntegerThing => integer::Symbol + t case ComplexThing => complex::Symbol + t case CharacterThing => character::Symbol + t case DoublePrecisionThing => doubleSymbol + t case DoublePrecisionThing => doubleComplexSymbol + logical::Symbol + + coerce(s:Symbol):$ == + s = real => ["real"]$Rep + s = REAL => ["real"]$Rep + s = integer => ["integer"]$Rep + s = INTEGER => ["integer"]$Rep + s = complex => ["complex"]$Rep + s = COMPLEX => ["complex"]$Rep + s = character => ["character"]$Rep + s = CHARACTER => ["character"]$Rep + s = logical => ["logical"]$Rep + s = LOGICAL => ["logical"]$Rep + s = doubleSymbol => ["double precision"]$Rep + s = upperDoubleSymbol => ["double precision"]$Rep + s = doubleComplexSymbol => ["double complex"]$Rep + s = upperDoubleCOmplexSymbol => ["double complex"]$Rep + + coerce(s:String):$ == + s = "real" => ["real"]$Rep + s = "integer" => ["integer"]$Rep + s = "complex" => ["complex"]$Rep + s = "character" => ["character"]$Rep + s = "logical" => ["logical"]$Rep + s = "double precision" => ["double precision"]$Rep + s = "double complex" => ["double complex"]$Rep + s = "REAL" => ["real"]$Rep + s = "INTEGER" => ["integer"]$Rep + s = "COMPLEX" => ["complex"]$Rep + s = "CHARACTER" => ["character"]$Rep + s = "LOGICAL" => ["logical"]$Rep + s = "DOUBLE PRECISION" => ["double precision"]$Rep + s = "DOUBLE COMPLEX" => ["double complex"]$Rep + error concat([s," is invalid as a Fortran Type"])$String + + real?(t:$):Boolean == t case RealThing + + double?(t:$):Boolean == t case DoublePrecisionThing + + logical?(t:$):Boolean == t case LogicalThing + + integer?(t:$):Boolean == t case IntegerThing + + character?(t:$):Boolean == t case CharacterThing + + complex?(t:$):Boolean == t case ComplexThing + + doubleComplex?(t:$):Boolean == t case DoubleComplexThing + *) \end{chunk} -\begin{chunk}{FAMONOID.dotabb} -"FAMONOID" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FAMONOID"] -"OAMONS" [color="#4488FF",href="bookvol10.2.pdf#nameddest=OAMONS"] -"FAMONOID" -> "OAMONS" +\begin{chunk}{FST.dotabb} +"FST" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FST"] +"ALIST" [color="#88FF44",href="bookvol10.3.pdf#nameddest=ALIST"] +"FST" -> "ALIST" \end{chunk} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain FGROUP FreeGroup} +\section{domain FTEM FortranTemplate} -\begin{chunk}{FreeGroup.input} +\begin{chunk}{FortranTemplate.input} )set break resume -)sys rm -f FreeGroup.output -)spool FreeGroup.output +)sys rm -f FortranTemplate.output +)spool FortranTemplate.output )set message test on )set message auto off )clear all --S 1 of 1 -)show FreeGroup +)show FortranTemplate --R ---R FreeGroup(S: SetCategory) is a domain constructor ---R Abbreviation for FreeGroup is FGROUP ---R This constructor is not exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for FGROUP +--R FortranTemplate is a domain constructor +--R Abbreviation for FortranTemplate is FTEM +--R This constructor is exposed in this frame. +--R Issue )edit bookvol10.3.pamphlet to see algebra source code for FTEM --R --R------------------------------- Operations -------------------------------- ---R ?*? : (%,S) -> % ?*? : (S,%) -> % ---R ?*? : (%,%) -> % ?**? : (S,Integer) -> % ---R ?**? : (%,Integer) -> % ?**? : (%,NonNegativeInteger) -> % ---R ?**? : (%,PositiveInteger) -> % ?/? : (%,%) -> % ---R ?=? : (%,%) -> Boolean 1 : () -> % ---R ?^? : (%,Integer) -> % ?^? : (%,NonNegativeInteger) -> % ---R ?^? : (%,PositiveInteger) -> % coerce : S -> % ---R coerce : % -> OutputForm commutator : (%,%) -> % ---R conjugate : (%,%) -> % hash : % -> SingleInteger ---R inv : % -> % latex : % -> String ---R mapGen : ((S -> S),%) -> % nthExpon : (%,Integer) -> Integer ---R nthFactor : (%,Integer) -> S one? : % -> Boolean ---R recip : % -> Union(%,"failed") retract : % -> S ---R sample : () -> % size : % -> NonNegativeInteger +--R ?=? : (%,%) -> Boolean close! : % -> % +--R coerce : % -> OutputForm flush : % -> Void +--R fortranCarriageReturn : () -> Void fortranLiteral : String -> Void +--R fortranLiteralLine : String -> Void hash : % -> SingleInteger +--R iomode : % -> String latex : % -> String +--R name : % -> FileName open : (FileName,String) -> % +--R open : FileName -> % read! : % -> String +--R reopen! : (%,String) -> % write! : (%,String) -> String --R ?~=? : (%,%) -> Boolean ---R factors : % -> List(Record(gen: S,exp: Integer)) ---R mapExpon : ((Integer -> Integer),%) -> % ---R retractIfCan : % -> Union(S,"failed") +--R processTemplate : FileName -> FileName +--R processTemplate : (FileName,FileName) -> FileName --R --E 1 )spool )lisp (bye) \end{chunk} -\begin{chunk}{FreeGroup.help} +\begin{chunk}{FortranTemplate.help} ==================================================================== -FreeGroup examples +FortranTemplate examples ==================================================================== -Free group on any set of generators -The free group on a set S is the group of finite products of -the form reduce(*,[si ** ni]) where the si's are in S, and the ni's -are integers. The multiplication is not commutative. +Code to manipulate Fortran templates See Also: -o )show FreeGroup +o )show FortranTemplate \end{chunk} -\pagehead{FreeGroup}{FGROUP} -\pagepic{ps/v103freegroup.ps}{FGROUP}{1.00} +\pagehead{FortranTemplate}{FTEM} +\pagepic{ps/v103fortrantemplate.ps}{FTEM}{1.00} {\bf See}\\ -\pageto{ListMonoidOps}{LMOPS} -\pageto{FreeMonoid}{FMONOID} -\pageto{InnerFreeAbelianMonoid}{IFAMON} -\pageto{FreeAbelianMonoid}{FAMONOID} -\pageto{FreeAbelianGroup}{FAGROUP} +\pageto{Result}{RESULT} +\pageto{FortranCode}{FC} +\pageto{FortranProgram}{FORTRAN} +\pageto{ThreeDimensionalMatrix}{M3D} +\pageto{SimpleFortranProgram}{SFORT} +\pageto{Switch}{SWITCH} +\pageto{FortranExpression}{FEXPR} {\bf Exports:}\\ \begin{tabular}{lllll} -\cross{FGROUP}{1} & -\cross{FGROUP}{coerce} & -\cross{FGROUP}{commutator} & -\cross{FGROUP}{conjugate} & -\cross{FGROUP}{factors} \\ -\cross{FGROUP}{hash} & -\cross{FGROUP}{inv} & -\cross{FGROUP}{latex} & -\cross{FGROUP}{mapExpon} & -\cross{FGROUP}{mapGen} \\ -\cross{FGROUP}{nthExpon} & -\cross{FGROUP}{nthFactor} & -\cross{FGROUP}{one?} & -\cross{FGROUP}{recip} & -\cross{FGROUP}{retract} \\ -\cross{FGROUP}{retractIfCan} & -\cross{FGROUP}{sample} & -\cross{FGROUP}{size} & -\cross{FGROUP}{?\~{}=?} & -\cross{FGROUP}{?**?} \\ -\cross{FGROUP}{?\^{}?} & -\cross{FGROUP}{?*?} & -\cross{FGROUP}{?/?} & -\cross{FGROUP}{?=?} & +\cross{FTEM}{close!} & +\cross{FTEM}{coerce} & +\cross{FTEM}{fortranCarriageReturn} & +\cross{FTEM}{fortranLiteral} & +\cross{FTEM}{fortranLiteralLine} \\ +\cross{FTEM}{hash} & +\cross{FTEM}{iomode} & +\cross{FTEM}{latex} & +\cross{FTEM}{name} & +\cross{FTEM}{open} \\ +\cross{FTEM}{processTemplate} & +\cross{FTEM}{read!} & +\cross{FTEM}{reopen!} & +\cross{FTEM}{write!} & +\cross{FTEM}{?=?} \\ +\cross{FTEM}{?\~{}=?} &&&& \end{tabular} -\begin{chunk}{domain FGROUP FreeGroup} -)abbrev domain FGROUP FreeGroup -++ Author: Stephen M. Watt -++ Date Last Updated: 6 June 1991 +\begin{chunk}{domain FTEM FortranTemplate} +)abbrev domain FTEM FortranTemplate +++ Author: Mike Dewar +++ Date Created: October 1992 ++ Description: -++ Free group on any set of generators -++ The free group on a set S is the group of finite products of -++ the form \spad{reduce(*,[si ** ni])} where the si's are in S, and the ni's -++ are integers. The multiplication is not commutative. +++ Code to manipulate Fortran templates -FreeGroup(S: SetCategory): Join(Group, RetractableTo S) with - "*": (S, $) -> $ - ++ s * x returns the product of x by s on the left. - "*": ($, S) -> $ - ++ x * s returns the product of x by s on the right. - "**" : (S, Integer) -> $ - ++ s ** n returns the product of s by itself n times. - size : $ -> NonNegativeInteger - ++ size(x) returns the number of monomials in x. - nthExpon : ($, Integer) -> Integer - ++ nthExpon(x, n) returns the exponent of the n^th monomial of x. - nthFactor : ($, Integer) -> S - ++ nthFactor(x, n) returns the factor of the n^th monomial of x. - mapExpon : (Integer -> Integer, $) -> $ - ++ mapExpon(f, a1\^e1 ... an\^en) returns - ++ \spad{a1\^f(e1) ... an\^f(en)}. - mapGen : (S -> S, $) -> $ - ++ mapGen(f, a1\^e1 ... an\^en) returns - ++ \spad{f(a1)\^e1 ... f(an)\^en}. - factors : $ -> List Record(gen: S, exp: Integer) - ++ factors(a1\^e1,...,an\^en) returns \spad{[[a1, e1],...,[an, en]]}. - == ListMonoidOps(S, Integer, 1) add - Rep := ListMonoidOps(S, Integer, 1) +FortranTemplate() : specification == implementation where - 1 == makeUnit() - one? f == empty? listOfMonoms f - s:S ** n:Integer == makeTerm(s, n) - f:$ * s:S == rightMult(f, s) - s:S * f:$ == leftMult(s, f) - inv f == reverse_! mapExpon("-", f) - factors f == copy listOfMonoms f - mapExpon(f, x) == mapExpon(f, x)$Rep - mapGen(f, x) == mapGen(f, x)$Rep - coerce(f:$):OutputForm == outputForm(f, "*", "**", 1) + specification == FileCategory(FileName, String) with - f:$ * g:$ == - one? f => g - one? g => f - r := reverse listOfMonoms f - q := copy listOfMonoms g - while not empty? r and not empty? q and r.first.gen = q.first.gen - and r.first.exp = -q.first.exp repeat - r := rest r - q := rest q - empty? r => makeMulti q - empty? q => makeMulti reverse_! r - r.first.gen = q.first.gen => - setlast_!(h := reverse_! r, - [q.first.gen, q.first.exp + r.first.exp]) - makeMulti concat_!(h, rest q) - makeMulti concat_!(reverse_! r, q) + processTemplate : (FileName, FileName) -> FileName + ++ processTemplate(tp,fn) processes the template tp, writing the + ++ result out to fn. + processTemplate : (FileName) -> FileName + ++ processTemplate(tp) processes the template tp, writing the + ++ result to the current FORTRAN output stream. + fortranLiteralLine : String -> Void + ++ fortranLiteralLine(s) writes s to the current Fortran output stream, + ++ followed by a carriage return + fortranLiteral : String -> Void + ++ fortranLiteral(s) writes s to the current Fortran output stream + fortranCarriageReturn : () -> Void + ++ fortranCarriageReturn() produces a carriage return on the current + ++ Fortran output stream + + implementation == TextFile add + + import TemplateUtilities + import FortranOutputStackPackage + + Rep := TextFile + + fortranLiteralLine(s:String):Void == + PRINC(s,_$fortranOutputStream$Lisp)$Lisp + TERPRI(_$fortranOutputStream$Lisp)$Lisp + + fortranLiteral(s:String):Void == + PRINC(s,_$fortranOutputStream$Lisp)$Lisp + + fortranCarriageReturn():Void == + TERPRI(_$fortranOutputStream$Lisp)$Lisp + + writePassiveLine!(line:String):Void == + -- We might want to be a bit clever here and look for new SubPrograms etc. + fortranLiteralLine line + + processTemplate(tp:FileName, fn:FileName):FileName == + pushFortranOutputStack(fn) + processTemplate(tp) + popFortranOutputStack() + fn + + getLine(fp:TextFile):String == + line : String := stripCommentsAndBlanks readLine!(fp) + while not empty?(line) and elt(line,maxIndex line) = char "__" repeat + setelt(line,maxIndex line,char " ") + line := concat(line, stripCommentsAndBlanks readLine!(fp))$String + line + + processTemplate(tp:FileName):FileName == + fp : TextFile := open(tp,"input") + active : Boolean := true + line : String + endInput : Boolean := false + while not (endInput or endOfFile? fp) repeat + if active then + line := getLine fp + line = "endInput" => endInput := true + if line = "beginVerbatim" then + active := false + else + not empty? line => interpretString line + else + line := readLine!(fp) + if line = "endVerbatim" then + active := true + else + writePassiveLine! line + close!(fp) + if not active then + error concat(["Missing `endVerbatim' line in ",tp::String])$String + string(_$fortranOutputFile$Lisp)::FileName \end{chunk} -\begin{chunk}{COQ FGROUP} -(* domain FGROUP *) +\begin{chunk}{COQ FTEM} +(* domain FTEM *) (* + + import TemplateUtilities + import FortranOutputStackPackage + + Rep := TextFile + + fortranLiteralLine(s:String):Void == + PRINC(s,_$fortranOutputStream$Lisp)$Lisp + TERPRI(_$fortranOutputStream$Lisp)$Lisp + + fortranLiteral(s:String):Void == + PRINC(s,_$fortranOutputStream$Lisp)$Lisp + + fortranCarriageReturn():Void == + TERPRI(_$fortranOutputStream$Lisp)$Lisp + + writePassiveLine!(line:String):Void == + -- We might want to be a bit clever here and look for new SubPrograms etc. + fortranLiteralLine line + + processTemplate(tp:FileName, fn:FileName):FileName == + pushFortranOutputStack(fn) + processTemplate(tp) + popFortranOutputStack() + fn + + getLine(fp:TextFile):String == + line : String := stripCommentsAndBlanks readLine!(fp) + while not empty?(line) and elt(line,maxIndex line) = char "__" repeat + setelt(line,maxIndex line,char " ") + line := concat(line, stripCommentsAndBlanks readLine!(fp))$String + line + + processTemplate(tp:FileName):FileName == + fp : TextFile := open(tp,"input") + active : Boolean := true + line : String + endInput : Boolean := false + while not (endInput or endOfFile? fp) repeat + if active then + line := getLine fp + line = "endInput" => endInput := true + if line = "beginVerbatim" then + active := false + else + not empty? line => interpretString line + else + line := readLine!(fp) + if line = "endVerbatim" then + active := true + else + writePassiveLine! line + close!(fp) + if not active then + error concat(["Missing `endVerbatim' line in ",tp::String])$String + string(_$fortranOutputFile$Lisp)::FileName + *) \end{chunk} -\begin{chunk}{FGROUP.dotabb} -"FGROUP" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FGROUP"] -"FLAGG" [color="#4488FF",href="bookvol10.2.pdf#nameddest=FLAGG"] -"FLAGG-" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FLAGG"] -"FGROUP" -> "FLAGG" -"FGROUP" -> "FLAGG-" +\begin{chunk}{FTEM.dotabb} +"FTEM" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FTEM"] +"STRING" [color="#88FF44",href="bookvol10.3.pdf#nameddest=STRING"] +"FTEM" -> "STRING" \end{chunk} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain FM FreeModule} +\section{domain FT FortranType} -\begin{chunk}{FreeModule.input} +\begin{chunk}{FortranType.input} )set break resume -)sys rm -f FreeModule.output -)spool FreeModule.output +)sys rm -f FortranType.output +)spool FortranType.output )set message test on )set message auto off )clear all --S 1 of 1 -)show FreeModule +)show FortranType --R ---R FreeModule(R: Ring,S: OrderedSet) is a domain constructor ---R Abbreviation for FreeModule is FM ---R This constructor is not exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for FM +--R FortranType is a domain constructor +--R Abbreviation for FortranType is FT +--R This constructor is exposed in this frame. +--R Issue )edit bookvol10.3.pamphlet to see algebra source code for FT --R --R------------------------------- Operations -------------------------------- ---R ?*? : (%,R) -> % ?*? : (R,%) -> % ---R ?*? : (Integer,%) -> % ?*? : (NonNegativeInteger,%) -> % ---R ?*? : (PositiveInteger,%) -> % ?+? : (%,%) -> % ---R ?-? : (%,%) -> % -? : % -> % ---R ?=? : (%,%) -> Boolean 0 : () -> % ---R coerce : % -> OutputForm hash : % -> SingleInteger ---R latex : % -> String leadingCoefficient : % -> R ---R leadingSupport : % -> S map : ((R -> R),%) -> % ---R monomial : (R,S) -> % reductum : % -> % ---R sample : () -> % zero? : % -> Boolean ---R ?~=? : (%,%) -> Boolean ---R subtractIfCan : (%,%) -> Union(%,"failed") +--R ?=? : (%,%) -> Boolean coerce : FortranScalarType -> % +--R coerce : % -> OutputForm external? : % -> Boolean +--R fortranCharacter : () -> % fortranComplex : () -> % +--R fortranDouble : () -> % fortranDoubleComplex : () -> % +--R fortranInteger : () -> % fortranLogical : () -> % +--R fortranReal : () -> % hash : % -> SingleInteger +--R latex : % -> String ?~=? : (%,%) -> Boolean +--R construct : (Union(fst: FortranScalarType,void: void),List(Polynomial(Integer)),Boolean) -> % +--R construct : (Union(fst: FortranScalarType,void: void),List(Symbol),Boolean) -> % +--R dimensionsOf : % -> List(Polynomial(Integer)) +--R scalarTypeOf : % -> Union(fst: FortranScalarType,void: void) --R --E 1 )spool )lisp (bye) \end{chunk} -\begin{chunk}{FreeModule.help} +\begin{chunk}{FortranType.help} ==================================================================== -FreeModule examples +FortranType examples ==================================================================== -A bi-module is a free module over a ring with generators indexed by an -ordered set. Each element can be expressed as a finite linear -combination of generators. Only non-zero terms are stored. +Creates and manipulates objects which correspond to FORTRAN data types, +including array dimensions. See Also: -o )show FreeModule +o )show FortranType \end{chunk} -\pagehead{FreeModule}{FM} -\pagepic{ps/v103freemodule.ps}{FM}{1.00} +\pagehead{FortranType}{FT} +\pagepic{ps/v103fortrantype.ps}{FT}{1.00} {\bf See}\\ -\pageto{PolynomialRing}{PR} -\pageto{SparseUnivariatePolynomial}{SUP} -\pageto{UnivariatePolynomial}{UP} +\pageto{FortranScalarType}{FST} +\pageto{SymbolTable}{SYMTAB} +\pageto{TheSymbolTable}{SYMS} {\bf Exports:}\\ -\begin{tabular}{lllll} -\cross{FM}{0} & -\cross{FM}{coerce} & -\cross{FM}{hash} & -\cross{FM}{latex} & -\cross{FM}{leadingCoefficient} \\ -\cross{FM}{leadingSupport} & -\cross{FM}{map} & -\cross{FM}{monomial} & -\cross{FM}{reductum} & -\cross{FM}{sample} \\ -\cross{FM}{subtractIfCan} & -\cross{FM}{zero?} & -\cross{FM}{?\~{}=?} & -\cross{FM}{?*?} & -\cross{FM}{?+?} \\ -\cross{FM}{?-?} & -\cross{FM}{-?} & -\cross{FM}{?=?} && +\begin{tabular}{llll} +\cross{FT}{coerce} & +\cross{FT}{construct} & +\cross{FT}{dimensionsOf} & +\cross{FT}{external?} \\ +\cross{FT}{fortranCharacter} & +\cross{FT}{fortranComplex} & +\cross{FT}{fortranDouble} & +\cross{FT}{fortranDoubleComplex} \\ +\cross{FT}{fortranInteger} & +\cross{FT}{fortranLogical} & +\cross{FT}{fortranReal} & +\cross{FT}{hash} \\ +\cross{FT}{latex} & +\cross{FT}{scalarTypeOf} & +\cross{FT}{?=?} & +\cross{FT}{?\~{}=?} \end{tabular} -\begin{chunk}{domain FM FreeModule} -)abbrev domain FM FreeModule -++ Author: Dave Barton, James Davenport, Barry Trager -++ Description: -++ A bi-module is a free module -++ over a ring with generators indexed by an ordered set. -++ Each element can be expressed as a finite linear combination of -++ generators. Only non-zero terms are stored. +\begin{chunk}{domain FT FortranType} +)abbrev domain FT FortranType +++ Author: Mike Dewar +++ Date Created: October 1992 +++ Description: +++ Creates and manipulates objects which correspond to FORTRAN +++ data types, including array dimensions. -FreeModule(R:Ring,S:OrderedSet): - Join(BiModule(R,R),IndexedDirectProductCategory(R,S)) with - if R has CommutativeRing then Module(R) - == IndexedDirectProductAbelianGroup(R,S) add - --representations - Term:= Record(k:S,c:R) - Rep:= List Term - --declarations - x,y: % - r: R - n: Integer - f: R -> R - s: S - --define - if R has EntireRing then - r * x == - zero? r => 0 --- one? r => x - (r = 1) => x - --map(r*#1,x) - [[u.k,r*u.c] for u in x ] - else - r * x == - zero? r => 0 --- one? r => x - (r = 1) => x - --map(r*#1,x) - [[u.k,a] for u in x | (a:=r*u.c) ^= 0$R] - if R has EntireRing then - x * r == - zero? r => 0 --- one? r => x - (r = 1) => x - --map(r*#1,x) - [[u.k,u.c*r] for u in x ] - else - x * r == - zero? r => 0 --- one? r => x - (r = 1) => x - --map(r*#1,x) - [[u.k,a] for u in x | (a:=u.c*r) ^= 0$R] +FortranType() : exports == implementation where - coerce(x) : OutputForm == - null x => (0$R) :: OutputForm - le : List OutputForm := nil - for rec in reverse x repeat - rec.c = 1 => le := cons(rec.k :: OutputForm, le) - le := cons(rec.c :: OutputForm * rec.k :: OutputForm, le) - reduce("+",le) + FST ==> FortranScalarType + FSTU ==> Union(fst:FST,void:"void") + + exports == SetCategory with + coerce : $ -> OutputForm + ++ coerce(x) provides a printable form for x + coerce : FST -> $ + ++ coerce(t) creates an element from a scalar type + scalarTypeOf : $ -> FSTU + ++ scalarTypeOf(t) returns the FORTRAN data type of t + dimensionsOf : $ -> List Polynomial Integer + ++ dimensionsOf(t) returns the dimensions of t + external? : $ -> Boolean + ++ external?(u) returns true if u is declared to be EXTERNAL + construct : (FSTU,List Symbol,Boolean) -> $ + ++ construct(type,dims) creates an element of FortranType + construct : (FSTU,List Polynomial Integer,Boolean) -> $ + ++ construct(type,dims) creates an element of FortranType + fortranReal : () -> $ + ++ fortranReal() returns REAL, an element of FortranType + fortranDouble : () -> $ + ++ fortranDouble() returns DOUBLE PRECISION, an element of FortranType + fortranInteger : () -> $ + ++ fortranInteger() returns INTEGER, an element of FortranType + fortranLogical : () -> $ + ++ fortranLogical() returns LOGICAL, an element of FortranType + fortranComplex : () -> $ + ++ fortranComplex() returns COMPLEX, an element of FortranType + fortranDoubleComplex: () -> $ + ++ fortranDoubleComplex() returns DOUBLE COMPLEX, an element of + ++ FortranType + fortranCharacter : () -> $ + ++ fortranCharacter() returns CHARACTER, an element of FortranType + + implementation == add + + Dims == List Polynomial Integer + + Rep := Record(type : FSTU, dimensions : Dims, external : Boolean) + + coerce(a:$):OutputForm == + t : OutputForm + if external?(a) then + if scalarTypeOf(a) case void then + t := "EXTERNAL"::OutputForm + else + t := blankSeparate(["EXTERNAL"::OutputForm, + coerce(scalarTypeOf a)$FSTU])$OutputForm + else + t := coerce(scalarTypeOf a)$FSTU + empty? dimensionsOf(a) => t + sub(t, + paren([u::OutputForm for u in dimensionsOf(a)])$OutputForm)$OutputForm + + scalarTypeOf(u:$):FSTU == + u.type + + dimensionsOf(u:$):Dims == + u.dimensions + + external?(u:$):Boolean == + u.external + + construct(t:FSTU, d:List Symbol, e:Boolean):$ == + e and not empty? d => error "EXTERNAL objects cannot have dimensions" + not(e) and t case void => error "VOID objects must be EXTERNAL" + construct(t,[l::Polynomial(Integer) for l in d],e)$Rep + + construct(t:FSTU, d:List Polynomial Integer, e:Boolean):$ == + e and not empty? d => error "EXTERNAL objects cannot have dimensions" + not(e) and t case void => error "VOID objects must be EXTERNAL" + construct(t,d,e)$Rep + + coerce(u:FST):$ == + construct([u]$FSTU,[]@List Polynomial Integer,false) + + fortranReal():$ == ("real"::FST)::$ + + fortranDouble():$ == ("double precision"::FST)::$ + + fortranInteger():$ == ("integer"::FST)::$ + + fortranComplex():$ == ("complex"::FST)::$ + + fortranDoubleComplex():$ == ("double complex"::FST)::$ + + fortranCharacter():$ == ("character"::FST)::$ + + fortranLogical():$ == ("logical"::FST)::$ \end{chunk} -\begin{chunk}{COQ FM} -(* domain FM *) +\begin{chunk}{COQ FT} +(* domain FT *) (* + + Dims == List Polynomial Integer + + Rep := Record(type : FSTU, dimensions : Dims, external : Boolean) + + coerce(a:$):OutputForm == + t : OutputForm + if external?(a) then + if scalarTypeOf(a) case void then + t := "EXTERNAL"::OutputForm + else + t := blankSeparate(["EXTERNAL"::OutputForm, + coerce(scalarTypeOf a)$FSTU])$OutputForm + else + t := coerce(scalarTypeOf a)$FSTU + empty? dimensionsOf(a) => t + sub(t, + paren([u::OutputForm for u in dimensionsOf(a)])$OutputForm)$OutputForm + + scalarTypeOf(u:$):FSTU == + u.type + + dimensionsOf(u:$):Dims == + u.dimensions + + external?(u:$):Boolean == + u.external + + construct(t:FSTU, d:List Symbol, e:Boolean):$ == + e and not empty? d => error "EXTERNAL objects cannot have dimensions" + not(e) and t case void => error "VOID objects must be EXTERNAL" + construct(t,[l::Polynomial(Integer) for l in d],e)$Rep + + construct(t:FSTU, d:List Polynomial Integer, e:Boolean):$ == + e and not empty? d => error "EXTERNAL objects cannot have dimensions" + not(e) and t case void => error "VOID objects must be EXTERNAL" + construct(t,d,e)$Rep + + coerce(u:FST):$ == + construct([u]$FSTU,[]@List Polynomial Integer,false) + + fortranReal():$ == ("real"::FST)::$ + + fortranDouble():$ == ("double precision"::FST)::$ + + fortranInteger():$ == ("integer"::FST)::$ + + fortranComplex():$ == ("complex"::FST)::$ + + fortranDoubleComplex():$ == ("double complex"::FST)::$ + + fortranCharacter():$ == ("character"::FST)::$ + + fortranLogical():$ == ("logical"::FST)::$ + *) \end{chunk} -\begin{chunk}{FM.dotabb} -"FM" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FM"] -"FLAGG" [color="#4488FF",href="bookvol10.2.pdf#nameddest=FLAGG"] -"FM" -> "FLAGG" +\begin{chunk}{FT.dotabb} +"FT" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FT"] +"PID" [color="#4488FF",href="bookvol10.2.pdf#nameddest=PID"] +"OAGROUP" [color="#4488FF",href="bookvol10.2.pdf#nameddest=OAGROUP"] +"FT" -> "PID" +"FT" -> "OAGROUP" \end{chunk} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain FM1 FreeModule1} +\section{domain FCOMP FourierComponent} -\begin{chunk}{FreeModule1.input} +\begin{chunk}{FourierComponent.input} )set break resume -)sys rm -f FreeModule1.output -)spool FreeModule1.output +)sys rm -f FourierComponent.output +)spool FourierComponent.output )set message test on )set message auto off )clear all --S 1 of 1 -)show FreeModule1 +)show FourierComponent --R ---R FreeModule1(R: Ring,S: OrderedSet) is a domain constructor ---R Abbreviation for FreeModule1 is FM1 +--R FourierComponent(E: OrderedSet) is a domain constructor +--R Abbreviation for FourierComponent is FCOMP --R This constructor is not exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for FM1 +--R Issue )edit bookvol10.3.pamphlet to see algebra source code for FCOMP --R --R------------------------------- Operations -------------------------------- ---R ?*? : (S,R) -> % ?*? : (R,S) -> % ---R ?*? : (%,R) -> % ?*? : (R,%) -> % ---R ?*? : (Integer,%) -> % ?*? : (NonNegativeInteger,%) -> % ---R ?*? : (PositiveInteger,%) -> % ?+? : (%,%) -> % ---R ?-? : (%,%) -> % -? : % -> % ---R ?=? : (%,%) -> Boolean 0 : () -> % ---R coefficient : (%,S) -> R coefficients : % -> List(R) ---R coerce : S -> % coerce : % -> OutputForm +--R ? Boolean ?<=? : (%,%) -> Boolean +--R ?=? : (%,%) -> Boolean ?>? : (%,%) -> Boolean +--R ?>=? : (%,%) -> Boolean argument : % -> E +--R coerce : % -> OutputForm cos : E -> % --R hash : % -> SingleInteger latex : % -> String ---R leadingCoefficient : % -> R leadingMonomial : % -> S ---R map : ((R -> R),%) -> % monom : (S,R) -> % ---R monomial? : % -> Boolean monomials : % -> List(%) ---R reductum : % -> % retract : % -> S ---R sample : () -> % zero? : % -> Boolean +--R max : (%,%) -> % min : (%,%) -> % +--R sin : E -> % sin? : % -> Boolean --R ?~=? : (%,%) -> Boolean ---R leadingTerm : % -> Record(k: S,c: R) ---R listOfTerms : % -> List(Record(k: S,c: R)) ---R numberOfMonomials : % -> NonNegativeInteger ---R retractIfCan : % -> Union(S,"failed") ---R subtractIfCan : (%,%) -> Union(%,"failed") --R --E 1 )spool )lisp (bye) \end{chunk} -\begin{chunk}{FreeModule1.help} +\begin{chunk}{FourierComponent.help} ==================================================================== -FreeModule1 examples +FourierComponent examples ==================================================================== -This domain implements linear combinations of elements from the domain -S with coefficients in the domain R where S is an ordered set and R is -a ring (which may be non-commutative). This domain is used by domains -of non-commutative algebra such as: XDistributedPolynomial, -XRecursivePolynomial. +This domain creates kernels for use in Fourier series See Also: -o )show FreeModule1 +o )show FourierComponent \end{chunk} -\pagehead{FreeModule1}{FM1} -\pagepic{ps/v103freemodule1.ps}{FM1}{1.00} +\pagehead{FourierComponent}{FCOMP} +\pagepic{ps/v103fouriercomponent.ps}{FCOMP}{1.00} +{\bf See}\\ +\pageto{FourierSeries}{FSERIES} {\bf Exports:}\\ \begin{tabular}{lllll} -\cross{FM1}{0} & -\cross{FM1}{coefficient} & -\cross{FM1}{coefficients} & -\cross{FM1}{coerce} & -\cross{FM1}{hash} \\ -\cross{FM1}{latex} & -\cross{FM1}{leadingCoefficient} & -\cross{FM1}{leadingMonomial} & -\cross{FM1}{leadingTerm} & -\cross{FM1}{listOfTerms} \\ -\cross{FM1}{map} & -\cross{FM1}{monom} & -\cross{FM1}{monomial?} & -\cross{FM1}{monomials} & -\cross{FM1}{numberOfMonomials} \\ -\cross{FM1}{reductum} & -\cross{FM1}{retract} & -\cross{FM1}{retractIfCan} & -\cross{FM1}{sample} & -\cross{FM1}{subtractIfCan} \\ -\cross{FM1}{zero?} & -\cross{FM1}{?\~{}=?} & -\cross{FM1}{?*?} & -\cross{FM1}{?+?} & -\cross{FM1}{?-?} \\ -\cross{FM1}{-?} & -\cross{FM1}{?=?} &&& +\cross{FCOMP}{argument} & +\cross{FCOMP}{coerce} & +\cross{FCOMP}{cos} & +\cross{FCOMP}{hash} & +\cross{FCOMP}{latex} \\ +\cross{FCOMP}{max} & +\cross{FCOMP}{min} & +\cross{FCOMP}{sin} & +\cross{FCOMP}{sin?} & +\cross{FCOMP}{?\~{}=?} \\ +\cross{FCOMP}{?$<$?} & +\cross{FCOMP}{?$<=$?} & +\cross{FCOMP}{?=?} & +\cross{FCOMP}{?$>$?} & +\cross{FCOMP}{?$>=$?} \end{tabular} -\begin{chunk}{domain FM1 FreeModule1} -)abbrev domain FM1 FreeModule1 -++ Author: Michel Petitot petitot@lifl.fr -++ Date Created: 91 -++ Date Last Updated: 7 Juillet 92 -++ Fix History: compilation v 2.1 le 13 dec 98 -++ Description: -++ This domain implements linear combinations -++ of elements from the domain \spad{S} with coefficients -++ in the domain \spad{R} where \spad{S} is an ordered set -++ and \spad{R} is a ring (which may be non-commutative). -++ This domain is used by domains of non-commutative algebra such as: -++ XDistributedPolynomial, XRecursivePolynomial. - -FreeModule1(R:Ring,S:OrderedSet): FMcat == FMdef where - EX ==> OutputForm - TERM ==> Record(k:S,c:R) - - FMcat == FreeModuleCat(R,S) with - "*":(S,R) -> % - ++ \spad{s*r} returns the product \spad{r*s} - ++ used by \spadtype{XRecursivePolynomial} - FMdef == FreeModule(R,S) add - -- representation - Rep := List TERM - - -- declarations - lt: List TERM - x : % - r : R - s : S - - -- define - numberOfMonomials p == - # (p::Rep) - - listOfTerms(x) == x:List TERM - - leadingTerm x == x.first - leadingMonomial x == x.first.k - coefficients x == [t.c for t in x] - monomials x == [ monom (t.k, t.c) for t in x] - - retractIfCan x == - numberOfMonomials(x) ^= 1 => "failed" - x.first.c = 1 => x.first.k - "failed" - - coerce(s:S):% == [[s,1$R]] - retract x == - (rr := retractIfCan x) case "failed" => error "FM1.retract impossible" - rr :: S - - if R has noZeroDivisors then - r * x == - r = 0 => 0 - [[u.k,r * u.c]$TERM for u in x] - x * r == - r = 0 => 0 - [[u.k,u.c * r]$TERM for u in x] - else - r * x == - r = 0 => 0 - [[u.k,a] for u in x | not (a:=r*u.c)= 0$R] - x * r == - r = 0 => 0 - [[u.k,a] for u in x | not (a:=u.c*r)= 0$R] +\begin{chunk}{domain FCOMP FourierComponent} +)abbrev domain FCOMP FourierComponent +++ Author: James Davenport +++ Date Created: 17 April 1992 +++ Date Last Updated: 12 June 1992 +++ Description: +++ This domain creates kernels for use in Fourier series - r * s == - r = 0 => 0 - [[s,r]$TERM] +FourierComponent(E:OrderedSet): + OrderedSet with + sin: E -> $ + ++ sin(x) makes a sin kernel for use in Fourier series + cos: E -> $ + ++ cos(x) makes a cos kernel for use in Fourier series + sin?: $ -> Boolean + ++ sin?(x) returns true if term is a sin, otherwise false + argument: $ -> E + ++ argument(x) returns the argument of a given sin/cos expressions + == + add + --representations + Rep:=Record(SinIfTrue:Boolean, arg:E) + e:E + x,y:$ - s * r == - r = 0 => 0 - [[s,r]$TERM] + sin e == [true,e] - monom(b,r):% == [[b,r]$TERM] + cos e == [false,e] - outTerm(r:R, s:S):EX == - r=1 => s::EX - r::EX * s::EX + sin? x == x.SinIfTrue - coerce(a:%):EX == - empty? a => (0$R)::EX - reduce(_+, reverse_! [outTerm(t.c, t.k) for t in a])$List(EX) + argument x == x.arg - coefficient(x,s) == - null x => 0$R - x.first.k > s => coefficient(rest x,s) - x.first.k = s => x.first.c - 0$R + coerce(x):OutputForm == + hconcat((if x.SinIfTrue then "sin" else "cos")::OutputForm, + bracket((x.arg)::OutputForm)) + x true + y.arg < x.arg => false + x.SinIfTrue => false + y.SinIfTrue \end{chunk} -\begin{chunk}{COQ FM1} -(* domain FM1 *) +\begin{chunk}{COQ FCOMP} +(* domain FCOMP *) (* -*) - -\end{chunk} - -\begin{chunk}{FM1.dotabb} -"FM1" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FM1"] -"FLAGG" [color="#4488FF",href="bookvol10.2.pdf#nameddest=FLAGG"] -"FM1" -> "FLAGG" - -\end{chunk} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain FMONOID FreeMonoid} - -\begin{chunk}{FreeMonoid.input} -)set break resume -)sys rm -f FreeMonoid.output -)spool FreeMonoid.output -)set message test on -)set message auto off -)clear all - ---S 1 of 1 -)show FreeMonoid ---R ---R FreeMonoid(S: SetCategory) is a domain constructor ---R Abbreviation for FreeMonoid is FMONOID ---R This constructor is not exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for FMONOID ---R ---R------------------------------- Operations -------------------------------- ---R ?*? : (%,S) -> % ?*? : (S,%) -> % ---R ?*? : (%,%) -> % ?**? : (S,NonNegativeInteger) -> % ---R ?**? : (%,NonNegativeInteger) -> % ?**? : (%,PositiveInteger) -> % ---R ?=? : (%,%) -> Boolean 1 : () -> % ---R ?^? : (%,NonNegativeInteger) -> % ?^? : (%,PositiveInteger) -> % ---R coerce : S -> % coerce : % -> OutputForm ---R hash : % -> SingleInteger hclf : (%,%) -> % ---R hcrf : (%,%) -> % latex : % -> String ---R lquo : (%,%) -> Union(%,"failed") mapGen : ((S -> S),%) -> % ---R max : (%,%) -> % if S has ORDSET min : (%,%) -> % if S has ORDSET ---R nthFactor : (%,Integer) -> S one? : % -> Boolean ---R recip : % -> Union(%,"failed") retract : % -> S ---R rquo : (%,%) -> Union(%,"failed") sample : () -> % ---R size : % -> NonNegativeInteger ?~=? : (%,%) -> Boolean ---R ? Boolean if S has ORDSET ---R ?<=? : (%,%) -> Boolean if S has ORDSET ---R ?>? : (%,%) -> Boolean if S has ORDSET ---R ?>=? : (%,%) -> Boolean if S has ORDSET ---R divide : (%,%) -> Union(Record(lm: %,rm: %),"failed") ---R factors : % -> List(Record(gen: S,exp: NonNegativeInteger)) ---R mapExpon : ((NonNegativeInteger -> NonNegativeInteger),%) -> % ---R nthExpon : (%,Integer) -> NonNegativeInteger ---R overlap : (%,%) -> Record(lm: %,mm: %,rm: %) ---R retractIfCan : % -> Union(S,"failed") ---R ---E 1 - -)spool -)lisp (bye) -\end{chunk} -\begin{chunk}{FreeMonoid.help} -==================================================================== -FreeMonoid examples -==================================================================== - -Free monoid on any set of generators. The free monoid on a set S is -the monoid of finite products of the form reduce(*,[si ** ni]) where -the si's are in S, and the ni's are nonnegative integers. The -multiplication is not commutative. - -See Also: -o )show FreeMonoid - -\end{chunk} - -\pagehead{FreeMonoid}{FMONOID} -\pagepic{ps/v103freemonoid.ps}{FMONOID}{1.00} -{\bf See}\\ -\pageto{ListMonoidOps}{LMOPS} -\pageto{FreeGroup}{FGROUP} -\pageto{InnerFreeAbelianMonoid}{IFAMON} -\pageto{FreeAbelianMonoid}{FAMONOID} -\pageto{FreeAbelianGroup}{FAGROUP} - -{\bf Exports:}\\ -\begin{tabular}{lllll} -\cross{FMONOID}{1} & -\cross{FMONOID}{coerce} & -\cross{FMONOID}{divide} & -\cross{FMONOID}{factors} & -\cross{FMONOID}{hash} \\ -\cross{FMONOID}{hclf} & -\cross{FMONOID}{hcrf} & -\cross{FMONOID}{latex} & -\cross{FMONOID}{lquo} & -\cross{FMONOID}{mapExpon} \\ -\cross{FMONOID}{mapGen} & -\cross{FMONOID}{max} & -\cross{FMONOID}{min} & -\cross{FMONOID}{nthExpon} & -\cross{FMONOID}{nthFactor} \\ -\cross{FMONOID}{one?} & -\cross{FMONOID}{overlap} & -\cross{FMONOID}{recip} & -\cross{FMONOID}{rquo} & -\cross{FMONOID}{retract} \\ -\cross{FMONOID}{retractIfCan} & -\cross{FMONOID}{sample} & -\cross{FMONOID}{size} & -\cross{FMONOID}{?\~{}=?} & -\cross{FMONOID}{?**?} \\ -\cross{FMONOID}{?$<$?} & -\cross{FMONOID}{?$<=$?} & -\cross{FMONOID}{?$>$?} & -\cross{FMONOID}{?$>=$?} & -\cross{FMONOID}{?\^{}?} \\ -\cross{FMONOID}{?*?} & -\cross{FMONOID}{?=?} &&& -\end{tabular} - -\begin{chunk}{domain FMONOID FreeMonoid} -)abbrev domain FMONOID FreeMonoid -++ Author: Stephen M. Watt -++ Date Last Updated: 6 June 1991 -++ Description: -++ Free monoid on any set of generators -++ The free monoid on a set S is the monoid of finite products of -++ the form \spad{reduce(*,[si ** ni])} where the si's are in S, and the ni's -++ are nonnegative integers. The multiplication is not commutative. - -FreeMonoid(S: SetCategory): FMcategory == FMdefinition where - NNI ==> NonNegativeInteger - REC ==> Record(gen: S, exp: NonNegativeInteger) - Ex ==> OutputForm - - FMcategory ==> Join(Monoid, RetractableTo S) with - "*": (S, $) -> $ - ++ s * x returns the product of x by s on the left. - "*": ($, S) -> $ - ++ x * s returns the product of x by s on the right. - "**": (S, NonNegativeInteger) -> $ - ++ s ** n returns the product of s by itself n times. - hclf: ($, $) -> $ - ++ hclf(x, y) returns the highest common left factor of x and y, - ++ i.e. the largest d such that \spad{x = d a} and \spad{y = d b}. - hcrf: ($, $) -> $ - ++ hcrf(x, y) returns the highest common right factor of x and y, - ++ i.e. the largest d such that \spad{x = a d} and \spad{y = b d}. - lquo: ($, $) -> Union($, "failed") - ++ lquo(x, y) returns the exact left quotient of x by y i.e. - ++ q such that \spad{x = y * q}, - ++ "failed" if x is not of the form \spad{y * q}. - rquo: ($, $) -> Union($, "failed") - ++ rquo(x, y) returns the exact right quotient of x by y i.e. - ++ q such that \spad{x = q * y}, - ++ "failed" if x is not of the form \spad{q * y}. - divide: ($, $) -> Union(Record(lm: $, rm: $), "failed") - ++ divide(x, y) returns the left and right exact quotients of - ++ x by y, i.e. \spad{[l, r]} such that \spad{x = l * y * r}, - ++ "failed" if x is not of the form \spad{l * y * r}. - overlap: ($, $) -> Record(lm: $, mm: $, rm: $) - ++ overlap(x, y) returns \spad{[l, m, r]} such that - ++ \spad{x = l * m}, \spad{y = m * r} and l and r have no overlap, - ++ i.e. \spad{overlap(l, r) = [l, 1, r]}. - size : $ -> NNI - ++ size(x) returns the number of monomials in x. - factors : $ -> List Record(gen: S, exp: NonNegativeInteger) - ++ factors(a1\^e1,...,an\^en) returns \spad{[[a1, e1],...,[an, en]]}. - nthExpon : ($, Integer) -> NonNegativeInteger - ++ nthExpon(x, n) returns the exponent of the n^th monomial of x. - nthFactor : ($, Integer) -> S - ++ nthFactor(x, n) returns the factor of the n^th monomial of x. - mapExpon : (NNI -> NNI, $) -> $ - ++ mapExpon(f, a1\^e1 ... an\^en) returns \spad{a1\^f(e1) ... an\^f(en)}. - mapGen : (S -> S, $) -> $ - ++ mapGen(f, a1\^e1 ... an\^en) returns \spad{f(a1)\^e1 ... f(an)\^en}. - if S has OrderedSet then OrderedSet - - FMdefinition ==> ListMonoidOps(S, NonNegativeInteger, 1) add - Rep := ListMonoidOps(S, NonNegativeInteger, 1) - - 1 == makeUnit() - one? f == empty? listOfMonoms f - coerce(f:$): Ex == outputForm(f, "*", "**", 1) - hcrf(f, g) == reverse_! hclf(reverse f, reverse g) - f:$ * s:S == rightMult(f, s) - s:S * f:$ == leftMult(s, f) - factors f == copy listOfMonoms f - mapExpon(f, x) == mapExpon(f, x)$Rep - mapGen(f, x) == mapGen(f, x)$Rep - s:S ** n:NonNegativeInteger == makeTerm(s, n) - - f:$ * g:$ == --- one? f => g - (f = 1) => g --- one? g => f - (g = 1) => f - lg := listOfMonoms g - ls := last(lf := listOfMonoms f) - ls.gen = lg.first.gen => - setlast_!(h := copy lf,[lg.first.gen,lg.first.exp+ls.exp]) - makeMulti concat(h, rest lg) - makeMulti concat(lf, lg) - - overlap(la, ar) == --- one? la or one? ar => [la, 1, ar] - (la = 1) or (ar = 1) => [la, 1, ar] - lla := la0 := listOfMonoms la - lar := listOfMonoms ar - l:List(REC) := empty() - while not empty? lla repeat - if lla.first.gen = lar.first.gen then - if lla.first.exp < lar.first.exp and empty? rest lla then - return [makeMulti l, - makeTerm(lla.first.gen, lla.first.exp), - makeMulti concat([lar.first.gen, - (lar.first.exp - lla.first.exp)::NNI], - rest lar)] - if lla.first.exp >= lar.first.exp then - if (ru:= lquo(makeMulti rest lar, - makeMulti rest lla)) case $ then - if lla.first.exp > lar.first.exp then - l := concat_!(l, [lla.first.gen, - (lla.first.exp - lar.first.exp)::NNI]) - m := concat([lla.first.gen, lar.first.exp], - rest lla) - else m := lla - return [makeMulti l, makeMulti m, ru::$] - l := concat_!(l, lla.first) - lla := rest lla - [makeMulti la0, 1, makeMulti lar] - - divide(lar, a) == --- one? a => [lar, 1] - (a = 1) => [lar, 1] - Na : Integer := #(la := listOfMonoms a) - Nlar : Integer := #(llar := listOfMonoms lar) - l:List(REC) := empty() - while Na <= Nlar repeat - if llar.first.gen = la.first.gen and - llar.first.exp >= la.first.exp then - -- Can match a portion of this lar factor. - -- Now match tail. - (q:=lquo(makeMulti rest llar,makeMulti rest la))case $ => - if llar.first.exp > la.first.exp then - l := concat_!(l, [la.first.gen, - (llar.first.exp - la.first.exp)::NNI]) - return [makeMulti l, q::$] - l := concat_!(l, first llar) - llar := rest llar - Nlar := Nlar - 1 - "failed" + Rep:=Record(SinIfTrue:Boolean, arg:E) + e:E + x,y:$ - hclf(f, g) == - h:List(REC) := empty() - for f0 in listOfMonoms f for g0 in listOfMonoms g repeat - f0.gen ^= g0.gen => return makeMulti h - h := concat_!(h, [f0.gen, min(f0.exp, g0.exp)]) - f0.exp ^= g0.exp => return makeMulti h - makeMulti h + sin e == [true,e] - lquo(aq, a) == - size a > #(laq := copy listOfMonoms aq) => "failed" - for a0 in listOfMonoms a repeat - a0.gen ^= laq.first.gen or a0.exp > laq.first.exp => - return "failed" - if a0.exp = laq.first.exp then laq := rest laq - else setfirst_!(laq, [laq.first.gen, - (laq.first.exp - a0.exp)::NNI]) - makeMulti laq + cos e == [false,e] - rquo(qa, a) == - (u := lquo(reverse qa, reverse a)) case "failed" => "failed" - reverse_!(u::$) + sin? x == x.SinIfTrue - if S has OrderedSet then - a < b == - la := listOfMonoms a - lb := listOfMonoms b - na: Integer := #la - nb: Integer := #lb - while na > 0 and nb > 0 repeat - la.first.gen > lb.first.gen => return false - la.first.gen < lb.first.gen => return true - if la.first.exp = lb.first.exp then - la:=rest la - lb:=rest lb - na:=na - 1 - nb:=nb - 1 - else if la.first.exp > lb.first.exp then - la:=concat([la.first.gen, - (la.first.exp - lb.first.exp)::NNI], rest lb) - lb:=rest lb - nb:=nb - 1 - else - lb:=concat([lb.first.gen, - (lb.first.exp-la.first.exp)::NNI], rest la) - la:=rest la - na:=na-1 - empty? la and not empty? lb + argument x == x.arg -\end{chunk} + coerce(x):OutputForm == + hconcat((if x.SinIfTrue then "sin" else "cos")::OutputForm, + bracket((x.arg)::OutputForm)) + x true + y.arg < x.arg => false + x.SinIfTrue => false + y.SinIfTrue -\begin{chunk}{COQ FMONOID} -(* domain FMONOID *) -(* *) \end{chunk} -\begin{chunk}{FMONOID.dotabb} -"FMONOID" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FMONOID"] -"FLAGG" [color="#4488FF",href="bookvol10.2.pdf#nameddest=FLAGG"] -"FLAGG-" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FLAGG"] -"FMONOID" -> "FLAGG-" -"FMONOID" -> "FLAGG" +\begin{chunk}{FCOMP.dotabb} +"FCOMP" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FCOMP"] +"ORDSET" [color="#4488FF",href="bookvol10.2.pdf#nameddest=ORDSET"] +"FCOMP" -> "ORDSET" \end{chunk} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain FNLA FreeNilpotentLie} +\section{domain FSERIES FourierSeries} -\begin{chunk}{FreeNilpotentLie.input} +\begin{chunk}{FourierSeries.input} )set break resume -)sys rm -f FreeNilpotentLie.output -)spool FreeNilpotentLie.output +)sys rm -f FourierSeries.output +)spool FourierSeries.output )set message test on )set message auto off )clear all --S 1 of 1 -)show FreeNilpotentLie +)show FourierSeries --R ---R FreeNilpotentLie(n: NonNegativeInteger,class: NonNegativeInteger,R: CommutativeRing) is a domain constructor ---R Abbreviation for FreeNilpotentLie is FNLA +--R FourierSeries(R: Join(CommutativeRing,Algebra(Fraction(Integer))),E: Join(OrderedSet,AbelianGroup)) is a domain constructor +--R Abbreviation for FourierSeries is FSERIES --R This constructor is exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for FNLA +--R Issue )edit bookvol10.3.pamphlet to see algebra source code for FSERIES --R --R------------------------------- Operations -------------------------------- --R ?*? : (R,%) -> % ?*? : (%,R) -> % --R ?*? : (%,%) -> % ?*? : (Integer,%) -> % --R ?*? : (NonNegativeInteger,%) -> % ?*? : (PositiveInteger,%) -> % ---R ?**? : (%,PositiveInteger) -> % ?+? : (%,%) -> % ---R ?-? : (%,%) -> % -? : % -> % ---R ?=? : (%,%) -> Boolean 0 : () -> % ---R antiCommutator : (%,%) -> % associator : (%,%,%) -> % ---R coerce : % -> OutputForm commutator : (%,%) -> % ---R deepExpand : % -> OutputForm dimension : () -> NonNegativeInteger ---R generator : NonNegativeInteger -> % hash : % -> SingleInteger ---R latex : % -> String sample : () -> % ---R shallowExpand : % -> OutputForm zero? : % -> Boolean +--R ?**? : (%,NonNegativeInteger) -> % ?**? : (%,PositiveInteger) -> % +--R ?+? : (%,%) -> % ?-? : (%,%) -> % +--R -? : % -> % ?=? : (%,%) -> Boolean +--R 1 : () -> % 0 : () -> % +--R ?^? : (%,NonNegativeInteger) -> % ?^? : (%,PositiveInteger) -> % +--R coerce : FourierComponent(E) -> % coerce : R -> % +--R coerce : Integer -> % coerce : % -> OutputForm +--R hash : % -> SingleInteger latex : % -> String +--R makeCos : (E,R) -> % makeSin : (E,R) -> % +--R one? : % -> Boolean recip : % -> Union(%,"failed") +--R sample : () -> % zero? : % -> Boolean --R ?~=? : (%,%) -> Boolean ---R leftPower : (%,PositiveInteger) -> % ---R plenaryPower : (%,PositiveInteger) -> % ---R rightPower : (%,PositiveInteger) -> % +--R characteristic : () -> NonNegativeInteger --R subtractIfCan : (%,%) -> Union(%,"failed") --R --E 1 @@ -65429,7405 +72758,13235 @@ FreeMonoid(S: SetCategory): FMcategory == FMdefinition where )spool )lisp (bye) \end{chunk} -\begin{chunk}{FreeNilpotentLie.help} +\begin{chunk}{FourierSeries.help} ==================================================================== -FreeNilpotentLie examples +FourierSeries examples ==================================================================== -Generate the Free Lie Algebra over a ring R with identity; -A P. Hall basis is generated by a package call to HallBasis. +This domain converts terms into Fourier series See Also: -o )show FreeNilpotentLie +o )show FourierSeries \end{chunk} -\pagehead{FreeNilpotentLie}{FNLA} -\pagepic{ps/v103freenilpotentlie.ps}{FNLA}{1.00} +\pagehead{FourierSeries}{FSERIES} +\pagepic{ps/v103fourierseries.ps}{FSERIES}{1.00} {\bf See}\\ -\pageto{OrdSetInts}{OSI} -\pageto{Commutator}{COMM} +\pageto{FourierComponent}{FCOMP} {\bf Exports:}\\ \begin{tabular}{lllll} -\cross{FNLA}{0} & -\cross{FNLA}{antiCommutator} & -\cross{FNLA}{associator} & -\cross{FNLA}{coerce} & -\cross{FNLA}{commutator} \\ -\cross{FNLA}{deepExpand} & -\cross{FNLA}{dimension} & -\cross{FNLA}{generator} & -\cross{FNLA}{hash} & -\cross{FNLA}{latex} \\ -\cross{FNLA}{leftPower} & -\cross{FNLA}{plenaryPower} & -\cross{FNLA}{rightPower} & -\cross{FNLA}{sample} & -\cross{FNLA}{shallowExpand} \\ -\cross{FNLA}{subtractIfCan} & -\cross{FNLA}{zero?} & -\cross{FNLA}{?\~{}=?} & -\cross{FNLA}{?*?} & -\cross{FNLA}{?**?} \\ -\cross{FNLA}{?+?} & -\cross{FNLA}{?-?} & -\cross{FNLA}{-?} & -\cross{FNLA}{?=?} & +\cross{FSERIES}{0} & +\cross{FSERIES}{1} & +\cross{FSERIES}{characteristic} & +\cross{FSERIES}{coerce} & +\cross{FSERIES}{hash} \\ +\cross{FSERIES}{latex} & +\cross{FSERIES}{makeCos} & +\cross{FSERIES}{makeSin} & +\cross{FSERIES}{one?} & +\cross{FSERIES}{recip} \\ +\cross{FSERIES}{sample} & +\cross{FSERIES}{subtractIfCan} & +\cross{FSERIES}{zero?} & +\cross{FSERIES}{?\~{}=?} & +\cross{FSERIES}{?*?} \\ +\cross{FSERIES}{?**?} & +\cross{FSERIES}{?\^{}?} & +\cross{FSERIES}{?+?} & +\cross{FSERIES}{?-?} & +\cross{FSERIES}{-?} \\ +\cross{FSERIES}{?=?} &&&& \end{tabular} -\begin{chunk}{domain FNLA FreeNilpotentLie} -)abbrev domain FNLA FreeNilpotentLie -++ Author: Larry Lambe -++ Date Created: July 1988 -++ Date Last Updated: March 13 1991 +\begin{chunk}{domain FSERIES FourierSeries} +)abbrev domain FSERIES FourierSeries +++ Author: James Davenport +++ Date Created: 17 April 1992 ++ Description: -++ Generate the Free Lie Algebra over a ring R with identity; -++ A P. Hall basis is generated by a package call to HallBasis. +++ This domain converts terms into Fourier series -FreeNilpotentLie(n:NNI,class:NNI,R: CommutativeRing): Export == Implement where - B ==> Boolean - Com ==> Commutator - HB ==> HallBasis - I ==> Integer - NNI ==> NonNegativeInteger - O ==> OutputForm - OSI ==> OrdSetInts - FM ==> FreeModule(R,OSI) - VI ==> Vector Integer - VLI ==> Vector List Integer - lC ==> leadingCoefficient - lS ==> leadingSupport +FourierSeries(R:Join(CommutativeRing,Algebra(Fraction Integer)), + E:Join(OrderedSet,AbelianGroup)): + Algebra(R) with + if E has canonical and R has canonical then canonical + coerce: R -> $ + ++ coerce(r) converts coefficients into Fourier Series + coerce: FourierComponent(E) -> $ + ++ coerce(c) converts sin/cos terms into Fourier Series + makeSin: (E,R) -> $ + ++ makeSin(e,r) makes a sin expression with given + ++ argument and coefficient + makeCos: (E,R) -> $ + ++ makeCos(e,r) makes a sin expression with given + ++argument and coefficient + == FreeModule(R,FourierComponent(E)) + add + --representations + Term := Record(k:FourierComponent(E),c:R) + Rep := List Term + multiply : (Term,Term) -> $ + w,x1,x2:$ + t1,t2:Term + n:NonNegativeInteger + z:Integer + e:FourierComponent(E) + a:E + r:R - Export ==> NonAssociativeAlgebra(R) with - dimension : () -> NNI - ++ dimension() is the rank of this Lie algebra - deepExpand : % -> O - ++ deepExpand(x) is not documented - shallowExpand : % -> O - ++ shallowExpand(x) is not documented - generator : NNI -> % - ++ generator(i) is the ith Hall Basis element + 1 == [[cos 0,1]] - Implement ==> FM add - Rep := FM - f,g : % + coerce e == + sin? e and zero? argument e => 0 + if argument e < 0 then + not sin? e => e:=cos(- argument e) + return [[sin(- argument e),-1]] + [[e,1]] - coms:VLI - coms := generate(n,class)$HB + multiply(t1,t2) == + r:=(t1.c*t2.c)*(1/2) + s1:=argument t1.k + s2:=argument t2.k + sum:=s1+s2 + diff:=s1-s2 + sin? t1.k => + sin? t2.k => + makeCos(diff,r) + makeCos(sum,-r) + makeSin(sum,r) + makeSin(diff,r) + sin? t2.k => + makeSin(sum,r) + makeSin(diff,r) + makeCos(diff,r) + makeCos(sum,r) - dimension == #coms + x1*x2 == + null x1 => 0 + null x2 => 0 + +/[+/[multiply(t1,t2) for t2 in x2] for t1 in x1] - have : (I,I) -> % - -- have(left,right) is a lookup function for basic commutators - -- already generated; if the nth basic commutator is - -- [left,wt,right], then have(left,right) = n - have(i,j) == - wt:I := coms(i).2 + coms(j).2 - wt > class => 0 - lo:I := 1 - hi:I := dimension - while hi-lo > 1 repeat - mid:I := (hi+lo) quo 2 - if coms(mid).2 < wt then lo := mid else hi := mid - while coms(hi).1 < i repeat hi := hi + 1 - while coms(hi).3 < j repeat hi := hi + 1 - monomial(1,hi::OSI)$FM + makeCos(a,r) == + a<0 => [[cos(-a),r]] + [[cos a,r]] - generator(i) == - i > dimension => 0$Rep - monomial(1,i::OSI)$FM + makeSin(a,r) == + zero? a => [] + a<0 => [[sin(-a),-r]] + [[sin a,r]] - putIn : I -> % - putIn(i) == - monomial(1$R,i::OSI)$FM +\end{chunk} - brkt : (I,%) -> % - brkt(k,f) == - f = 0 => 0 - dg:I := value lS f - reductum(f) = 0 => - k = dg => 0 - k > dg => -lC(f)*brkt(dg, putIn(k)) - inHallBasis?(n,k,dg,coms(dg).1) => lC(f)*have(k, dg) - lC(f)*( brkt(coms(dg).1, _ - brkt(k,putIn coms(dg).3)) - brkt(coms(dg).3, _ - brkt(k,putIn coms(dg).1) )) - brkt(k,monomial(lC f,lS f)$FM)+brkt(k,reductum f) +\begin{chunk}{COQ FSERIES} +(* domain FSERIES *) +(* + Term := Record(k:FourierComponent(E),c:R) + Rep := List Term + multiply : (Term,Term) -> $ + w,x1,x2:$ + t1,t2:Term + n:NonNegativeInteger + z:Integer + e:FourierComponent(E) + a:E + r:R - f*g == - reductum(f) = 0 => - lC(f)*brkt(value(lS f),g) - monomial(lC f,lS f)$FM*g + reductum(f)*g + 1 == [[cos 0,1]] - Fac : I -> Com - -- an auxilliary function used for output of Free Lie algebra - -- elements (see expand) - Fac(m) == - coms(m).1 = 0 => mkcomm(m)$Com - mkcomm(Fac coms(m).1, Fac coms(m).3) + coerce e == + sin? e and zero? argument e => 0 + if argument e < 0 then + not sin? e => e:=cos(- argument e) + return [[sin(- argument e),-1]] + [[e,1]] - shallowE : (R,OSI) -> O - shallowE(r,s) == - k := value s - r = 1 => - k <= n => s::O - mkcomm(mkcomm(coms(k).1)$Com,mkcomm(coms(k).3)$Com)$Com::O - k <= n => r::O * s::O - r::O * mkcomm(mkcomm(coms(k).1)$Com,mkcomm(coms(k).3)$Com)$Com::O + multiply(t1,t2) == + r:=(t1.c*t2.c)*(1/2) + s1:=argument t1.k + s2:=argument t2.k + sum:=s1+s2 + diff:=s1-s2 + sin? t1.k => + sin? t2.k => + makeCos(diff,r) + makeCos(sum,-r) + makeSin(sum,r) + makeSin(diff,r) + sin? t2.k => + makeSin(sum,r) + makeSin(diff,r) + makeCos(diff,r) + makeCos(sum,r) - shallowExpand(f) == - f = 0 => 0::O - reductum(f) = 0 => shallowE(lC f,lS f) - shallowE(lC f,lS f) + shallowExpand(reductum f) + x1*x2 == + null x1 => 0 + null x2 => 0 + +/[+/[multiply(t1,t2) for t2 in x2] for t1 in x1] - deepExpand(f) == - f = 0 => 0::O - reductum(f) = 0 => - lC(f)=1 => Fac(value(lS f))::O - lC(f)::O * Fac(value(lS f))::O - lC(f)=1 => Fac(value(lS f))::O + deepExpand(reductum f) - lC(f)::O * Fac(value(lS f))::O + deepExpand(reductum f) + makeCos(a,r) == + a<0 => [[cos(-a),r]] + [[cos a,r]] -\end{chunk} + makeSin(a,r) == + zero? a => [] + a<0 => [[sin(-a),-r]] + [[sin a,r]] -\begin{chunk}{COQ FNLA} -(* domain FNLA *) -(* *) \end{chunk} -\begin{chunk}{FNLA.dotabb} -"FNLA" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FNLA"] -"IVECTOR" [color="#88FF44",href="bookvol10.3.pdf#nameddest=IVECTOR"] -"FNLA" -> "IVECTOR" +\begin{chunk}{FSERIES.dotabb} +"FSERIES" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FSERIES"] +"PID" [color="#4488FF",href="bookvol10.2.pdf#nameddest=PID"] +"OAGROUP" [color="#4488FF",href="bookvol10.2.pdf#nameddest=OAGROUP"] +"FSERIES" -> "PID" +"FSERIES" -> "OAGROUP" \end{chunk} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain FPARFRAC FullPartialFractionExpansion} +\section{domain FRAC Fraction} -\begin{chunk}{FullPartialFractionExpansion.input} +\begin{chunk}{Fraction.input} )set break resume -)sys rm -f FullPartialFractionExpansion.output -)spool FullPartialFractionExpansion.output +)sys rm -f Fraction.output +)spool Fraction.output )set message test on )set message auto off )clear all ---S 1 of 17 -Fx := FRAC UP(x, FRAC INT) +--S 1 of 13 +a := 11/12 --R --R ---R (1) Fraction(UnivariatePolynomial(x,Fraction(Integer))) ---R Type: Domain +--R 11 +--R (1) -- +--R 12 +--R Type: Fraction(Integer) --E 1 ---S 2 of 17 -f : Fx := 36 / (x**5-2*x**4-2*x**3+4*x**2+x-2) +--S 2 of 13 +b := 23/24 --R --R ---R 36 ---R (2) ---------------------------- ---R 5 4 3 2 ---R x - 2x - 2x + 4x + x - 2 ---R Type: Fraction(UnivariatePolynomial(x,Fraction(Integer))) +--R 23 +--R (2) -- +--R 24 +--R Type: Fraction(Integer) --E 2 ---S 3 of 17 -g := fullPartialFraction f +--S 3 of 13 +3 - a*b**2 + a + b/a --R --R ---R 4 4 --+ - 3%A - 6 ---R (3) ----- - ----- + > --------- ---R x - 2 x + 1 --+ 2 ---R 2 (x - %A) ---R %A - 1= 0 ---RType: FullPartialFractionExpansion(Fraction(Integer),UnivariatePolynomial(x,Fraction(Integer))) +--R 313271 +--R (3) ------ +--R 76032 +--R Type: Fraction(Integer) --E 3 ---S 4 of 17 -g :: Fx +--S 4 of 13 +numer(a) --R --R ---R 36 ---R (4) ---------------------------- ---R 5 4 3 2 ---R x - 2x - 2x + 4x + x - 2 ---R Type: Fraction(UnivariatePolynomial(x,Fraction(Integer))) +--R (4) 11 +--R Type: PositiveInteger --E 4 ---S 5 of 17 -g5 := D(g, 5) +--S 5 of 13 +denom(b) --R --R ---R 480 480 --+ 2160%A + 4320 ---R (5) - -------- + -------- + > ------------- ---R 6 6 --+ 7 ---R (x - 2) (x + 1) 2 (x - %A) ---R %A - 1= 0 ---RType: FullPartialFractionExpansion(Fraction(Integer),UnivariatePolynomial(x,Fraction(Integer))) +--R (5) 24 +--R Type: PositiveInteger --E 5 ---S 6 of 17 -f5 := D(f, 5) +--S 6 of 13 +r := (x**2 + 2*x + 1)/(x**2 - 2*x + 1) --R --R ---R (6) ---R 10 9 8 7 6 ---R - 544320x + 4354560x - 14696640x + 28615680x - 40085280x ---R + ---R 5 4 3 2 ---R 46656000x - 39411360x + 18247680x - 5870880x + 3317760x + 246240 ---R / ---R 20 19 18 17 16 15 14 13 ---R x - 12x + 53x - 76x - 159x + 676x - 391x - 1596x ---R + ---R 12 11 10 9 8 7 6 5 ---R 2527x + 1148x - 4977x + 1372x + 4907x - 3444x - 2381x + 2924x ---R + ---R 4 3 2 ---R 276x - 1184x + 208x + 192x - 64 ---R Type: Fraction(UnivariatePolynomial(x,Fraction(Integer))) +--R 2 +--R x + 2x + 1 +--R (6) ----------- +--R 2 +--R x - 2x + 1 +--R Type: Fraction(Polynomial(Integer)) --E 6 ---S 7 of 17 -g5::Fx - f5 +--S 7 of 13 +factor(r) --R --R ---R (7) 0 ---R Type: Fraction(UnivariatePolynomial(x,Fraction(Integer))) +--R 2 +--R x + 2x + 1 +--R (7) ----------- +--R 2 +--R x - 2x + 1 +--R Type: Factored(Fraction(Polynomial(Integer))) --E 7 ---S 8 of 17 -f : Fx := (x**5 * (x-1)) / ((x**2 + x + 1)**2 * (x-2)**3) +--S 8 of 13 +map(factor,r) --R --R ---R 6 5 ---R x - x ---R (8) ----------------------------------- ---R 7 6 5 3 2 ---R x - 4x + 3x + 9x - 6x - 4x - 8 ---R Type: Fraction(UnivariatePolynomial(x,Fraction(Integer))) +--R 2 +--R (x + 1) +--R (8) -------- +--R 2 +--R (x - 1) +--R Type: Fraction(Factored(Polynomial(Integer))) --E 8 ---S 9 of 17 -g := fullPartialFraction f +--S 9 of 13 +continuedFraction(7/12) --R --R ---R (9) ---R 1952 464 32 179 135 ---R ---- --- -- - ---- %A + ---- ---R 2401 343 49 --+ 2401 2401 ---R ------ + -------- + -------- + > ---------------- ---R x - 2 2 3 --+ x - %A ---R (x - 2) (x - 2) 2 ---R %A + %A + 1= 0 ---R + ---R 37 20 ---R ---- %A + ---- ---R --+ 1029 1029 ---R > -------------- ---R --+ 2 ---R 2 (x - %A) ---R %A + %A + 1= 0 ---RType: FullPartialFractionExpansion(Fraction(Integer),UnivariatePolynomial(x,Fraction(Integer))) +--R 1 | 1 | 1 | 1 | +--R (9) +---+ + +---+ + +---+ + +---+ +--R | 1 | 1 | 2 | 2 +--R Type: ContinuedFraction(Integer) --E 9 ---S 10 of 17 -g :: Fx - f +--S 10 of 13 +partialFraction(7,12) --R --R ---R (10) 0 ---R Type: Fraction(UnivariatePolynomial(x,Fraction(Integer))) +--R 3 1 +--R (10) 1 - -- + - +--R 2 3 +--R 2 +--R Type: PartialFraction(Integer) --E 10 ---S 11 of 17 -f : Fx := (2*x**7-7*x**5+26*x**3+8*x) / (x**8-5*x**6+6*x**4+4*x**2-8) +--S 11 of 13 +g := 2/3 + 4/5*%i --R --R ---R 7 5 3 ---R 2x - 7x + 26x + 8x ---R (11) ------------------------ ---R 8 6 4 2 ---R x - 5x + 6x + 4x - 8 ---R Type: Fraction(UnivariatePolynomial(x,Fraction(Integer))) +--R 2 4 +--R (11) - + - %i +--R 3 5 +--R Type: Complex(Fraction(Integer)) --E 11 ---S 12 of 17 -g := fullPartialFraction f +--S 12 of 13 +g :: FRAC COMPLEX INT --R --R ---R 1 1 ---R - - ---R --+ 2 --+ 1 --+ 2 ---R (12) > ------ + > --------- + > ------ ---R --+ x - %A --+ 3 --+ x - %A ---R 2 2 (x - %A) 2 ---R %A - 2= 0 %A - 2= 0 %A + 1= 0 ---RType: FullPartialFractionExpansion(Fraction(Integer),UnivariatePolynomial(x,Fraction(Integer))) +--R 10 + 12%i +--R (12) --------- +--R 15 +--R Type: Fraction(Complex(Integer)) --E 12 ---S 13 of 17 -g :: Fx - f ---R ---R ---R (13) 0 ---R Type: Fraction(UnivariatePolynomial(x,Fraction(Integer))) ---E 13 - ---S 14 of 17 -f:Fx := x**3 / (x**21 + 2*x**20 + 4*x**19 + 7*x**18 + 10*x**17 + 17*x**16 + 22*x**15 + 30*x**14 + 36*x**13 + 40*x**12 + 47*x**11 + 46*x**10 + 49*x**9 + 43*x**8 + 38*x**7 + 32*x**6 + 23*x**5 + 19*x**4 + 10*x**3 + 7*x**2 + 2*x + 1) ---R ---R ---R (14) ---R 3 ---R x ---R / ---R 21 20 19 18 17 16 15 14 13 12 ---R x + 2x + 4x + 7x + 10x + 17x + 22x + 30x + 36x + 40x ---R + ---R 11 10 9 8 7 6 5 4 3 2 ---R 47x + 46x + 49x + 43x + 38x + 32x + 23x + 19x + 10x + 7x + 2x ---R + ---R 1 ---R Type: Fraction(UnivariatePolynomial(x,Fraction(Integer))) ---E 14 - ---S 15 of 17 -g := fullPartialFraction f +--S 13 of 13 +)show Fraction --R ---R ---R (15) ---R 1 1 19 ---R - %A - %A - -- ---R --+ 2 --+ 9 27 ---R > ------ + > --------- ---R --+ x - %A --+ x - %A ---R 2 2 ---R %A + 1= 0 %A + %A + 1= 0 ---R + ---R 1 1 ---R -- %A - -- ---R --+ 27 27 ---R > ---------- ---R --+ 2 ---R 2 (x - %A) ---R %A + %A + 1= 0 ---R + ---R SIGMA ---R 5 2 ---R %A + %A + 1= 0 ---R , ---R 96556567040 4 420961732891 3 59101056149 2 ---R - ------------ %A + ------------ %A - ------------ %A ---R 912390759099 912390759099 912390759099 ---R + ---R 373545875923 529673492498 ---R - ------------ %A + ------------ ---R 912390759099 912390759099 ---R / ---R x - %A ---R + ---R SIGMA ---R 5 2 ---R %A + %A + 1= 0 ---R , ---R 5580868 4 2024443 3 4321919 2 84614 5070620 ---R - -------- %A - -------- %A + -------- %A - ------- %A - -------- ---R 94070601 94070601 94070601 1542141 94070601 ---R -------------------------------------------------------------------- ---R 2 ---R (x - %A) ---R + ---R SIGMA ---R 5 2 ---R %A + %A + 1= 0 ---R , ---R 1610957 4 2763014 3 2016775 2 266953 4529359 ---R -------- %A + -------- %A - -------- %A + -------- %A + -------- ---R 94070601 94070601 94070601 94070601 94070601 ---R ------------------------------------------------------------------- ---R 3 ---R (x - %A) ---RType: FullPartialFractionExpansion(Fraction(Integer),UnivariatePolynomial(x,Fraction(Integer))) ---E 15 - ---S 16 of 17 -g :: Fx - f ---R ---R ---R (16) 0 ---R Type: Fraction(UnivariatePolynomial(x,Fraction(Integer))) ---E 16 - ---S 17 of 17 -)show FullPartialFractionExpansion ---R ---R FullPartialFractionExpansion(F: Join(Field,CharacteristicZero),UP: UnivariatePolynomialCategory(F)) is a domain constructor ---R Abbreviation for FullPartialFractionExpansion is FPARFRAC ---R This constructor is exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for FPARFRAC +--R Fraction(S: IntegralDomain) is a domain constructor +--R Abbreviation for Fraction is FRAC +--R This constructor is exposed in this frame. +--R Issue )edit bookvol10.3.pamphlet to see algebra source code for FRAC --R --R------------------------------- Operations -------------------------------- ---R ?+? : (UP,%) -> % ?=? : (%,%) -> Boolean ---R D : (%,NonNegativeInteger) -> % D : % -> % ---R coerce : % -> OutputForm convert : % -> Fraction(UP) ---R differentiate : % -> % hash : % -> SingleInteger ---R latex : % -> String polyPart : % -> UP +--R ?*? : (%,S) -> % ?*? : (S,%) -> % +--R ?*? : (Fraction(Integer),%) -> % ?*? : (%,Fraction(Integer)) -> % +--R ?*? : (%,%) -> % ?*? : (Integer,%) -> % +--R ?*? : (NonNegativeInteger,%) -> % ?*? : (PositiveInteger,%) -> % +--R ?**? : (%,Integer) -> % ?**? : (%,NonNegativeInteger) -> % +--R ?**? : (%,PositiveInteger) -> % ?+? : (%,%) -> % +--R ?-? : (%,%) -> % -? : % -> % +--R ?/? : (S,S) -> % ?/? : (%,%) -> % +--R ?=? : (%,%) -> Boolean D : (%,(S -> S)) -> % +--R D : % -> % if S has DIFRING 1 : () -> % +--R 0 : () -> % ?^? : (%,Integer) -> % +--R ?^? : (%,NonNegativeInteger) -> % ?^? : (%,PositiveInteger) -> % +--R abs : % -> % if S has OINTDOM associates? : (%,%) -> Boolean +--R ceiling : % -> S if S has INS coerce : S -> % +--R coerce : Fraction(Integer) -> % coerce : % -> % +--R coerce : Integer -> % coerce : % -> OutputForm +--R convert : % -> Float if S has REAL denom : % -> S +--R denominator : % -> % differentiate : (%,(S -> S)) -> % +--R factor : % -> Factored(%) floor : % -> S if S has INS +--R gcd : List(%) -> % gcd : (%,%) -> % +--R hash : % -> SingleInteger init : () -> % if S has STEP +--R inv : % -> % latex : % -> String +--R lcm : List(%) -> % lcm : (%,%) -> % +--R map : ((S -> S),%) -> % max : (%,%) -> % if S has ORDSET +--R min : (%,%) -> % if S has ORDSET numer : % -> S +--R numerator : % -> % one? : % -> Boolean +--R prime? : % -> Boolean ?quo? : (%,%) -> % +--R random : () -> % if S has INS recip : % -> Union(%,"failed") +--R ?rem? : (%,%) -> % retract : % -> S +--R sample : () -> % sizeLess? : (%,%) -> Boolean +--R squareFree : % -> Factored(%) squareFreePart : % -> % +--R unit? : % -> Boolean unitCanonical : % -> % +--R wholePart : % -> S if S has EUCDOM zero? : % -> Boolean --R ?~=? : (%,%) -> Boolean ---R construct : List(Record(exponent: NonNegativeInteger,center: UP,num: UP)) -> % ---R differentiate : (%,NonNegativeInteger) -> % ---R fracPart : % -> List(Record(exponent: NonNegativeInteger,center: UP,num: UP)) ---R fullPartialFraction : Fraction(UP) -> % +--R ? Boolean if S has ORDSET +--R ?<=? : (%,%) -> Boolean if S has ORDSET +--R ?>? : (%,%) -> Boolean if S has ORDSET +--R ?>=? : (%,%) -> Boolean if S has ORDSET +--R D : (%,(S -> S),NonNegativeInteger) -> % +--R D : (%,List(Symbol),List(NonNegativeInteger)) -> % if S has PDRING(SYMBOL) +--R D : (%,Symbol,NonNegativeInteger) -> % if S has PDRING(SYMBOL) +--R D : (%,List(Symbol)) -> % if S has PDRING(SYMBOL) +--R D : (%,Symbol) -> % if S has PDRING(SYMBOL) +--R D : (%,NonNegativeInteger) -> % if S has DIFRING +--R OMwrite : (OpenMathDevice,%,Boolean) -> Void if S has INS and S has OM +--R OMwrite : (OpenMathDevice,%) -> Void if S has INS and S has OM +--R OMwrite : (%,Boolean) -> String if S has INS and S has OM +--R OMwrite : % -> String if S has INS and S has OM +--R characteristic : () -> NonNegativeInteger +--R charthRoot : % -> Union(%,"failed") if $ has CHARNZ and S has PFECAT or S has CHARNZ +--R coerce : Symbol -> % if S has RETRACT(SYMBOL) +--R conditionP : Matrix(%) -> Union(Vector(%),"failed") if $ has CHARNZ and S has PFECAT +--R convert : % -> DoubleFloat if S has REAL +--R convert : % -> InputForm if S has KONVERT(INFORM) +--R convert : % -> Pattern(Float) if S has KONVERT(PATTERN(FLOAT)) +--R convert : % -> Pattern(Integer) if S has KONVERT(PATTERN(INT)) +--R differentiate : (%,(S -> S),NonNegativeInteger) -> % +--R differentiate : (%,List(Symbol),List(NonNegativeInteger)) -> % if S has PDRING(SYMBOL) +--R differentiate : (%,Symbol,NonNegativeInteger) -> % if S has PDRING(SYMBOL) +--R differentiate : (%,List(Symbol)) -> % if S has PDRING(SYMBOL) +--R differentiate : (%,Symbol) -> % if S has PDRING(SYMBOL) +--R differentiate : (%,NonNegativeInteger) -> % if S has DIFRING +--R differentiate : % -> % if S has DIFRING +--R divide : (%,%) -> Record(quotient: %,remainder: %) +--R ?.? : (%,S) -> % if S has ELTAB(S,S) +--R euclideanSize : % -> NonNegativeInteger +--R eval : (%,Symbol,S) -> % if S has IEVALAB(SYMBOL,S) +--R eval : (%,List(Symbol),List(S)) -> % if S has IEVALAB(SYMBOL,S) +--R eval : (%,List(Equation(S))) -> % if S has EVALAB(S) +--R eval : (%,Equation(S)) -> % if S has EVALAB(S) +--R eval : (%,S,S) -> % if S has EVALAB(S) +--R eval : (%,List(S),List(S)) -> % if S has EVALAB(S) +--R expressIdealMember : (List(%),%) -> Union(List(%),"failed") +--R exquo : (%,%) -> Union(%,"failed") +--R extendedEuclidean : (%,%,%) -> Union(Record(coef1: %,coef2: %),"failed") +--R extendedEuclidean : (%,%) -> Record(coef1: %,coef2: %,generator: %) +--R factorPolynomial : SparseUnivariatePolynomial(%) -> Factored(SparseUnivariatePolynomial(%)) if S has PFECAT +--R factorSquareFreePolynomial : SparseUnivariatePolynomial(%) -> Factored(SparseUnivariatePolynomial(%)) if S has PFECAT +--R fractionPart : % -> % if S has EUCDOM +--R gcdPolynomial : (SparseUnivariatePolynomial(%),SparseUnivariatePolynomial(%)) -> SparseUnivariatePolynomial(%) +--R lcmCoef : (%,%) -> Record(llcmres: %,coeff1: %,coeff2: %) +--R multiEuclidean : (List(%),%) -> Union(List(%),"failed") +--R negative? : % -> Boolean if S has OINTDOM +--R nextItem : % -> Union(%,"failed") if S has STEP +--R patternMatch : (%,Pattern(Float),PatternMatchResult(Float,%)) -> PatternMatchResult(Float,%) if S has PATMAB(FLOAT) +--R patternMatch : (%,Pattern(Integer),PatternMatchResult(Integer,%)) -> PatternMatchResult(Integer,%) if S has PATMAB(INT) +--R positive? : % -> Boolean if S has OINTDOM +--R principalIdeal : List(%) -> Record(coef: List(%),generator: %) +--R reducedSystem : Matrix(%) -> Matrix(S) +--R reducedSystem : (Matrix(%),Vector(%)) -> Record(mat: Matrix(S),vec: Vector(S)) +--R reducedSystem : (Matrix(%),Vector(%)) -> Record(mat: Matrix(Integer),vec: Vector(Integer)) if S has LINEXP(INT) +--R reducedSystem : Matrix(%) -> Matrix(Integer) if S has LINEXP(INT) +--R retract : % -> Integer if S has RETRACT(INT) +--R retract : % -> Fraction(Integer) if S has RETRACT(INT) +--R retract : % -> Symbol if S has RETRACT(SYMBOL) +--R retractIfCan : % -> Union(Integer,"failed") if S has RETRACT(INT) +--R retractIfCan : % -> Union(Fraction(Integer),"failed") if S has RETRACT(INT) +--R retractIfCan : % -> Union(Symbol,"failed") if S has RETRACT(SYMBOL) +--R retractIfCan : % -> Union(S,"failed") +--R sign : % -> Integer if S has OINTDOM +--R solveLinearPolynomialEquation : (List(SparseUnivariatePolynomial(%)),SparseUnivariatePolynomial(%)) -> Union(List(SparseUnivariatePolynomial(%)),"failed") if S has PFECAT +--R squareFreePolynomial : SparseUnivariatePolynomial(%) -> Factored(SparseUnivariatePolynomial(%)) if S has PFECAT +--R subtractIfCan : (%,%) -> Union(%,"failed") +--R unitNormal : % -> Record(unit: %,canonical: %,associate: %) --R ---E 17 +--E 13 )spool )lisp (bye) \end{chunk} -\begin{chunk}{FullPartialFractionExpansion.help} +\begin{chunk}{Fraction.help} ==================================================================== -FullPartialFractionExpansion expansion +Fraction examples ==================================================================== -The domain FullPartialFractionExpansion implements factor-free -conversion of quotients to full partial fractions. - -Our examples will all involve quotients of univariate polynomials -with rational number coefficients. - - Fx := FRAC UP(x, FRAC INT) - Fraction UnivariatePolynomial(x,Fraction Integer) - Type: Domain - -Here is a simple-looking rational function. - - f : Fx := 36 / (x**5-2*x**4-2*x**3+4*x**2+x-2) - 36 - ---------------------------- - 5 4 3 2 - x - 2x - 2x + 4x + x - 2 - Type: Fraction UnivariatePolynomial(x,Fraction Integer) +The Fraction domain implements quotients. The elements must +belong to a domain of category IntegralDomain: multiplication +must be commutative and the product of two non-zero elements must not +be zero. This allows you to make fractions of most things you would +think of, but don't expect to create a fraction of two matrices! The +abbreviation for Fraction is FRAC. -We use fullPartialFraction to convert it to an object of type -FullPartialFractionExpansion. +Use / to create a fraction. - g := fullPartialFraction f - 4 4 --+ - 3%A - 6 - ----- - ----- + > --------- - x - 2 x + 1 --+ 2 - 2 (x - %A) - %A - 1= 0 -Type: FullPartialFractionExpansion(Fraction Integer, - UnivariatePolynomial(x,Fraction Integer)) + a := 11/12 + 11 + -- + 12 + Type: Fraction Integer -Use a coercion to change it back into a quotient. + b := 23/24 + 23 + -- + 24 + Type: Fraction Integer - g :: Fx - 36 - ---------------------------- - 5 4 3 2 - x - 2x - 2x + 4x + x - 2 - Type: Fraction UnivariatePolynomial(x,Fraction Integer) +The standard arithmetic operations are available. -Full partial fractions differentiate faster than rational functions. + 3 - a*b**2 + a + b/a + 313271 + ------ + 76032 + Type: Fraction Integer - g5 := D(g, 5) - 480 480 --+ 2160%A + 4320 - - -------- + -------- + > ------------- - 6 6 --+ 7 - (x - 2) (x + 1) 2 (x - %A) - %A - 1= 0 -Type: FullPartialFractionExpansion(Fraction Integer, - UnivariatePolynomial(x,Fraction Integer)) +Extract the numerator and denominator by using numer and denom, +respectively. - f5 := D(f, 5) - 10 9 8 7 6 - - 544320x + 4354560x - 14696640x + 28615680x - 40085280x - + - 5 4 3 2 - 46656000x - 39411360x + 18247680x - 5870880x + 3317760x + 246240 - / - 20 19 18 17 16 15 14 13 - x - 12x + 53x - 76x - 159x + 676x - 391x - 1596x - + - 12 11 10 9 8 7 6 5 - 2527x + 1148x - 4977x + 1372x + 4907x - 3444x - 2381x + 2924x - + - 4 3 2 - 276x - 1184x + 208x + 192x - 64 - Type: Fraction UnivariatePolynomial(x,Fraction Integer) + numer(a) + 11 + Type: PositiveInteger -We can check that the two forms represent the same function. + denom(b) + 24 + Type: PositiveInteger - g5::Fx - f5 - 0 - Type: Fraction UnivariatePolynomial(x,Fraction Integer) +Operations like max, min, negative?, positive? and zero? +are all available if they are provided for the numerators and +denominators. -Here are some examples that are more complicated. +Don't expect a useful answer from factor, gcd or lcm if you apply +them to fractions. - f : Fx := (x**5 * (x-1)) / ((x**2 + x + 1)**2 * (x-2)**3) - 6 5 - x - x - ----------------------------------- - 7 6 5 3 2 - x - 4x + 3x + 9x - 6x - 4x - 8 - Type: Fraction UnivariatePolynomial(x,Fraction Integer) + r := (x**2 + 2*x + 1)/(x**2 - 2*x + 1) + 2 + x + 2x + 1 + ----------- + 2 + x - 2x + 1 + Type: Fraction Polynomial Integer - g := fullPartialFraction f - 1952 464 32 179 135 - ---- --- -- - ---- %A + ---- - 2401 343 49 --+ 2401 2401 - ------ + -------- + -------- + > ---------------- - x - 2 2 3 --+ x - %A - (x - 2) (x - 2) 2 - %A + %A + 1= 0 - + - 37 20 - ---- %A + ---- - --+ 1029 1029 - > -------------- - --+ 2 - 2 (x - %A) - %A + %A + 1= 0 -Type: FullPartialFractionExpansion(Fraction Integer, - UnivariatePolynomial(x,Fraction Integer)) +Since all non-zero fractions are invertible, these operations have trivial +definitions. - g :: Fx - f - 0 - Type: Fraction UnivariatePolynomial(x,Fraction Integer) + factor(r) + 2 + x + 2x + 1 + ----------- + 2 + x - 2x + 1 + Type: Factored Fraction Polynomial Integer - f : Fx := (2*x**7-7*x**5+26*x**3+8*x) / (x**8-5*x**6+6*x**4+4*x**2-8) - 7 5 3 - 2x - 7x + 26x + 8x - ------------------------ - 8 6 4 2 - x - 5x + 6x + 4x - 8 - Type: Fraction UnivariatePolynomial(x,Fraction Integer) +Use map to apply factor to the numerator and denominator, which is +probably what you mean. - g := fullPartialFraction f - 1 1 - - - - --+ 2 --+ 1 --+ 2 - > ------ + > --------- + > ------ - --+ x - %A --+ 3 --+ x - %A - 2 2 (x - %A) 2 - %A - 2= 0 %A - 2= 0 %A + 1= 0 -Type: FullPartialFractionExpansion(Fraction Integer, - UnivariatePolynomial(x,Fraction Integer)) + map(factor,r) + 2 + (x + 1) + -------- + 2 + (x - 1) + Type: Fraction Factored Polynomial Integer - g :: Fx - f - 0 - Type: Fraction UnivariatePolynomial(x,Fraction Integer) +Other forms of fractions are available. Use continuedFraction to +create a continued fraction. - f:Fx := x**3 / (x**21 + 2*x**20 + 4*x**19 + 7*x**18 + 10*x**17 + 17*x**16 + 22*x**15 + 30*x**14 + 36*x**13 + 40*x**12 + 47*x**11 + 46*x**10 + 49*x**9 + 43*x**8 + 38*x**7 + 32*x**6 + 23*x**5 + 19*x**4 + 10*x**3 + 7*x**2 + 2*x + 1) - 3 - x - / - 21 20 19 18 17 16 15 14 13 12 - x + 2x + 4x + 7x + 10x + 17x + 22x + 30x + 36x + 40x - + - 11 10 9 8 7 6 5 4 3 2 - 47x + 46x + 49x + 43x + 38x + 32x + 23x + 19x + 10x + 7x + 2x - + - 1 - Type: Fraction UnivariatePolynomial(x,Fraction Integer) + continuedFraction(7/12) + 1 | 1 | 1 | 1 | + +---+ + +---+ + +---+ + +---+ + | 1 | 1 | 2 | 2 + Type: ContinuedFraction Integer - g := fullPartialFraction f - 1 1 19 - - %A - %A - -- - --+ 2 --+ 9 27 - > ------ + > --------- - --+ x - %A --+ x - %A - 2 2 - %A + 1= 0 %A + %A + 1= 0 - + - 1 1 - -- %A - -- - --+ 27 27 - > ---------- - --+ 2 - 2 (x - %A) - %A + %A + 1= 0 - + - SIGMA - 5 2 - %A + %A + 1= 0 - , - 96556567040 4 420961732891 3 59101056149 2 - - ------------ %A + ------------ %A - ------------ %A - 912390759099 912390759099 912390759099 - + - 373545875923 529673492498 - - ------------ %A + ------------ - 912390759099 912390759099 - / - x - %A - + - SIGMA - 5 2 - %A + %A + 1= 0 - , - 5580868 4 2024443 3 4321919 2 84614 5070620 - - -------- %A - -------- %A + -------- %A - ------- %A - -------- - 94070601 94070601 94070601 1542141 94070601 - -------------------------------------------------------------------- - 2 - (x - %A) - + - SIGMA - 5 2 - %A + %A + 1= 0 - , - 1610957 4 2763014 3 2016775 2 266953 4529359 - -------- %A + -------- %A - -------- %A + -------- %A + -------- - 94070601 94070601 94070601 94070601 94070601 - ------------------------------------------------------------------- - 3 - (x - %A) -Type: FullPartialFractionExpansion(Fraction Integer,UnivariatePolynomial(x,Fraction Integer)) +Use partialFraction to create a partial fraction. -This verification takes much longer than the conversion to partial fractions. + partialFraction(7,12) + 3 1 + 1 - -- + - + 2 3 + 2 + Type: PartialFraction Integer - g :: Fx - f - 0 - Type: Fraction UnivariatePolynomial(x,Fraction Integer) +Use conversion to create alternative views of fractions with objects +moved in and out of the numerator and denominator. -Use PartialFraction for standard partial fraction decompositions. + g := 2/3 + 4/5*%i + 2 4 + - + - %i + 3 5 + Type: Complex Fraction Integer -For more information, see the paper: Bronstein, M and Salvy, B. -"Full Partial Fraction Decomposition of Rational Functions," -Proceedings of ISSAC'93, Kiev, ACM Press. + g :: FRAC COMPLEX INT + 10 + 12%i + --------- + 15 + Type: Fraction Complex Integer -See Also: +See Also: +o )help ContinuedFraction o )help PartialFraction -o )show FullPartialFractionExpansion +o )help Integer +o )show Fraction \end{chunk} -\pagehead{FullPartialFractionExpansion}{FPARFRAC} -\pagepic{ps/v103fullpartialfractionexpansion.ps}{FPARFRAC}{1.00} +\pagehead{Fraction}{FRAC} +\pagepic{ps/v103fraction.ps}{FRAC}{1.00} +{\bf See}\\ +\pageto{Localize}{LO} +\pageto{LocalAlgebra}{LA} {\bf Exports:}\\ -\begin{tabular}{lllll} -\cross{FPARFRAC}{coerce} & -\cross{FPARFRAC}{construct} & -\cross{FPARFRAC}{convert} & -\cross{FPARFRAC}{D} & -\cross{FPARFRAC}{differentiate} \\ -\cross{FPARFRAC}{hash} & -\cross{FPARFRAC}{latex} & -\cross{FPARFRAC}{polyPart} & -\cross{FPARFRAC}{fracPart} & -\cross{FPARFRAC}{fullPartialFraction} \\ -\cross{FPARFRAC}{?\~{}=?} & -\cross{FPARFRAC}{?+?} & -\cross{FPARFRAC}{?=?} && +\begin{tabular}{lll} +\cross{FRAC}{0} & +\cross{FRAC}{1} & +\cross{FRAC}{abs} \\ +\cross{FRAC}{associates?} & +\cross{FRAC}{characteristic} & +\cross{FRAC}{charthRoot} \\ +\cross{FRAC}{ceiling} & +\cross{FRAC}{coerce} & +\cross{FRAC}{conditionP} \\ +\cross{FRAC}{convert} & +\cross{FRAC}{D} & +\cross{FRAC}{denom} \\ +\cross{FRAC}{denominator} & +\cross{FRAC}{differentiate} & +\cross{FRAC}{divide} \\ +\cross{FRAC}{euclideanSize} & +\cross{FRAC}{eval} & +\cross{FRAC}{expressIdealMember} \\ +\cross{FRAC}{exquo} & +\cross{FRAC}{extendedEuclidean} & +\cross{FRAC}{factor} \\ +\cross{FRAC}{factorPolynomial} & +\cross{FRAC}{factorSquareFreePolynomial} & +\cross{FRAC}{floor} \\ +\cross{FRAC}{fractionPart} & +\cross{FRAC}{gcd} & +\cross{FRAC}{gcdPolynomial} \\ +\cross{FRAC}{hash} & +\cross{FRAC}{init} & +\cross{FRAC}{inv} \\ +\cross{FRAC}{latex} & +\cross{FRAC}{lcm} & +\cross{FRAC}{map} \\ +\cross{FRAC}{max} & +\cross{FRAC}{min} & +\cross{FRAC}{multiEuclidean} \\ +\cross{FRAC}{negative?} & +\cross{FRAC}{nextItem} & +\cross{FRAC}{numer} \\ +\cross{FRAC}{numerator} & +\cross{FRAC}{OMwrite} & +\cross{FRAC}{one?} \\ +\cross{FRAC}{patternMatch} & +\cross{FRAC}{positive?} & +\cross{FRAC}{prime?} \\ +\cross{FRAC}{principalIdeal} & +\cross{FRAC}{random} & +\cross{FRAC}{recip} \\ +\cross{FRAC}{reducedSystem} & +\cross{FRAC}{retract} & +\cross{FRAC}{retractIfCan} \\ +\cross{FRAC}{sample} & +\cross{FRAC}{sign} & +\cross{FRAC}{sizeLess?} \\ +\cross{FRAC}{solveLinearPolynomialEquation} & +\cross{FRAC}{squareFree} & +\cross{FRAC}{squareFreePart} \\ +\cross{FRAC}{squareFreePolynomial} & +\cross{FRAC}{subtractIfCan} & +\cross{FRAC}{unit?} \\ +\cross{FRAC}{unitCanonical} & +\cross{FRAC}{unitNormal} & +\cross{FRAC}{wholePart} \\ +\cross{FRAC}{zero?} & +\cross{FRAC}{?*?} & +\cross{FRAC}{?**?} \\ +\cross{FRAC}{?+?} & +\cross{FRAC}{?-?} & +\cross{FRAC}{-?} \\ +\cross{FRAC}{?/?} & +\cross{FRAC}{?=?} & +\cross{FRAC}{?\^{}?} \\ +\cross{FRAC}{?\~{}=?} & +\cross{FRAC}{?$<$?} & +\cross{FRAC}{?$<=$?} \\ +\cross{FRAC}{?$>$?} & +\cross{FRAC}{?$>=$?} & +\cross{FRAC}{?.?} \\ +\cross{FRAC}{?quo?} & +\cross{FRAC}{?rem?} & \end{tabular} -\begin{chunk}{domain FPARFRAC FullPartialFractionExpansion} -)abbrev domain FPARFRAC FullPartialFractionExpansion -++ Author: Manuel Bronstein -++ Date Created: 9 December 1992 -++ Date Last Updated: 6 October 1993 -++ References: M.Bronstein & B.Salvy, -++ Full Partial Fraction Decomposition of Rational Functions, -++ in Proceedings of ISSAC'93, Kiev, ACM Press. +\begin{chunk}{domain FRAC Fraction} +)abbrev domain FRAC Fraction +++ Author: Mark Botch +++ Date Last Updated: 12 February 1992 +++ Basic Functions: Field, numer, denom ++ Description: -++ Full partial fraction expansion of rational functions +++ Fraction takes an IntegralDomain S and produces +++ the domain of Fractions with numerators and denominators from S. +++ If S is also a GcdDomain, then gcd's between numerator and +++ denominator will be cancelled during all operations. -FullPartialFractionExpansion(F, UP): Exports == Implementation where - F : Join(Field, CharacteristicZero) - UP : UnivariatePolynomialCategory F +Fraction(S: IntegralDomain): QuotientFieldCategory S with + if S has IntegerNumberSystem and S has OpenMath then OpenMath + if S has canonical and S has GcdDomain and S has canonicalUnitNormal + then canonical + ++ \spad{canonical} means that equal elements are in fact identical. + == LocalAlgebra(S, S, S) add - N ==> NonNegativeInteger - Q ==> Fraction Integer - O ==> OutputForm - RF ==> Fraction UP - SUP ==> SparseUnivariatePolynomial RF - REC ==> Record(exponent: N, center: UP, num: UP) - ODV ==> OrderlyDifferentialVariable Symbol - ODP ==> OrderlyDifferentialPolynomial UP - ODF ==> Fraction ODP - FPF ==> Record(polyPart: UP, fracPart: List REC) + Rep:= Record(num:S, den:S) - Exports ==> Join(SetCategory, ConvertibleTo RF) with - "+": (UP, $) -> $ - ++ p + x returns the sum of p and x - fullPartialFraction: RF -> $ - ++ fullPartialFraction(f) returns \spad{[p, [[j, Dj, Hj]...]]} such that - ++ \spad{f = p(x) + sum_{[j,Dj,Hj] in l} sum_{Dj(a)=0} Hj(a)/(x - a)\^j}. - polyPart: $ -> UP - ++ polyPart(f) returns the polynomial part of f. - fracPart: $ -> List REC - ++ fracPart(f) returns the list of summands of the fractional part of f. - construct: List REC -> $ - ++ construct(l) is the inverse of fracPart. - differentiate: $ -> $ - ++ differentiate(f) returns the derivative of f. - D: $ -> $ - ++ D(f) returns the derivative of f. - differentiate: ($, N) -> $ - ++ differentiate(f, n) returns the n-th derivative of f. - D: ($, NonNegativeInteger) -> $ - ++ D(f, n) returns the n-th derivative of f. + coerce(d:S):% == [d,1] - Implementation ==> add - Rep := FPF + zero?(x:%) == zero? x.num - fullParFrac: (UP, UP, UP, N) -> List REC - outputexp : (O, N) -> O - output : (N, UP, UP) -> O - REC2RF : (UP, UP, N) -> RF - UP2SUP : UP -> SUP - diffrec : REC -> REC - FP2O : List REC -> O + if S has GcdDomain and S has canonicalUnitNormal then --- create a differential variable - u := new()$Symbol - u0 := makeVariable(u, 0)$ODV - alpha := u::O - x := monomial(1, 1)$UP - xx := x::O - zr := (0$N)::O + retract(x:%):S == + ((x.den) = 1) => x.num + error "Denominator not equal to 1" - construct l == [0, l] - D r == differentiate r - D(r, n) == differentiate(r,n) - polyPart f == f.polyPart - fracPart f == f.fracPart - p:UP + f:$ == [p + polyPart f, fracPart f] + retractIfCan(x:%):Union(S, "failed") == + ((x.den) = 1) => x.num + "failed" + else - differentiate f == - differentiate(polyPart f) + construct [diffrec rec for rec in fracPart f] + retract(x:%):S == + (a:= x.num exquo x.den) case "failed" => + error "Denominator not equal to 1" + a - differentiate(r, n) == - for i in 1..n repeat r := differentiate r - r + retractIfCan(x:%):Union(S,"failed") == x.num exquo x.den --- diffrec(sum_{rec.center(a) = 0} rec.num(a) / (x - a)^e) = --- sum_{rec.center(a) = 0} -e rec.num(a) / (x - a)^{e+1} --- where e = rec.exponent - diffrec rec == - e := rec.exponent - [e + 1, rec.center, - e * rec.num] + if S has EuclideanDomain then + wholePart x == + ((x.den) = 1) => x.num + x.num quo x.den - convert(f:$):RF == - ans := polyPart(f)::RF - for rec in fracPart f repeat - ans := ans + REC2RF(rec.center, rec.num, rec.exponent) - ans + if S has IntegerNumberSystem then - UP2SUP p == map((z1:F):RF +-> z1::UP::RF, p)_ - $UnivariatePolynomialCategoryFunctions2(F, UP, RF, SUP) + floor x == + ((x.den) = 1) => x.num + x < 0 => -ceiling(-x) + wholePart x - -- returns Trace_k^k(a) (h(a) / (x - a)^n) where d(a) = 0 - REC2RF(d, h, n) == --- one?(m := degree d) => - ((m := degree d) = 1) => - a := - (leadingCoefficient reductum d) / (leadingCoefficient d) - h(a)::UP / (x - a::UP)**n - dd := UP2SUP d - hh := UP2SUP h - aa := monomial(1, 1)$SUP - p := (x::RF::SUP - aa)**n rem dd - rec := extendedEuclidean(p, dd, hh)::Record(coef1:SUP, coef2:SUP) - t := rec.coef1 -- we want Trace_k^k(a)(t) now - ans := coefficient(t, 0) - for i in 1..degree(d)-1 repeat - t := (t * aa) rem dd - ans := ans + coefficient(t, i) - ans + ceiling x == + ((x.den) = 1) => x.num + x < 0 => -floor(-x) + 1 + wholePart x - fullPartialFraction f == - qr := divide(numer f, d := denom f) - qr.quotient + construct concat - [fullParFrac(qr.remainder, d, rec.factor, rec.exponent::N) - for rec in factors squareFree denom f] + if S has OpenMath then + -- TODO: somwhere this file does something which redefines the division + -- operator. Doh! - fullParFrac(a, d, q, n) == - ans:List REC := empty() - em := e := d quo (q ** n) - rec := extendedEuclidean(e, q, 1)::Record(coef1:UP,coef2:UP) - bm := b := rec.coef1 -- b = inverse of e modulo q - lvar:List(ODV) := [u0] - um := 1::ODP - un := (u1 := u0::ODP)**n - lval:List(UP) := [q1 := q := differentiate(q0 := q)] - h:ODF := a::ODP / (e * un) - rec := extendedEuclidean(q1, q0, 1)::Record(coef1:UP,coef2:UP) - c := rec.coef1 -- c = inverse of q' modulo q - cm := 1::UP - cn := (c ** n) rem q0 - for m in 1..n repeat - p := retract(em * un * um * h)@ODP - pp := retract(eval(p, lvar, lval))@UP - h := inv(m::Q) * differentiate h - q := differentiate q - lvar := concat(makeVariable(u, m), lvar) - lval := concat(inv((m+1)::F) * q, lval) - qq := q0 quo gcd(pp, q0) -- new center - if (degree(qq) > 0) then - ans := concat([(n + 1 - m)::N, qq, (pp * bm * cn * cm) rem qq], ans) - cm := (c * cm) rem q0 -- cm = c**m modulo q now - um := u1 * um -- um = u**m now - em := e * em -- em = e**{m+1} now - bm := (b * bm) rem q0 -- bm = b**{m+1} modulo q now - ans + writeOMFrac(dev: OpenMathDevice, x: %): Void == + OMputApp(dev) + OMputSymbol(dev, "nums1", "rational") + OMwrite(dev, x.num, false) + OMwrite(dev, x.den, false) + OMputEndApp(dev) - coerce(f:$):O == - ans := FP2O(l := fracPart f) - zero?(p := polyPart f) => - empty? l => (0$N)::O - ans - p::O + ans + OMwrite(x: %): String == + s: String := "" + sp := OM_-STRINGTOSTRINGPTR(s)$Lisp + dev: OpenMathDevice := OMopenString(sp pretend String, OMencodingXML) + OMputObject(dev) + writeOMFrac(dev, x) + OMputEndObject(dev) + OMclose(dev) + s := OM_-STRINGPTRTOSTRING(sp)$Lisp pretend String + s - FP2O l == - empty? l => empty() - rec := first l - ans := output(rec.exponent, rec.center, rec.num) - for rec in rest l repeat - ans := ans + output(rec.exponent, rec.center, rec.num) - ans + OMwrite(x: %, wholeObj: Boolean): String == + s: String := "" + sp := OM_-STRINGTOSTRINGPTR(s)$Lisp + dev: OpenMathDevice := OMopenString(sp pretend String, OMencodingXML) + if wholeObj then + OMputObject(dev) + writeOMFrac(dev, x) + if wholeObj then + OMputEndObject(dev) + OMclose(dev) + s := OM_-STRINGPTRTOSTRING(sp)$Lisp pretend String + s - output(n, d, h) == --- one? degree d => - (degree d) = 1 => - a := - leadingCoefficient(reductum d) / leadingCoefficient(d) - h(a)::O / outputexp((x - a::UP)::O, n) - sum(outputForm(makeSUP h, alpha) / outputexp(xx - alpha, n), - outputForm(makeSUP d, alpha) = zr) + OMwrite(dev: OpenMathDevice, x: %): Void == + OMputObject(dev) + writeOMFrac(dev, x) + OMputEndObject(dev) - outputexp(f, n) == --- one? n => f - (n = 1) => f - f ** (n::O) + OMwrite(dev: OpenMathDevice, x: %, wholeObj: Boolean): Void == + if wholeObj then + OMputObject(dev) + writeOMFrac(dev, x) + if wholeObj then + OMputEndObject(dev) -\end{chunk} + if S has GcdDomain then -\begin{chunk}{COQ FPARFRAC} -(* domain FPARFRAC *) -(* -*) + cancelGcd: % -> S -\end{chunk} + normalize: % -> % -\begin{chunk}{FPARFRAC.dotabb} -"FPARFRAC" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FPARFRAC"] -"ALIST" [color="#88FF44",href="bookvol10.3.pdf#nameddest=ALIST"] -"FPARFRAC" -> "ALIST" + normalize x == + zero?(x.num) => 0 + ((x.den) = 1) => x + uca := unitNormal(x.den) + zero?(x.den := uca.canonical) => error "division by zero" + x.num := x.num * uca.associate + x -\end{chunk} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain FUNCTION FunctionCalled} + recip x == + zero?(x.num) => "failed" + normalize [x.den, x.num] -\begin{chunk}{FunctionCalled.input} -)set break resume -)sys rm -f FunctionCalled.output -)spool FunctionCalled.output -)set message test on -)set message auto off -)clear all + cancelGcd x == + ((x.den) = 1) => x.den + d := gcd(x.num, x.den) + xn := x.num exquo d + xn case "failed" => + error "gcd not gcd in QF cancelGcd (numerator)" + xd := x.den exquo d + xd case "failed" => + error "gcd not gcd in QF cancelGcd (denominator)" + x.num := xn :: S + x.den := xd :: S + d ---S 1 of 1 -)show FunctionCalled ---R ---R FunctionCalled(f: Symbol) is a domain constructor ---R Abbreviation for FunctionCalled is FUNCTION ---R This constructor is not exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for FUNCTION ---R ---R------------------------------- Operations -------------------------------- ---R ?=? : (%,%) -> Boolean coerce : % -> OutputForm ---R hash : % -> SingleInteger latex : % -> String ---R name : % -> Symbol ?~=? : (%,%) -> Boolean ---R ---E 1 + nn:S / dd:S == + zero? dd => error "division by zero" + cancelGcd(z := [nn, dd]) + normalize z -)spool -)lisp (bye) -\end{chunk} -\begin{chunk}{FunctionCalled.help} -==================================================================== -FunctionCalled examples -==================================================================== + x + y == + zero? y => x + zero? x => y + z := [x.den,y.den] + d := cancelGcd z + g := [z.den * x.num + z.num * y.num, d] + cancelGcd g + g.den := g.den * z.num * z.den + normalize g -This domain implements named functions + -- We can not rely on the defaulting mechanism + -- to supply a definition for -, even though this + -- definition would do, for thefollowing reasons: + -- 1) The user could have defined a subtraction + -- in Localize, which would not work for + -- QuotientField; + -- 2) even if he doesn't, the system currently + -- places a default definition in Localize, + -- which uses Localize's +, which does not + -- cancel gcds + x - y == + zero? y => x + z := [x.den, y.den] + d := cancelGcd z + g := [z.den * x.num - z.num * y.num, d] + cancelGcd g + g.den := g.den * z.num * z.den + normalize g -See Also: -o )show FunctionCalled + x:% * y:% == + zero? x or zero? y => 0 + (x = 1) => y + (y = 1) => x + (x, y) := ([x.num, y.den], [y.num, x.den]) + cancelGcd x; cancelGcd y; + normalize [x.num * y.num, x.den * y.den] -\end{chunk} + n:Integer * x:% == + y := [n::S, x.den] + cancelGcd y + normalize [x.num * y.num, y.den] -\pagehead{FunctionCalled}{FUNCTION} -\pagepic{ps/v103functioncalled.ps}{FUNCTION}{1.00} + nn:S * x:% == + y := [nn, x.den] + cancelGcd y + normalize [x.num * y.num, y.den] -{\bf Exports:}\\ -\begin{tabular}{llllll} -\cross{FUNCTION}{coerce} & -\cross{FUNCTION}{hash} & -\cross{FUNCTION}{latex} & -\cross{FUNCTION}{name} & -\cross{FUNCTION}{?=?} & -\cross{FUNCTION}{?\~{}=?} -\end{tabular} + differentiate(x:%, deriv:S -> S) == + y := [deriv(x.den), x.den] + d := cancelGcd(y) + y.num := deriv(x.num) * y.den - x.num * y.num + (d, y.den) := (y.den, d) + cancelGcd y + y.den := y.den * d * d + normalize y -\begin{chunk}{domain FUNCTION FunctionCalled} -)abbrev domain FUNCTION FunctionCalled -++ Author: Mark Botch -++ Description: -++ This domain implements named functions + if S has canonicalUnitNormal then -FunctionCalled(f:Symbol): SetCategory with - name: % -> Symbol - ++ name(x) returns the symbol - == add - name r == f - coerce(r:%):OutputForm == f::OutputForm - x = y == true - latex(x:%):String == latex f + x = y == (x.num = y.num) and (x.den = y.den) -\end{chunk} + one? x == ((x.num) = 1) and ((x.den) = 1) + -- again assuming canonical nature of representation -\begin{chunk}{COQ FUNCTION} -(* domain FUNCTION *) -(* -*) + else -\end{chunk} + nn:S/dd:S == if zero? dd then error "division by zero" else [nn,dd] -\begin{chunk}{FUNCTION.dotabb} -"FUNCTION" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FUNCTION"] -"ALIST" [color="#88FF44",href="bookvol10.3.pdf#nameddest=ALIST"] -"FUNCTION" -> "ALIST" + recip x == + zero?(x.num) => "failed" + [x.den, x.num] -\end{chunk} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter G} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain GDMP GeneralDistributedMultivariatePolynomial} + if (S has RetractableTo Fraction Integer) then -\begin{chunk}{GeneralDistributedMultivariatePolynomial.input} -)set break resume -)sys rm -f GeneralDistributedMultivariatePolynomial.output -)spool GeneralDistributedMultivariatePolynomial.output -)set message test on -)set message auto off -)clear all + retract(x:%):Fraction(Integer) == retract(retract(x)@S) ---S 1 of 11 -(d1,d2,d3) : DMP([z,y,x],FRAC INT) ---R ---R Type: Void ---E 1 + retractIfCan(x:%):Union(Fraction Integer, "failed") == + (u := retractIfCan(x)@Union(S, "failed")) case "failed" => "failed" + retractIfCan(u::S) ---S 2 of 11 -d1 := -4*z + 4*y**2*x + 16*x**2 + 1 ---R ---R ---R 2 2 ---R (2) - 4z + 4y x + 16x + 1 ---R Type: DistributedMultivariatePolynomial([z,y,x],Fraction(Integer)) ---E 2 + else if (S has RetractableTo Integer) then ---S 3 of 11 -d2 := 2*z*y**2 + 4*x + 1 ---R ---R ---R 2 ---R (3) 2z y + 4x + 1 ---R Type: DistributedMultivariatePolynomial([z,y,x],Fraction(Integer)) ---E 3 + retract(x:%):Fraction(Integer) == + retract(numer x) / retract(denom x) ---S 4 of 11 -d3 := 2*z*x**2 - 2*y**2 - x ---R ---R ---R 2 2 ---R (4) 2z x - 2y - x ---R Type: DistributedMultivariatePolynomial([z,y,x],Fraction(Integer)) ---E 4 + retractIfCan(x:%):Union(Fraction Integer, "failed") == + (n := retractIfCan numer x) case "failed" => "failed" + (d := retractIfCan denom x) case "failed" => "failed" + (n::Integer) / (d::Integer) ---S 5 of 11 -groebner [d1,d2,d3] ---R ---R ---R (5) ---R 1568 6 1264 5 6 4 182 3 2047 2 103 2857 ---R [z - ---- x - ---- x + --- x + --- x - ---- x - ---- x - -----, ---R 2745 305 305 549 610 2745 10980 ---R 2 112 6 84 5 1264 4 13 3 84 2 1772 2 ---R y + ---- x - --- x - ---- x - --- x + --- x + ---- x + ----, ---R 2745 305 305 549 305 2745 2745 ---R 7 29 6 17 4 11 3 1 2 15 1 ---R x + -- x - -- x - -- x + -- x + -- x + -] ---R 4 16 8 32 16 4 ---R Type: List(DistributedMultivariatePolynomial([z,y,x],Fraction(Integer))) ---E 5 + QFP ==> SparseUnivariatePolynomial % ---S 6 of 11 -(n1,n2,n3) : HDMP([z,y,x],FRAC INT) ---R ---R Type: Void ---E 6 + DP ==> SparseUnivariatePolynomial S ---S 7 of 11 -n1 := d1 ---R ---R ---R 2 2 ---R (7) 4y x + 16x - 4z + 1 ---RType: HomogeneousDistributedMultivariatePolynomial([z,y,x],Fraction(Integer)) ---E 7 + import UnivariatePolynomialCategoryFunctions2(%,QFP,S,DP) ---S 8 of 11 -n2 := d2 ---R ---R ---R 2 ---R (8) 2z y + 4x + 1 ---RType: HomogeneousDistributedMultivariatePolynomial([z,y,x],Fraction(Integer)) ---E 8 + import UnivariatePolynomialCategoryFunctions2(S,DP,%,QFP) ---S 9 of 11 -n3 := d3 ---R ---R ---R 2 2 ---R (9) 2z x - 2y - x ---RType: HomogeneousDistributedMultivariatePolynomial([z,y,x],Fraction(Integer)) ---E 9 + if S has GcdDomain then ---S 10 of 11 -groebner [n1,n2,n3] ---R ---R ---R (10) ---R 4 3 3 2 1 1 4 29 3 1 2 7 9 1 ---R [y + 2x - - x + - z - -, x + -- x - - y - - z x - -- x - -, ---R 2 2 8 4 8 4 16 4 ---R 2 1 2 2 1 2 2 1 ---R z y + 2x + -, y x + 4x - z + -, z x - y - - x, ---R 2 4 2 ---R 2 2 2 1 3 ---R z - 4y + 2x - - z - - x] ---R 4 2 ---RType: List(HomogeneousDistributedMultivariatePolynomial([z,y,x],Fraction(Integer))) ---E 10 + gcdPolynomial(pp,qq) == + zero? pp => qq + zero? qq => pp + zero? degree pp or zero? degree qq => 1 + denpp:="lcm"/[denom u for u in coefficients pp] + ppD:DP:=map(x+->retract(x*denpp),pp) + denqq:="lcm"/[denom u for u in coefficients qq] + qqD:DP:=map(x+->retract(x*denqq),qq) + g:=gcdPolynomial(ppD,qqD) + zero? degree g => 1 + ((lc:=leadingCoefficient g) = 1) => map(x+->x::%,g) + map(x+->x/lc,g) ---S 11 of 11 -)show GeneralDistributedMultivariatePolynomial ---R ---R GeneralDistributedMultivariatePolynomial(vl: List(Symbol),R: Ring,E: DirectProductCategory(#(vl),NonNegativeInteger)) is a domain constructor ---R Abbreviation for GeneralDistributedMultivariatePolynomial is GDMP ---R This constructor is not exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for GDMP ---R ---R------------------------------- Operations -------------------------------- ---R ?*? : (%,R) -> % ?*? : (R,%) -> % ---R ?*? : (%,%) -> % ?*? : (Integer,%) -> % ---R ?*? : (NonNegativeInteger,%) -> % ?*? : (PositiveInteger,%) -> % ---R ?**? : (%,NonNegativeInteger) -> % ?**? : (%,PositiveInteger) -> % ---R ?+? : (%,%) -> % ?-? : (%,%) -> % ---R -? : % -> % ?/? : (%,R) -> % if R has FIELD ---R ?=? : (%,%) -> Boolean 1 : () -> % ---R 0 : () -> % ?^? : (%,NonNegativeInteger) -> % ---R ?^? : (%,PositiveInteger) -> % coefficient : (%,E) -> R ---R coefficients : % -> List(R) coerce : % -> % if R has INTDOM ---R coerce : R -> % coerce : Integer -> % ---R coerce : % -> OutputForm content : % -> R if R has GCDDOM ---R degree : % -> E eval : (%,List(%),List(%)) -> % ---R eval : (%,%,%) -> % eval : (%,Equation(%)) -> % ---R eval : (%,List(Equation(%))) -> % gcd : (%,%) -> % if R has GCDDOM ---R gcd : List(%) -> % if R has GCDDOM ground : % -> R ---R ground? : % -> Boolean hash : % -> SingleInteger ---R latex : % -> String lcm : (%,%) -> % if R has GCDDOM ---R lcm : List(%) -> % if R has GCDDOM leadingCoefficient : % -> R ---R leadingMonomial : % -> % map : ((R -> R),%) -> % ---R mapExponents : ((E -> E),%) -> % max : (%,%) -> % if R has ORDSET ---R min : (%,%) -> % if R has ORDSET minimumDegree : % -> E ---R monomial : (R,E) -> % monomial? : % -> Boolean ---R monomials : % -> List(%) one? : % -> Boolean ---R pomopo! : (%,R,E,%) -> % primitiveMonomials : % -> List(%) ---R recip : % -> Union(%,"failed") reductum : % -> % ---R reorder : (%,List(Integer)) -> % retract : % -> R ---R sample : () -> % zero? : % -> Boolean ---R ?~=? : (%,%) -> Boolean ---R ?*? : (Fraction(Integer),%) -> % if R has ALGEBRA(FRAC(INT)) ---R ?*? : (%,Fraction(Integer)) -> % if R has ALGEBRA(FRAC(INT)) ---R ? Boolean if R has ORDSET ---R ?<=? : (%,%) -> Boolean if R has ORDSET ---R ?>? : (%,%) -> Boolean if R has ORDSET ---R ?>=? : (%,%) -> Boolean if R has ORDSET ---R D : (%,List(OrderedVariableList(vl)),List(NonNegativeInteger)) -> % ---R D : (%,OrderedVariableList(vl),NonNegativeInteger) -> % ---R D : (%,List(OrderedVariableList(vl))) -> % ---R D : (%,OrderedVariableList(vl)) -> % ---R associates? : (%,%) -> Boolean if R has INTDOM ---R binomThmExpt : (%,%,NonNegativeInteger) -> % if R has COMRING ---R characteristic : () -> NonNegativeInteger ---R charthRoot : % -> Union(%,"failed") if $ has CHARNZ and R has PFECAT or R has CHARNZ ---R coefficient : (%,List(OrderedVariableList(vl)),List(NonNegativeInteger)) -> % ---R coefficient : (%,OrderedVariableList(vl),NonNegativeInteger) -> % ---R coerce : Fraction(Integer) -> % if R has ALGEBRA(FRAC(INT)) or R has RETRACT(FRAC(INT)) ---R coerce : OrderedVariableList(vl) -> % ---R conditionP : Matrix(%) -> Union(Vector(%),"failed") if $ has CHARNZ and R has PFECAT ---R content : (%,OrderedVariableList(vl)) -> % if R has GCDDOM ---R convert : % -> InputForm if OrderedVariableList(vl) has KONVERT(INFORM) and R has KONVERT(INFORM) ---R convert : % -> Pattern(Integer) if OrderedVariableList(vl) has KONVERT(PATTERN(INT)) and R has KONVERT(PATTERN(INT)) ---R convert : % -> Pattern(Float) if OrderedVariableList(vl) has KONVERT(PATTERN(FLOAT)) and R has KONVERT(PATTERN(FLOAT)) ---R degree : (%,List(OrderedVariableList(vl))) -> List(NonNegativeInteger) ---R degree : (%,OrderedVariableList(vl)) -> NonNegativeInteger ---R differentiate : (%,List(OrderedVariableList(vl)),List(NonNegativeInteger)) -> % ---R differentiate : (%,OrderedVariableList(vl),NonNegativeInteger) -> % ---R differentiate : (%,List(OrderedVariableList(vl))) -> % ---R differentiate : (%,OrderedVariableList(vl)) -> % ---R discriminant : (%,OrderedVariableList(vl)) -> % if R has COMRING ---R eval : (%,List(OrderedVariableList(vl)),List(%)) -> % ---R eval : (%,OrderedVariableList(vl),%) -> % ---R eval : (%,List(OrderedVariableList(vl)),List(R)) -> % ---R eval : (%,OrderedVariableList(vl),R) -> % ---R exquo : (%,%) -> Union(%,"failed") if R has INTDOM ---R exquo : (%,R) -> Union(%,"failed") if R has INTDOM ---R factor : % -> Factored(%) if R has PFECAT ---R factorPolynomial : SparseUnivariatePolynomial(%) -> Factored(SparseUnivariatePolynomial(%)) if R has PFECAT ---R factorSquareFreePolynomial : SparseUnivariatePolynomial(%) -> Factored(SparseUnivariatePolynomial(%)) if R has PFECAT ---R gcdPolynomial : (SparseUnivariatePolynomial(%),SparseUnivariatePolynomial(%)) -> SparseUnivariatePolynomial(%) if R has GCDDOM ---R isExpt : % -> Union(Record(var: OrderedVariableList(vl),exponent: NonNegativeInteger),"failed") ---R isPlus : % -> Union(List(%),"failed") ---R isTimes : % -> Union(List(%),"failed") ---R lcmCoef : (%,%) -> Record(llcmres: %,coeff1: %,coeff2: %) if R has GCDDOM ---R mainVariable : % -> Union(OrderedVariableList(vl),"failed") ---R minimumDegree : (%,List(OrderedVariableList(vl))) -> List(NonNegativeInteger) ---R minimumDegree : (%,OrderedVariableList(vl)) -> NonNegativeInteger ---R monicDivide : (%,%,OrderedVariableList(vl)) -> Record(quotient: %,remainder: %) ---R monomial : (%,List(OrderedVariableList(vl)),List(NonNegativeInteger)) -> % ---R monomial : (%,OrderedVariableList(vl),NonNegativeInteger) -> % ---R multivariate : (SparseUnivariatePolynomial(%),OrderedVariableList(vl)) -> % ---R multivariate : (SparseUnivariatePolynomial(R),OrderedVariableList(vl)) -> % ---R numberOfMonomials : % -> NonNegativeInteger ---R patternMatch : (%,Pattern(Integer),PatternMatchResult(Integer,%)) -> PatternMatchResult(Integer,%) if OrderedVariableList(vl) has PATMAB(INT) and R has PATMAB(INT) ---R patternMatch : (%,Pattern(Float),PatternMatchResult(Float,%)) -> PatternMatchResult(Float,%) if OrderedVariableList(vl) has PATMAB(FLOAT) and R has PATMAB(FLOAT) ---R prime? : % -> Boolean if R has PFECAT ---R primitivePart : (%,OrderedVariableList(vl)) -> % if R has GCDDOM ---R primitivePart : % -> % if R has GCDDOM ---R reducedSystem : Matrix(%) -> Matrix(R) ---R reducedSystem : (Matrix(%),Vector(%)) -> Record(mat: Matrix(R),vec: Vector(R)) ---R reducedSystem : (Matrix(%),Vector(%)) -> Record(mat: Matrix(Integer),vec: Vector(Integer)) if R has LINEXP(INT) ---R reducedSystem : Matrix(%) -> Matrix(Integer) if R has LINEXP(INT) ---R resultant : (%,%,OrderedVariableList(vl)) -> % if R has COMRING ---R retract : % -> OrderedVariableList(vl) ---R retract : % -> Integer if R has RETRACT(INT) ---R retract : % -> Fraction(Integer) if R has RETRACT(FRAC(INT)) ---R retractIfCan : % -> Union(OrderedVariableList(vl),"failed") ---R retractIfCan : % -> Union(Integer,"failed") if R has RETRACT(INT) ---R retractIfCan : % -> Union(Fraction(Integer),"failed") if R has RETRACT(FRAC(INT)) ---R retractIfCan : % -> Union(R,"failed") ---R solveLinearPolynomialEquation : (List(SparseUnivariatePolynomial(%)),SparseUnivariatePolynomial(%)) -> Union(List(SparseUnivariatePolynomial(%)),"failed") if R has PFECAT ---R squareFree : % -> Factored(%) if R has GCDDOM ---R squareFreePart : % -> % if R has GCDDOM ---R squareFreePolynomial : SparseUnivariatePolynomial(%) -> Factored(SparseUnivariatePolynomial(%)) if R has PFECAT ---R subtractIfCan : (%,%) -> Union(%,"failed") ---R totalDegree : (%,List(OrderedVariableList(vl))) -> NonNegativeInteger ---R totalDegree : % -> NonNegativeInteger ---R unit? : % -> Boolean if R has INTDOM ---R unitCanonical : % -> % if R has INTDOM ---R unitNormal : % -> Record(unit: %,canonical: %,associate: %) if R has INTDOM ---R univariate : % -> SparseUnivariatePolynomial(R) ---R univariate : (%,OrderedVariableList(vl)) -> SparseUnivariatePolynomial(%) ---R variables : % -> List(OrderedVariableList(vl)) ---R ---E 11 + if (S has PolynomialFactorizationExplicit) then + -- we'll let the solveLinearPolynomialEquations operator + -- default from Field + pp,qq: QFP + lpp: List QFP + import Factored SparseUnivariatePolynomial % + + if S has CharacteristicNonZero then + + if S has canonicalUnitNormal and S has GcdDomain then + + charthRoot x == + n:= charthRoot x.num + n case "failed" => "failed" + d:=charthRoot x.den + d case "failed" => "failed" + n/d + + else + + charthRoot x == + -- to find x = p-th root of n/d + -- observe that xd is p-th root of n*d**(p-1) + ans:=charthRoot(x.num * + (x.den)**(characteristic()$%-1)::NonNegativeInteger) + ans case "failed" => "failed" + ans / x.den + + clear: List % -> List S + + clear l == + d:="lcm"/[x.den for x in l] + [ x.num * (d exquo x.den)::S for x in l] + + mat: Matrix % + + conditionP mat == + matD: Matrix S + matD:= matrix [ clear l for l in listOfLists mat ] + ansD := conditionP matD + ansD case "failed" => "failed" + ansDD:=ansD :: Vector(S) + [ ansDD(i)::% for i in 1..#ansDD]$Vector(%) + + factorPolynomial(pp) == + zero? pp => 0 + denpp:="lcm"/[denom u for u in coefficients pp] + ppD:DP:=map(x+->retract(x*denpp),pp) + ff:=factorPolynomial ppD + den1:%:=denpp::% + lfact:List Record(flg:Union("nil", "sqfr", "irred", "prime"), + fctr:QFP, xpnt:Integer) + lfact:= [[w.flg, + if leadingCoefficient w.fctr =1 then + map(x+->x::%,w.fctr) + else (lc:=(leadingCoefficient w.fctr)::%; + den1:=den1/lc**w.xpnt; + map(x+->x::%/lc,w.fctr)), + w.xpnt] for w in factorList ff] + makeFR(map(x+->x::%/den1,unit(ff)),lfact) + + factorSquareFreePolynomial(pp) == + zero? pp => 0 + degree pp = 0 => makeFR(pp,empty()) + lcpp:=leadingCoefficient pp + pp:=pp/lcpp + denpp:="lcm"/[denom u for u in coefficients pp] + ppD:DP:=map(x+->retract(x*denpp),pp) + ff:=factorSquareFreePolynomial ppD + den1:%:=denpp::%/lcpp + lfact:List Record(flg:Union("nil", "sqfr", "irred", "prime"), + fctr:QFP, xpnt:Integer) + lfact:= [[w.flg, + if leadingCoefficient w.fctr =1 then + map(x+->x::%,w.fctr) + else (lc:=(leadingCoefficient w.fctr)::%; + den1:=den1/lc**w.xpnt; + map(x+->x::%/lc,w.fctr)), + w.xpnt] for w in factorList ff] + makeFR(map(x+->x::%/den1,unit(ff)),lfact) -)spool -)lisp (bye) \end{chunk} -\begin{chunk}{GeneralDistributedMultivariatePolynomial.help} -==================================================================== -MultivariatePolynomial -DistributedMultivariatePolynomial -HomogeneousDistributedMultivariatePolynomial -GeneralDistributedMultivariatePolynomial -==================================================================== +\begin{chunk}{COQ FRAC} +(* domain FRAC *) +(* -DistributedMultivariatePolynomial which is abbreviated as DMP and -HomogeneousDistributedMultivariatePolynomial, which is abbreviated -as HDMP, are very similar to MultivariatePolynomial except that -they are represented and displayed in a non-recursive manner. + Rep:= Record(num:S, den:S) - (d1,d2,d3) : DMP([z,y,x],FRAC INT) - Type: Void + coerce(d:S):% == [d,1] -The constructor DMP orders its monomials lexicographically while -HDMP orders them by total order refined by reverse lexicographic -order. + zero?(x:%) == zero? x.num - d1 := -4*z + 4*y**2*x + 16*x**2 + 1 - 2 2 - - 4z + 4y x + 16x + 1 - Type: DistributedMultivariatePolynomial([z,y,x],Fraction Integer) + if S has GcdDomain and S has canonicalUnitNormal then - d2 := 2*z*y**2 + 4*x + 1 - 2 - 2z y + 4x + 1 - Type: DistributedMultivariatePolynomial([z,y,x],Fraction Integer) + retract(x:%):S == + ((x.den) = 1) => x.num + error "Denominator not equal to 1" - d3 := 2*z*x**2 - 2*y**2 - x - 2 2 - 2z x - 2y - x - Type: DistributedMultivariatePolynomial([z,y,x],Fraction Integer) + retractIfCan(x:%):Union(S, "failed") == + ((x.den) = 1) => x.num + "failed" + else -These constructors are mostly used in Groebner basis calculations. + retract(x:%):S == + (a:= x.num exquo x.den) case "failed" => + error "Denominator not equal to 1" + a - groebner [d1,d2,d3] - 1568 6 1264 5 6 4 182 3 2047 2 103 2857 - [z - ---- x - ---- x + --- x + --- x - ---- x - ---- x - -----, - 2745 305 305 549 610 2745 10980 - 2 112 6 84 5 1264 4 13 3 84 2 1772 2 - y + ---- x - --- x - ---- x - --- x + --- x + ---- x + ----, - 2745 305 305 549 305 2745 2745 - 7 29 6 17 4 11 3 1 2 15 1 - x + -- x - -- x - -- x + -- x + -- x + -] - 4 16 8 32 16 4 - Type: List DistributedMultivariatePolynomial([z,y,x],Fraction Integer) + retractIfCan(x:%):Union(S,"failed") == x.num exquo x.den - (n1,n2,n3) : HDMP([z,y,x],FRAC INT) - Type: Void + if S has EuclideanDomain then + wholePart x == + ((x.den) = 1) => x.num + x.num quo x.den - n1 := d1 - 2 2 - 4y x + 16x - 4z + 1 - Type: HomogeneousDistributedMultivariatePolynomial([z,y,x],Fraction Integer) + if S has IntegerNumberSystem then - n2 := d2 - 2 - 2z y + 4x + 1 - Type: HomogeneousDistributedMultivariatePolynomial([z,y,x],Fraction Integer) + floor x == + ((x.den) = 1) => x.num + x < 0 => -ceiling(-x) + wholePart x - n3 := d3 - 2 2 - 2z x - 2y - x - Type: HomogeneousDistributedMultivariatePolynomial([z,y,x],Fraction Integer) + ceiling x == + ((x.den) = 1) => x.num + x < 0 => -floor(-x) + 1 + wholePart x -Note that we get a different Groebner basis when we use the HDMP -polynomials, as expected. + if S has OpenMath then + -- TODO: somwhere this file does something which redefines the division + -- operator. Doh! - groebner [n1,n2,n3] - 4 3 3 2 1 1 4 29 3 1 2 7 9 1 - [y + 2x - - x + - z - -, x + -- x - - y - - z x - -- x - -, - 2 2 8 4 8 4 16 4 - 2 1 2 2 1 2 2 1 - z y + 2x + -, y x + 4x - z + -, z x - y - - x, - 2 4 2 - 2 2 2 1 3 - z - 4y + 2x - - z - - x] - 4 2 - Type: List HomogeneousDistributedMultivariatePolynomial([z,y,x], - Fraction Integer) + writeOMFrac(dev: OpenMathDevice, x: %): Void == + OMputApp(dev) + OMputSymbol(dev, "nums1", "rational") + OMwrite(dev, x.num, false) + OMwrite(dev, x.den, false) + OMputEndApp(dev) -GeneralDistributedMultivariatePolynomial is somewhat more flexible in -the sense that as well as accepting a list of variables to specify the -variable ordering, it also takes a predicate on exponent vectors to -specify the term ordering. With this polynomial type the user can -experiment with the effect of using completely arbitrary term orderings. -This flexibility is mostly important for algorithms such as Groebner -basis calculations which can be very sensitive to term ordering. + OMwrite(x: %): String == + s: String := "" + sp := OM_-STRINGTOSTRINGPTR(s)$Lisp + dev: OpenMathDevice := OMopenString(sp pretend String, OMencodingXML) + OMputObject(dev) + writeOMFrac(dev, x) + OMputEndObject(dev) + OMclose(dev) + s := OM_-STRINGPTRTOSTRING(sp)$Lisp pretend String + s -See Also: -o )help Polynomial -o )help UnivariatePolynomial -o )help MultivariatePolynomial -o )help HomogeneousDistributedMultivariatePolynomial -o )help DistributedMultivariatePolynomial -o )show GeneralDistributedMultivariatePolynomial + OMwrite(x: %, wholeObj: Boolean): String == + s: String := "" + sp := OM_-STRINGTOSTRINGPTR(s)$Lisp + dev: OpenMathDevice := OMopenString(sp pretend String, OMencodingXML) + if wholeObj then + OMputObject(dev) + writeOMFrac(dev, x) + if wholeObj then + OMputEndObject(dev) + OMclose(dev) + s := OM_-STRINGPTRTOSTRING(sp)$Lisp pretend String + s -\end{chunk} -\pagehead{GeneralDistributedMultivariatePolynomial}{GDMP} -\pagepic{ps/v103generaldistributedmultivariatepolynomial.ps}{GDMP}{1.00} -{\bf See}\\ -\pageto{DistributedMultivariatePolynomial}{DMP} -\pageto{HomogeneousDistributedMultivariatePolynomial}{HDMP} + OMwrite(dev: OpenMathDevice, x: %): Void == + OMputObject(dev) + writeOMFrac(dev, x) + OMputEndObject(dev) -{\bf Exports:}\\ -\begin{tabular}{lll} -\cross{GDMP}{0} & -\cross{GDMP}{1} & -\cross{GDMP}{associates?} \\ -\cross{GDMP}{binomThmExpt} & -\cross{GDMP}{characteristic} & -\cross{GDMP}{charthRoot} \\ -\cross{GDMP}{coefficient} & -\cross{GDMP}{coefficients} & -\cross{GDMP}{coerce} \\ -\cross{GDMP}{conditionP} & -\cross{GDMP}{content} & -\cross{GDMP}{D} \\ -\cross{GDMP}{degree} & -\cross{GDMP}{differentiate} & -\cross{GDMP}{discriminant} \\ -\cross{GDMP}{eval} & -\cross{GDMP}{exquo} & -\cross{GDMP}{factor} \\ -\cross{GDMP}{factorPolynomial} & -\cross{GDMP}{factorSquareFreePolynomial} & -\cross{GDMP}{gcd} \\ -\cross{GDMP}{gcdPolynomial} & -\cross{GDMP}{ground} & -\cross{GDMP}{ground?} \\ -\cross{GDMP}{hash} & -\cross{GDMP}{isExpt} & -\cross{GDMP}{isPlus} \\ -\cross{GDMP}{isTimes} & -\cross{GDMP}{latex} & -\cross{GDMP}{lcm} \\ -\cross{GDMP}{leadingCoefficient} & -\cross{GDMP}{leadingMonomial} & -\cross{GDMP}{mainVariable} \\ -\cross{GDMP}{map} & -\cross{GDMP}{mapExponents} & -\cross{GDMP}{max} \\ -\cross{GDMP}{min} & -\cross{GDMP}{minimumDegree} & -\cross{GDMP}{monicDivide} \\ -\cross{GDMP}{monomial} & -\cross{GDMP}{monomial?} & -\cross{GDMP}{monomials} \\ -\cross{GDMP}{multivariate} & -\cross{GDMP}{numberOfMonomials} & -\cross{GDMP}{one?} \\ -\cross{GDMP}{patternMatch} & -\cross{GDMP}{pomopo!} & -\cross{GDMP}{prime?} \\ -\cross{GDMP}{primitiveMonomials} & -\cross{GDMP}{primitivePart} & -\cross{GDMP}{recip} \\ -\cross{GDMP}{reducedSystem} & -\cross{GDMP}{reductum} & -\cross{GDMP}{reorder} \\ -\cross{GDMP}{resultant} & -\cross{GDMP}{retract} & -\cross{GDMP}{retractIfCan} \\ -\cross{GDMP}{sample} & -\cross{GDMP}{solveLinearPolynomialEquation} & -\cross{GDMP}{squareFree} \\ -\cross{GDMP}{squareFreePart} & -\cross{GDMP}{squareFreePolynomial} & -\cross{GDMP}{subtractIfCan} \\ -\cross{GDMP}{totalDegree} & -\cross{GDMP}{unit?} & -\cross{GDMP}{unitCanonical} \\ -\cross{GDMP}{unitNormal} & -\cross{GDMP}{univariate} & -\cross{GDMP}{variables} \\ -\cross{GDMP}{zero?} & -\cross{GDMP}{?*?} & -\cross{GDMP}{?**?} \\ -\cross{GDMP}{?+?} & -\cross{GDMP}{?-?} & -\cross{GDMP}{-?} \\ -\cross{GDMP}{?=?} & -\cross{GDMP}{?\~{}=?} & -\cross{GDMP}{?$<$?} \\ -\cross{GDMP}{?$<=$?} & -\cross{GDMP}{?$>$?} & -\cross{GDMP}{?$>=$?} \\ -\cross{GDMP}{?\^{}?} && -\end{tabular} + OMwrite(dev: OpenMathDevice, x: %, wholeObj: Boolean): Void == + if wholeObj then + OMputObject(dev) + writeOMFrac(dev, x) + if wholeObj then + OMputEndObject(dev) -\begin{chunk}{domain GDMP GeneralDistributedMultivariatePolynomial} -)abbrev domain GDMP GeneralDistributedMultivariatePolynomial -++ Author: Barry Trager -++ Description: -++ This type supports distributed multivariate polynomials -++ whose variables are from a user specified list of symbols. -++ The coefficient ring may be non commutative, -++ but the variables are assumed to commute. -++ The term ordering is specified by its third parameter. -++ Suggested types which define term orderings include: -++ \spadtype{DirectProduct}, \spadtype{HomogeneousDirectProduct}, -++ \spadtype{SplitHomogeneousDirectProduct} and finally -++ \spadtype{OrderedDirectProduct} which accepts an arbitrary user -++ function to define a term ordering. + if S has GcdDomain then -GeneralDistributedMultivariatePolynomial(vl,R,E): public == private where - vl: List Symbol - R: Ring - E: DirectProductCategory(#vl,NonNegativeInteger) - OV ==> OrderedVariableList(vl) - SUP ==> SparseUnivariatePolynomial - NNI ==> NonNegativeInteger + cancelGcd: % -> S - public == PolynomialCategory(R,E,OV) with - reorder: (%,List Integer) -> % - ++ reorder(p, perm) applies the permutation perm to the variables - ++ in a polynomial and returns the new correctly ordered polynomial + normalize: % -> % - private == PolynomialRing(R,E) add - --representations - Term := Record(k:E,c:R) - Rep := List Term - n := #vl - Vec ==> Vector(NonNegativeInteger) - zero?(p : %): Boolean == null(p : Rep) + normalize x == + zero?(x.num) => 0 + ((x.den) = 1) => x + uca := unitNormal(x.den) + zero?(x.den := uca.canonical) => error "division by zero" + x.num := x.num * uca.associate + x - totalDegree p == - zero? p => 0 - "max"/[reduce("+",(t.k)::(Vector NNI), 0) for t in p] + recip x == + zero?(x.num) => "failed" + normalize [x.den, x.num] - monomial(p:%, v: OV,e: NonNegativeInteger):% == - locv := lookup v - p*monomial(1, - directProduct [if z=locv then e else 0 for z in 1..n]$Vec) + cancelGcd x == + ((x.den) = 1) => x.den + d := gcd(x.num, x.den) + xn := x.num exquo d + xn case "failed" => + error "gcd not gcd in QF cancelGcd (numerator)" + xd := x.den exquo d + xd case "failed" => + error "gcd not gcd in QF cancelGcd (denominator)" + x.num := xn :: S + x.den := xd :: S + d - coerce(v: OV):% == monomial(1,v,1) + nn:S / dd:S == + zero? dd => error "division by zero" + cancelGcd(z := [nn, dd]) + normalize z - listCoef(p : %): List R == - rec : Term - [rec.c for rec in (p:Rep)] + x + y == + zero? y => x + zero? x => y + z := [x.den,y.den] + d := cancelGcd z + g := [z.den * x.num + z.num * y.num, d] + cancelGcd g + g.den := g.den * z.num * z.den + normalize g - mainVariable(p: %) == - zero?(p) => "failed" - for v in vl repeat - vv := variable(v)::OV - if degree(p,vv)>0 then return vv - "failed" + -- We can not rely on the defaulting mechanism + -- to supply a definition for -, even though this + -- definition would do, for thefollowing reasons: + -- 1) The user could have defined a subtraction + -- in Localize, which would not work for + -- QuotientField; + -- 2) even if he doesn't, the system currently + -- places a default definition in Localize, + -- which uses Localize's +, which does not + -- cancel gcds + x - y == + zero? y => x + z := [x.den, y.den] + d := cancelGcd z + g := [z.den * x.num - z.num * y.num, d] + cancelGcd g + g.den := g.den * z.num * z.den + normalize g - ground?(p) == mainVariable(p) case "failed" + x:% * y:% == + zero? x or zero? y => 0 + (x = 1) => y + (y = 1) => x + (x, y) := ([x.num, y.den], [y.num, x.den]) + cancelGcd x; cancelGcd y; + normalize [x.num * y.num, x.den * y.den] - retract(p : %): R == - not ground? p => error "not a constant" - leadingCoefficient p + n:Integer * x:% == + y := [n::S, x.den] + cancelGcd y + normalize [x.num * y.num, y.den] - retractIfCan(p : %): Union(R,"failed") == - ground?(p) => leadingCoefficient p - "failed" + nn:S * x:% == + y := [nn, x.den] + cancelGcd y + normalize [x.num * y.num, y.den] - degree(p: %,v: OV) == degree(univariate(p,v)) - minimumDegree(p: %,v: OV) == minimumDegree(univariate(p,v)) - differentiate(p: %,v: OV) == - multivariate(differentiate(univariate(p,v)),v) + differentiate(x:%, deriv:S -> S) == + y := [deriv(x.den), x.den] + d := cancelGcd(y) + y.num := deriv(x.num) * y.den - x.num * y.num + (d, y.den) := (y.den, d) + cancelGcd y + y.den := y.den * d * d + normalize y - degree(p: %,lv: List OV) == [degree(p,v) for v in lv] - minimumDegree(p: %,lv: List OV) == [minimumDegree(p,v) for v in lv] + if S has canonicalUnitNormal then - numberOfMonomials(p:%) == - l : Rep := p : Rep - null(l) => 1 - #l + x = y == (x.num = y.num) and (x.den = y.den) - monomial?(p : %): Boolean == - l : Rep := p : Rep - null(l) or null rest(l) + one? x == ((x.num) = 1) and ((x.den) = 1) + -- again assuming canonical nature of representation - if R has OrderedRing then - maxNorm(p : %): R == - l : List R := nil - r,m : R - m := 0 - for r in listCoef(p) repeat - if r > m then m := r - else if (-r) > m then m := -r - m + else - --trailingCoef(p : %) == - -- l : Rep := p : Rep - -- null l => 0 - -- r : Term := last l - -- r.c + nn:S/dd:S == if zero? dd then error "division by zero" else [nn,dd] - --leadingPrimitiveMonomial(p : %) == - -- ground?(p) => 1$% - -- r : Term := first(p:Rep) - -- r := [r.k,1$R]$Term -- new cell - -- list(r)$Rep :: % + recip x == + zero?(x.num) => "failed" + [x.den, x.num] - -- The following 2 defs are inherited from PolynomialRing + if (S has RetractableTo Fraction Integer) then - --leadingMonomial(p : %) == - -- ground?(p) => p - -- r : Term := first(p:Rep) - -- r := [r.k,r.c]$Term -- new cell - -- list(r)$Rep :: % + retract(x:%):Fraction(Integer) == retract(retract(x)@S) - --reductum(p : %): % == - -- ground? p => 0$% - -- (rest(p:Rep)):% + retractIfCan(x:%):Union(Fraction Integer, "failed") == + (u := retractIfCan(x)@Union(S, "failed")) case "failed" => "failed" + retractIfCan(u::S) - if R has Field then - (p : %) / (r : R) == inv(r) * p + else if (S has RetractableTo Integer) then - variables(p: %) == - maxdeg:Vector(NonNegativeInteger) := new(n,0) - while not zero?(p) repeat - tdeg := degree p - p := reductum p - for i in 1..n repeat - maxdeg.i := max(maxdeg.i, tdeg.i) - [index(i:PositiveInteger) for i in 1..n | maxdeg.i^=0] + retract(x:%):Fraction(Integer) == + retract(numer x) / retract(denom x) - reorder(p: %,perm: List Integer):% == - #perm ^= n => error "must be a complete permutation of all vars" - q := [[directProduct [term.k.j for j in perm]$Vec,term.c]$Term - for term in p] - sort((z1,z2) +-> z1.k > z2.k,q) + retractIfCan(x:%):Union(Fraction Integer, "failed") == + (n := retractIfCan numer x) case "failed" => "failed" + (d := retractIfCan denom x) case "failed" => "failed" + (n::Integer) / (d::Integer) - --coerce(dp:DistributedMultivariatePolynomial(vl,R)):% == - -- q:=dp:List(Term) - -- sort(#1.k > #2.k,q):% + QFP ==> SparseUnivariatePolynomial % - univariate(p: %,v: OV):SUP(%) == - zero?(p) => 0 - exp := degree p - locv := lookup v - deg:NonNegativeInteger := 0 - nexp := directProduct [if i=locv then (deg :=exp.i;0) else exp.i - for i in 1..n]$Vec - monomial(monomial(leadingCoefficient p,nexp),deg)+ - univariate(reductum p,v) + DP ==> SparseUnivariatePolynomial S - eval(p: %,v: OV,val:%):% == univariate(p,v)(val) + import UnivariatePolynomialCategoryFunctions2(%,QFP,S,DP) - eval(p: %,v: OV,val:R):% == eval(p,v,val::%)$% + import UnivariatePolynomialCategoryFunctions2(S,DP,%,QFP) - eval(p: %,lv: List OV,lval: List R):% == - lv = [] => p - eval(eval(p,first lv,(first lval)::%)$%, rest lv, rest lval)$% + if S has GcdDomain then - -- assume Lvar are sorted correctly - evalSortedVarlist(p: %,Lvar: List OV,Lpval: List %):% == - v := mainVariable p - v case "failed" => p - pv := v:: OV - Lvar=[] or Lpval=[] => p - mvar := Lvar.first - mvar > pv => evalSortedVarlist(p,Lvar.rest,Lpval.rest) - pval := Lpval.first - pts:SUP(%):= map(x+->evalSortedVarlist(x,Lvar,Lpval),univariate(p,pv)) - mvar=pv => pts(pval) - multivariate(pts,pv) + gcdPolynomial(pp,qq) == + zero? pp => qq + zero? qq => pp + zero? degree pp or zero? degree qq => 1 + denpp:="lcm"/[denom u for u in coefficients pp] + ppD:DP:=map(x+->retract(x*denpp),pp) + denqq:="lcm"/[denom u for u in coefficients qq] + qqD:DP:=map(x+->retract(x*denqq),qq) + g:=gcdPolynomial(ppD,qqD) + zero? degree g => 1 + ((lc:=leadingCoefficient g) = 1) => map(x+->x::%,g) + map(x+->x/lc,g) - eval(p:%,Lvar:List OV,Lpval:List %) == - nlvar:List OV := sort((x,y) +-> x > y,Lvar) - nlpval := - Lvar = nlvar => Lpval - nlpval := [Lpval.position(mvar,Lvar) for mvar in nlvar] - evalSortedVarlist(p,nlvar,nlpval) + if (S has PolynomialFactorizationExplicit) then + -- we'll let the solveLinearPolynomialEquations operator + -- default from Field + pp,qq: QFP + lpp: List QFP + import Factored SparseUnivariatePolynomial % - multivariate(p1:SUP(%),v: OV):% == - 0=p1 => 0 - degree p1 = 0 => leadingCoefficient p1 - leadingCoefficient(p1)*(v::%)**degree(p1) + - multivariate(reductum p1,v) + if S has CharacteristicNonZero then - univariate(p: %):SUP(R) == - (v := mainVariable p) case "failed" => - monomial(leadingCoefficient p,0) - q := univariate(p,v:: OV) - ans:SUP(R) := 0 - while q ^= 0 repeat - ans := ans + monomial(ground leadingCoefficient q,degree q) - q := reductum q - ans + if S has canonicalUnitNormal and S has GcdDomain then - multivariate(p:SUP(R),v: OV):% == - 0=p => 0 - (leadingCoefficient p)*monomial(1,v,degree p) + - multivariate(reductum p,v) + charthRoot x == + n:= charthRoot x.num + n case "failed" => "failed" + d:=charthRoot x.den + d case "failed" => "failed" + n/d - if R has GcdDomain then - content(p: %):R == - zero?(p) => 0 - "gcd"/[t.c for t in p] + else + + charthRoot x == + -- to find x = p-th root of n/d + -- observe that xd is p-th root of n*d**(p-1) + ans:=charthRoot(x.num * + (x.den)**(characteristic()$%-1)::NonNegativeInteger) + ans case "failed" => "failed" + ans / x.den + clear: List % -> List S + clear l == + d:="lcm"/[x.den for x in l] + [ x.num * (d exquo x.den)::S for x in l] - if R has EuclideanDomain and not(R has FloatingPointSystem) then - gcd(p: %,q:%):% == - gcd(p,q)$PolynomialGcdPackage(E,OV,R,%) + mat: Matrix % - else gcd(p: %,q:%):% == - r : R - (pv := mainVariable(p)) case "failed" => - (r := leadingCoefficient p) = 0$R => q - gcd(r,content q)::% - (qv := mainVariable(q)) case "failed" => - (r := leadingCoefficient q) = 0$R => p - gcd(r,content p)::% - pv gcd(p,content univariate(q,qv)) - qv gcd(q,content univariate(p,pv)) - multivariate(gcd(univariate(p,pv),univariate(q,qv)),pv) + conditionP mat == + matD: Matrix S + matD:= matrix [ clear l for l in listOfLists mat ] + ansD := conditionP matD + ansD case "failed" => "failed" + ansDD:=ansD :: Vector(S) + [ ansDD(i)::% for i in 1..#ansDD]$Vector(%) - coerce(p: %) : OutputForm == - zero?(p) => (0$R) :: OutputForm - l,lt : List OutputForm - lt := nil - vl1 := [v::OutputForm for v in vl] - for t in reverse p repeat - l := nil - for i in 1..#vl1 repeat - t.k.i = 0 => l - t.k.i = 1 => l := cons(vl1.i,l) - l := cons(vl1.i ** t.k.i ::OutputForm,l) - l := reverse l - if (t.c ^= 1) or (null l) then l := cons(t.c :: OutputForm,l) - 1 = #l => lt := cons(first l,lt) - lt := cons(reduce("*",l),lt) - 1 = #lt => first lt - reduce("+",lt) + factorPolynomial(pp) == + zero? pp => 0 + denpp:="lcm"/[denom u for u in coefficients pp] + ppD:DP:=map(x+->retract(x*denpp),pp) + ff:=factorPolynomial ppD + den1:%:=denpp::% + lfact:List Record(flg:Union("nil", "sqfr", "irred", "prime"), + fctr:QFP, xpnt:Integer) + lfact:= [[w.flg, + if leadingCoefficient w.fctr =1 then + map(x+->x::%,w.fctr) + else (lc:=(leadingCoefficient w.fctr)::%; + den1:=den1/lc**w.xpnt; + map(x+->x::%/lc,w.fctr)), + w.xpnt] for w in factorList ff] + makeFR(map(x+->x::%/den1,unit(ff)),lfact) -\end{chunk} + factorSquareFreePolynomial(pp) == + zero? pp => 0 + degree pp = 0 => makeFR(pp,empty()) + lcpp:=leadingCoefficient pp + pp:=pp/lcpp + denpp:="lcm"/[denom u for u in coefficients pp] + ppD:DP:=map(x+->retract(x*denpp),pp) + ff:=factorSquareFreePolynomial ppD + den1:%:=denpp::%/lcpp + lfact:List Record(flg:Union("nil", "sqfr", "irred", "prime"), + fctr:QFP, xpnt:Integer) + lfact:= [[w.flg, + if leadingCoefficient w.fctr =1 then + map(x+->x::%,w.fctr) + else (lc:=(leadingCoefficient w.fctr)::%; + den1:=den1/lc**w.xpnt; + map(x+->x::%/lc,w.fctr)), + w.xpnt] for w in factorList ff] + makeFR(map(x+->x::%/den1,unit(ff)),lfact) -\begin{chunk}{COQ GDMP} -(* domain GDMP *) -(* *) \end{chunk} -\begin{chunk}{GDMP.dotabb} -"GDMP" [color="#88FF44",href="bookvol10.3.pdf#nameddest=GDMP"] -"ALIST" [color="#88FF44",href="bookvol10.3.pdf#nameddest=ALIST"] -"GDMP" -> "ALIST" +\begin{chunk}{FRAC.dotabb} +"FRAC" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FRAC"] +"PFECAT" [color="#4488FF",href="bookvol10.2.pdf#nameddest=PFECAT"] +"FRAC" -> "PFECAT" \end{chunk} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain GMODPOL GeneralModulePolynomial} +\section{domain FRIDEAL FractionalIdeal} -\begin{chunk}{GeneralModulePolynomial.input} +\begin{chunk}{FractionalIdeal.input} )set break resume -)sys rm -f GeneralModulePolynomial.output -)spool GeneralModulePolynomial.output +)sys rm -f FractionalIdeal.output +)spool FractionalIdeal.output )set message test on )set message auto off )clear all --S 1 of 1 -)show GeneralModulePolynomial +)show FractionalIdeal --R ---R GeneralModulePolynomial(vl: List(Symbol),R: CommutativeRing,IS: OrderedSet,E: DirectProductCategory(#(vl),NonNegativeInteger),ff: ((Record(index: IS,exponent: E),Record(index: IS,exponent: E)) -> Boolean),P: PolynomialCategory(R,E,OrderedVariableList(vl))) is a domain constructor ---R Abbreviation for GeneralModulePolynomial is GMODPOL +--R FractionalIdeal(R: EuclideanDomain,F: QuotientFieldCategory(R),UP: UnivariatePolynomialCategory(F),A: Join(FramedAlgebra(F,UP),RetractableTo(F))) is a domain constructor +--R Abbreviation for FractionalIdeal is FRIDEAL --R This constructor is not exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for GMODPOL +--R Issue )edit bookvol10.3.pamphlet to see algebra source code for FRIDEAL --R --R------------------------------- Operations -------------------------------- ---R ?*? : (R,%) -> % ?*? : (%,R) -> % ---R ?*? : (%,P) -> % ?*? : (P,%) -> % ---R ?*? : (Integer,%) -> % ?*? : (NonNegativeInteger,%) -> % ---R ?*? : (PositiveInteger,%) -> % ?+? : (%,%) -> % ---R ?-? : (%,%) -> % -? : % -> % ---R ?=? : (%,%) -> Boolean 0 : () -> % ---R build : (R,IS,E) -> % coerce : % -> OutputForm ---R hash : % -> SingleInteger latex : % -> String ---R leadingCoefficient : % -> R leadingExponent : % -> E ---R leadingIndex : % -> IS multMonom : (R,E,%) -> % ---R reductum : % -> % sample : () -> % ---R unitVector : IS -> % zero? : % -> Boolean ---R ?~=? : (%,%) -> Boolean ---R leadingMonomial : % -> ModuleMonomial(IS,E,ff) ---R monomial : (R,ModuleMonomial(IS,E,ff)) -> % ---R subtractIfCan : (%,%) -> Union(%,"failed") +--R ?*? : (%,%) -> % ?**? : (%,Integer) -> % +--R ?**? : (%,NonNegativeInteger) -> % ?**? : (%,PositiveInteger) -> % +--R ?/? : (%,%) -> % ?=? : (%,%) -> Boolean +--R 1 : () -> % ?^? : (%,Integer) -> % +--R ?^? : (%,NonNegativeInteger) -> % ?^? : (%,PositiveInteger) -> % +--R basis : % -> Vector(A) coerce : % -> OutputForm +--R commutator : (%,%) -> % conjugate : (%,%) -> % +--R denom : % -> R hash : % -> SingleInteger +--R ideal : Vector(A) -> % inv : % -> % +--R latex : % -> String minimize : % -> % +--R norm : % -> F numer : % -> Vector(A) +--R one? : % -> Boolean recip : % -> Union(%,"failed") +--R sample : () -> % ?~=? : (%,%) -> Boolean +--R randomLC : (NonNegativeInteger,Vector(A)) -> A --R --E 1 )spool )lisp (bye) \end{chunk} -\begin{chunk}{GeneralModulePolynomial.help} +\begin{chunk}{FractionalIdeal.help} ==================================================================== -GeneralModulePolynomial examples +FractionalIdeal examples ==================================================================== -This package is undocumented +Fractional ideals in a framed algebra. See Also: -o )show GeneralModulePolynomial +o )show FractionalIdeal \end{chunk} -\pagehead{GeneralModulePolynomial}{GMODPOL} -\pagepic{ps/v103generalmodulepolynomial.ps}{GMODPOL}{1.00} +\pagehead{FractionalIdeal}{FRIDEAL} +\pagepic{ps/v103fractionalideal.ps}{FRIDEAL}{1.00} {\bf See}\\ -\pageto{ModuleMonomial}{MODMONOM} +\pageto{FramedModule}{FRMOD} +\pageto{HyperellipticFiniteDivisor}{HELLFDIV} +\pageto{FiniteDivisor}{FDIV} {\bf Exports:}\\ \begin{tabular}{lllll} -\cross{GMODPOL}{0} & -\cross{GMODPOL}{build} & -\cross{GMODPOL}{coerce} & -\cross{GMODPOL}{hash} & -\cross{GMODPOL}{latex} \\ -\cross{GMODPOL}{leadingCoefficient} & -\cross{GMODPOL}{leadingExponent} & -\cross{GMODPOL}{leadingIndex} & -\cross{GMODPOL}{leadingMonomial} & -\cross{GMODPOL}{monomial} \\ -\cross{GMODPOL}{multMonom} & -\cross{GMODPOL}{reductum} & -\cross{GMODPOL}{sample} & -\cross{GMODPOL}{subtractIfCan} & -\cross{GMODPOL}{unitVector} \\ -\cross{GMODPOL}{zero?} & -\cross{GMODPOL}{?\~{}=?} & -\cross{GMODPOL}{?*?} & -\cross{GMODPOL}{?+?} & -\cross{GMODPOL}{?-?} \\ -\cross{GMODPOL}{-?} & -\cross{GMODPOL}{?=?} &&& +\cross{FRIDEAL}{1} & +\cross{FRIDEAL}{basis} & +\cross{FRIDEAL}{coerce} & +\cross{FRIDEAL}{commutator} & +\cross{FRIDEAL}{conjugate} \\ +\cross{FRIDEAL}{denom} & +\cross{FRIDEAL}{hash} & +\cross{FRIDEAL}{ideal} & +\cross{FRIDEAL}{inv} & +\cross{FRIDEAL}{latex} \\ +\cross{FRIDEAL}{minimize} & +\cross{FRIDEAL}{norm} & +\cross{FRIDEAL}{numer} & +\cross{FRIDEAL}{one?} & +\cross{FRIDEAL}{randomLC} \\ +\cross{FRIDEAL}{recip} & +\cross{FRIDEAL}{sample} & +\cross{FRIDEAL}{?\~{}=?} & +\cross{FRIDEAL}{?**?} & +\cross{FRIDEAL}{?\^{}?} \\ +\cross{FRIDEAL}{?*?} & +\cross{FRIDEAL}{?**?} & +\cross{FRIDEAL}{?/?} & +\cross{FRIDEAL}{?=?} & +\cross{FRIDEAL}{?\^{}?} \end{tabular} -\begin{chunk}{domain GMODPOL GeneralModulePolynomial} -)abbrev domain GMODPOL GeneralModulePolynomial -++ Author: Mark Botch +\begin{chunk}{domain FRIDEAL FractionalIdeal} +)abbrev domain FRIDEAL FractionalIdeal +++ Author: Manuel Bronstein +++ Date Created: 27 Jan 1989 +++ Date Last Updated: 30 July 1993 ++ Description: -++ This package is undocumented - -GeneralModulePolynomial(vl, R, IS, E, ff, P): public == private where - vl: List(Symbol) - R: CommutativeRing - IS: OrderedSet - NNI ==> NonNegativeInteger - E: DirectProductCategory(#vl, NNI) - MM ==> Record(index:IS, exponent:E) - ff: (MM, MM) -> Boolean - OV ==> OrderedVariableList(vl) - P: PolynomialCategory(R, E, OV) - ModMonom ==> ModuleMonomial(IS, E, ff) - +++ Fractional ideals in a framed algebra. - public == Join(Module(P), Module(R)) with - leadingCoefficient: $ -> R - ++ leadingCoefficient(x) is not documented - leadingMonomial: $ -> ModMonom - ++ leadingMonomial(x) is not documented - leadingExponent: $ -> E - ++ leadingExponent(x) is not documented - leadingIndex: $ -> IS - ++ leadingIndex(x) is not documented - reductum: $ -> $ - ++ reductum(x) is not documented - monomial: (R, ModMonom) -> $ - ++ monomial(r,x) is not documented - unitVector: IS -> $ - ++ unitVector(x) is not documented - build: (R, IS, E) -> $ - ++ build(r,i,e) is not documented - multMonom: (R, E, $) -> $ - ++ multMonom(r,e,x) is not documented - "*": (P,$) -> $ - ++ p*x is not documented +FractionalIdeal(R, F, UP, A): Exports == Implementation where + R : EuclideanDomain + F : QuotientFieldCategory R + UP: UnivariatePolynomialCategory F + A : Join(FramedAlgebra(F, UP), RetractableTo F) + VF ==> Vector F + VA ==> Vector A + UPA ==> SparseUnivariatePolynomial A + QF ==> Fraction UP - private == FreeModule(R, ModMonom) add - Rep:= FreeModule(R, ModMonom) - leadingMonomial(p:$):ModMonom == leadingSupport(p)$Rep - leadingExponent(p:$):E == exponent(leadingMonomial p) - leadingIndex(p:$):IS == index(leadingMonomial p) - unitVector(i:IS):$ == monomial(1,[i, 0$E]$ModMonom) + Exports ==> Group with + ideal : VA -> % + ++ ideal([f1,...,fn]) returns the ideal \spad{(f1,...,fn)}. + basis : % -> VA + ++ basis((f1,...,fn)) returns the vector \spad{[f1,...,fn]}. + norm : % -> F + ++ norm(I) returns the norm of the ideal I. + numer : % -> VA + ++ numer(1/d * (f1,...,fn)) = the vector \spad{[f1,...,fn]}. + denom : % -> R + ++ denom(1/d * (f1,...,fn)) returns d. + minimize: % -> % + ++ minimize(I) returns a reduced set of generators for \spad{I}. + randomLC: (NonNegativeInteger, VA) -> A + ++ randomLC(n,x) should be local but conditional. + Implementation ==> add + import CommonDenominator(R, F, VF) + import MatrixCommonDenominator(UP, QF) + import InnerCommonDenominator(R, F, List R, List F) + import MatrixCategoryFunctions2(F, Vector F, Vector F, Matrix F, + UP, Vector UP, Vector UP, Matrix UP) + import MatrixCategoryFunctions2(UP, Vector UP, Vector UP, + Matrix UP, F, Vector F, Vector F, Matrix F) + import MatrixCategoryFunctions2(UP, Vector UP, Vector UP, + Matrix UP, QF, Vector QF, Vector QF, Matrix QF) - ----------------------------------------------------------------------------- + Rep := Record(num:VA, den:R) - build(c:R, i:IS, e:E):$ == monomial(c, construct(i, e)) + poly : % -> UPA + invrep : Matrix F -> A + upmat : (A, NonNegativeInteger) -> Matrix UP + summat : % -> Matrix UP + num2O : VA -> OutputForm + agcd : List A -> R + vgcd : VF -> R + mkIdeal : (VA, R) -> % + intIdeal: (List A, R) -> % + ret? : VA -> Boolean + tryRange: (NonNegativeInteger, VA, R, %) -> Union(%, "failed") - ----------------------------------------------------------------------------- + 1 == [[1]$VA, 1] - ---- WARNING: assumes c ^= 0 + numer i == i.num - multMonom(c:R, e:E, mp:$):$ == - zero? mp => mp - monomial(c * leadingCoefficient mp, [leadingIndex mp, - e + leadingExponent mp]) + multMonom(c, e, reductum mp) + denom i == i.den - ----------------------------------------------------------------------------- + mkIdeal(v, d) == [v, d] + invrep m == represents(transpose(m) * coordinates(1$A)) - ((p:P) * (mp:$)):$ == - zero? p => 0 - multMonom(leadingCoefficient p, degree p, mp) + - reductum(p) * mp + upmat(x, i) == map(s +-> monomial(s, i)$UP, regularRepresentation x) -\end{chunk} + ret? v == any?(s+->retractIfCan(s)@Union(F,"failed") case F, v) -\begin{chunk}{COQ GMODPOL} -(* domain GMODPOL *) -(* -*) + x = y == denom(x) = denom(y) and numer(x) = numer(y) -\end{chunk} + agcd l == reduce("gcd", [vgcd coordinates a for a in l]$List(R), 0) -\begin{chunk}{GMODPOL.dotabb} -"GMODPOL" [color="#88FF44",href="bookvol10.3.pdf#nameddest=GMODPOL"] -"PFECAT" [color="#4488FF",href="bookvol10.2.pdf#nameddest=PFECAT"] -"DIRPCAT" [color="#4488FF",href="bookvol10.2.pdf#nameddest=DIRPCAT"] -"GMODPOL" -> "PFECAT" -"GMODPOL" -> "DIRPCAT" + norm i == + ("gcd"/[retract(u)@R for u in coefficients determinant summat i]) + / denom(i) ** rank()$A -\end{chunk} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain GCNAALG GenericNonAssociativeAlgebra} + tryRange(range, nm, nrm, i) == + for j in 0..10 repeat + a := randomLC(10 * range, nm) + unit? gcd((retract(norm a)@R exquo nrm)::R, nrm) => + return intIdeal([nrm::F::A, a], denom i) + "failed" -\begin{chunk}{GenericNonAssociativeAlgebra.input} -)set break resume -)sys rm -f GenericNonAssociativeAlgebra.output -)spool GenericNonAssociativeAlgebra.output -)set message test on -)set message auto off -)clear all + summat i == + m := minIndex(v := numer i) + reduce("+", + [upmat(qelt(v, j + m), j) for j in 0..#v-1]$List(Matrix UP)) ---S 1 of 1 -)show GenericNonAssociativeAlgebra ---R ---R GenericNonAssociativeAlgebra(R: CommutativeRing,n: PositiveInteger,ls: List(Symbol),gamma: Vector(Matrix(R))) is a domain constructor ---R Abbreviation for GenericNonAssociativeAlgebra is GCNAALG ---R This constructor is not exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for GCNAALG ---R ---R------------------------------- Operations -------------------------------- ---R ?*? : (%,%) -> % ?*? : (Integer,%) -> % ---R ?*? : (NonNegativeInteger,%) -> % ?*? : (PositiveInteger,%) -> % ---R ?**? : (%,PositiveInteger) -> % ?+? : (%,%) -> % ---R ?-? : (%,%) -> % -? : % -> % ---R ?=? : (%,%) -> Boolean 0 : () -> % ---R alternative? : () -> Boolean antiAssociative? : () -> Boolean ---R antiCommutative? : () -> Boolean antiCommutator : (%,%) -> % ---R associative? : () -> Boolean associator : (%,%,%) -> % ---R basis : () -> Vector(%) coerce : % -> OutputForm ---R commutative? : () -> Boolean commutator : (%,%) -> % ---R flexible? : () -> Boolean generic : (Symbol,Vector(%)) -> % ---R generic : Vector(%) -> % generic : Vector(Symbol) -> % ---R generic : Symbol -> % generic : () -> % ---R hash : % -> SingleInteger jacobiIdentity? : () -> Boolean ---R jordanAdmissible? : () -> Boolean jordanAlgebra? : () -> Boolean ---R latex : % -> String leftAlternative? : () -> Boolean ---R lieAdmissible? : () -> Boolean lieAlgebra? : () -> Boolean ---R powerAssociative? : () -> Boolean rank : () -> PositiveInteger ---R rightAlternative? : () -> Boolean sample : () -> % ---R someBasis : () -> Vector(%) zero? : % -> Boolean ---R ?~=? : (%,%) -> Boolean ---R ?*? : (SquareMatrix(n,Fraction(Polynomial(R))),%) -> % ---R ?*? : (Fraction(Polynomial(R)),%) -> % ---R ?*? : (%,Fraction(Polynomial(R))) -> % ---R apply : (Matrix(Fraction(Polynomial(R))),%) -> % ---R associatorDependence : () -> List(Vector(Fraction(Polynomial(R)))) if Fraction(Polynomial(R)) has INTDOM ---R coerce : Vector(Fraction(Polynomial(R))) -> % ---R conditionsForIdempotents : () -> List(Polynomial(R)) if R has INTDOM ---R conditionsForIdempotents : Vector(%) -> List(Polynomial(R)) if R has INTDOM ---R conditionsForIdempotents : () -> List(Polynomial(Fraction(Polynomial(R)))) ---R conditionsForIdempotents : Vector(%) -> List(Polynomial(Fraction(Polynomial(R)))) ---R convert : Vector(Fraction(Polynomial(R))) -> % ---R convert : % -> Vector(Fraction(Polynomial(R))) ---R coordinates : Vector(%) -> Matrix(Fraction(Polynomial(R))) ---R coordinates : % -> Vector(Fraction(Polynomial(R))) ---R coordinates : (Vector(%),Vector(%)) -> Matrix(Fraction(Polynomial(R))) ---R coordinates : (%,Vector(%)) -> Vector(Fraction(Polynomial(R))) ---R ?.? : (%,Integer) -> Fraction(Polynomial(R)) ---R generic : (Vector(Symbol),Vector(%)) -> % ---R genericLeftDiscriminant : () -> Fraction(Polynomial(R)) if R has INTDOM ---R genericLeftMinimalPolynomial : % -> SparseUnivariatePolynomial(Fraction(Polynomial(R))) if R has INTDOM ---R genericLeftNorm : % -> Fraction(Polynomial(R)) if R has INTDOM ---R genericLeftTrace : % -> Fraction(Polynomial(R)) if R has INTDOM ---R genericLeftTraceForm : (%,%) -> Fraction(Polynomial(R)) if R has INTDOM ---R genericRightDiscriminant : () -> Fraction(Polynomial(R)) if R has INTDOM ---R genericRightMinimalPolynomial : % -> SparseUnivariatePolynomial(Fraction(Polynomial(R))) if R has INTDOM ---R genericRightNorm : % -> Fraction(Polynomial(R)) if R has INTDOM ---R genericRightTrace : % -> Fraction(Polynomial(R)) if R has INTDOM ---R genericRightTraceForm : (%,%) -> Fraction(Polynomial(R)) if R has INTDOM ---R leftCharacteristicPolynomial : % -> SparseUnivariatePolynomial(Fraction(Polynomial(R))) ---R leftDiscriminant : () -> Fraction(Polynomial(R)) ---R leftDiscriminant : Vector(%) -> Fraction(Polynomial(R)) ---R leftMinimalPolynomial : % -> SparseUnivariatePolynomial(Fraction(Polynomial(R))) if Fraction(Polynomial(R)) has INTDOM ---R leftNorm : % -> Fraction(Polynomial(R)) ---R leftPower : (%,PositiveInteger) -> % ---R leftRankPolynomial : () -> SparseUnivariatePolynomial(Fraction(Polynomial(R))) if R has INTDOM ---R leftRankPolynomial : () -> SparseUnivariatePolynomial(Polynomial(Fraction(Polynomial(R)))) if Fraction(Polynomial(R)) has FIELD ---R leftRecip : % -> Union(%,"failed") if Fraction(Polynomial(R)) has INTDOM ---R leftRegularRepresentation : % -> Matrix(Fraction(Polynomial(R))) ---R leftRegularRepresentation : (%,Vector(%)) -> Matrix(Fraction(Polynomial(R))) ---R leftTrace : % -> Fraction(Polynomial(R)) ---R leftTraceMatrix : () -> Matrix(Fraction(Polynomial(R))) ---R leftTraceMatrix : Vector(%) -> Matrix(Fraction(Polynomial(R))) ---R leftUnit : () -> Union(%,"failed") if Fraction(Polynomial(R)) has INTDOM ---R leftUnits : () -> Union(Record(particular: %,basis: List(%)),"failed") ---R noncommutativeJordanAlgebra? : () -> Boolean ---R plenaryPower : (%,PositiveInteger) -> % ---R recip : % -> Union(%,"failed") if Fraction(Polynomial(R)) has INTDOM ---R represents : Vector(Fraction(Polynomial(R))) -> % ---R represents : (Vector(Fraction(Polynomial(R))),Vector(%)) -> % ---R rightCharacteristicPolynomial : % -> SparseUnivariatePolynomial(Fraction(Polynomial(R))) ---R rightDiscriminant : () -> Fraction(Polynomial(R)) ---R rightDiscriminant : Vector(%) -> Fraction(Polynomial(R)) ---R rightMinimalPolynomial : % -> SparseUnivariatePolynomial(Fraction(Polynomial(R))) if Fraction(Polynomial(R)) has INTDOM ---R rightNorm : % -> Fraction(Polynomial(R)) ---R rightPower : (%,PositiveInteger) -> % ---R rightRankPolynomial : () -> SparseUnivariatePolynomial(Fraction(Polynomial(R))) if R has INTDOM ---R rightRankPolynomial : () -> SparseUnivariatePolynomial(Polynomial(Fraction(Polynomial(R)))) if Fraction(Polynomial(R)) has FIELD ---R rightRecip : % -> Union(%,"failed") if Fraction(Polynomial(R)) has INTDOM ---R rightRegularRepresentation : % -> Matrix(Fraction(Polynomial(R))) ---R rightRegularRepresentation : (%,Vector(%)) -> Matrix(Fraction(Polynomial(R))) ---R rightTrace : % -> Fraction(Polynomial(R)) ---R rightTraceMatrix : () -> Matrix(Fraction(Polynomial(R))) ---R rightTraceMatrix : Vector(%) -> Matrix(Fraction(Polynomial(R))) ---R rightUnit : () -> Union(%,"failed") if Fraction(Polynomial(R)) has INTDOM ---R rightUnits : () -> Union(Record(particular: %,basis: List(%)),"failed") ---R structuralConstants : () -> Vector(Matrix(Fraction(Polynomial(R)))) ---R structuralConstants : Vector(%) -> Vector(Matrix(Fraction(Polynomial(R)))) ---R subtractIfCan : (%,%) -> Union(%,"failed") ---R unit : () -> Union(%,"failed") if Fraction(Polynomial(R)) has INTDOM ---R ---E 1 + inv i == + m := inverse(map(s+->s::QF, summat i))::Matrix(QF) + cd := splitDenominator(denom(i)::F::UP::QF * m) + cd2 := splitDenominator coefficients(cd.den) + invd:= cd2.den / reduce("gcd", cd2.num) + d := reduce("max", [degree p for p in parts(cd.num)]) + ideal + [invd * invrep map(s+->coefficient(s, j), cd.num) for j in 0..d]$VA -)spool -)lisp (bye) -\end{chunk} -\begin{chunk}{GenericNonAssociativeAlgebra.help} -==================================================================== -GenericNonAssociativeAlgebra examples -==================================================================== + ideal v == + d := reduce("lcm", [commonDenominator coordinates qelt(v, i) + for i in minIndex v .. maxIndex v]$List(R)) + intIdeal([d::F * qelt(v, i) for i in minIndex v .. maxIndex v], d) -AlgebraGenericElementPackage allows you to create generic elements of an -algebra, i.e. the scalars are extended to include symbolic coefficients. + intIdeal(l, d) == + lr := empty()$List(R) + nr := empty()$List(A) + for x in removeDuplicates l repeat + if (u := retractIfCan(x)@Union(F, "failed")) case F + then lr := concat(retract(u::F)@R, lr) + else nr := concat(x, nr) + r := reduce("gcd", lr, 0) + g := agcd nr + a := (r quo (b := gcd(gcd(d, r), g)))::F::A + d := d quo b + r ^= 0 and ((g exquo r) case R) => mkIdeal([a], d) + invb := inv(b::F) + va:VA := [invb * m for m in nr] + zero? a => mkIdeal(va, d) + mkIdeal(concat(a, va), d) -See Also: -o )show GenericNonAssociativeAlgebra + vgcd v == + reduce("gcd", + [retract(v.i)@R for i in minIndex v .. maxIndex v]$List(R)) -\end{chunk} + poly i == + m := minIndex(v := numer i) + +/[monomial(qelt(v, i + m), i) for i in 0..#v-1] -\pagehead{GenericNonAssociativeAlgebra}{GCNAALG} -\pagepic{ps/v103genericnonassociativealgebra.ps}{GCNAALG}{1.00} + i1 * i2 == + intIdeal(coefficients(poly i1 * poly i2), denom i1 * denom i2) -{\bf Exports:}\\ -\begin{tabular}{ll} -\cross{GCNAALG}{0} & -\cross{GCNAALG}{alternative?} \\ -\cross{GCNAALG}{antiAssociative?} & -\cross{GCNAALG}{antiCommutative?} \\ -\cross{GCNAALG}{antiCommutator} & -\cross{GCNAALG}{apply} \\ -\cross{GCNAALG}{associative?} & -\cross{GCNAALG}{associator} \\ -\cross{GCNAALG}{associatorDependence} & -\cross{GCNAALG}{basis} \\ -\cross{GCNAALG}{coerce} & -\cross{GCNAALG}{commutative?} \\ -\cross{GCNAALG}{commutator} & -\cross{GCNAALG}{conditionsForIdempotents} \\ -\cross{GCNAALG}{convert} & -\cross{GCNAALG}{convert} \\ -\cross{GCNAALG}{coordinates} & -\cross{GCNAALG}{coordinates} \\ -\cross{GCNAALG}{coordinates} & -\cross{GCNAALG}{coordinates} \\ -\cross{GCNAALG}{flexible?} & -\cross{GCNAALG}{generic} \\ -\cross{GCNAALG}{genericLeftDiscriminant} & -\cross{GCNAALG}{genericLeftMinimalPolynomial} \\ -\cross{GCNAALG}{genericLeftNorm} & -\cross{GCNAALG}{genericLeftTrace} \\ -\cross{GCNAALG}{genericLeftTraceForm} & -\cross{GCNAALG}{genericRightDiscriminant} \\ -\cross{GCNAALG}{genericRightMinimalPolynomial} & -\cross{GCNAALG}{genericRightNorm} \\ -\cross{GCNAALG}{genericRightTrace} & -\cross{GCNAALG}{genericRightTraceForm} \\ -\cross{GCNAALG}{hash} & -\cross{GCNAALG}{jacobiIdentity?} \\ -\cross{GCNAALG}{jordanAdmissible?} & -\cross{GCNAALG}{jordanAlgebra?} \\ -\cross{GCNAALG}{latex} & -\cross{GCNAALG}{leftAlternative?} \\ -\cross{GCNAALG}{leftCharacteristicPolynomial} & -\cross{GCNAALG}{leftDiscriminant} \\ -\cross{GCNAALG}{leftDiscriminant} & -\cross{GCNAALG}{leftMinimalPolynomial} \\ -\cross{GCNAALG}{leftNorm} & -\cross{GCNAALG}{leftPower} \\ -\cross{GCNAALG}{leftRankPolynomial} & -\cross{GCNAALG}{leftRankPolynomial} \\ -\cross{GCNAALG}{leftRecip} & -\cross{GCNAALG}{leftRegularRepresentation} \\ -\cross{GCNAALG}{leftRegularRepresentation} & -\cross{GCNAALG}{leftTrace} \\ -\cross{GCNAALG}{leftTraceMatrix} & -\cross{GCNAALG}{leftTraceMatrix} \\ -\cross{GCNAALG}{leftUnit} & -\cross{GCNAALG}{leftUnits} \\ -\cross{GCNAALG}{lieAdmissible?} & -\cross{GCNAALG}{lieAlgebra?} \\ -\cross{GCNAALG}{noncommutativeJordanAlgebra?} & -\cross{GCNAALG}{plenaryPower} \\ -\cross{GCNAALG}{powerAssociative?} & -\cross{GCNAALG}{rank} \\ -\cross{GCNAALG}{recip} & -\cross{GCNAALG}{represents} \\ -\cross{GCNAALG}{rightAlternative?} & -\cross{GCNAALG}{rightCharacteristicPolynomial} \\ -\cross{GCNAALG}{rightDiscriminant} & -\cross{GCNAALG}{rightDiscriminant} \\ -\cross{GCNAALG}{rightMinimalPolynomial} & -\cross{GCNAALG}{rightNorm} \\ -\cross{GCNAALG}{rightPower} & -\cross{GCNAALG}{rightRankPolynomial} \\ -\cross{GCNAALG}{rightRankPolynomial} & -\cross{GCNAALG}{rightRecip} \\ -\cross{GCNAALG}{rightRegularRepresentation} & -\cross{GCNAALG}{rightRegularRepresentation} \\ -\cross{GCNAALG}{rightTrace} & -\cross{GCNAALG}{rightTraceMatrix} \\ -\cross{GCNAALG}{rightTraceMatrix} & -\cross{GCNAALG}{rightUnit} \\ -\cross{GCNAALG}{rightUnits} & -\cross{GCNAALG}{sample} \\ -\cross{GCNAALG}{someBasis} & -\cross{GCNAALG}{structuralConstants} \\ -\cross{GCNAALG}{structuralConstants} & -\cross{GCNAALG}{subtractIfCan} \\ -\cross{GCNAALG}{unit} & -\cross{GCNAALG}{zero?} \\ -\cross{GCNAALG}{?*?} & -\cross{GCNAALG}{?**?} \\ -\cross{GCNAALG}{?+?} & -\cross{GCNAALG}{?-?} \\ -\cross{GCNAALG}{-?} & -\cross{GCNAALG}{?=?} \\ -\cross{GCNAALG}{?.?} & -\cross{GCNAALG}{?\~{}=?} -\end{tabular} + i:$ ** m:Integer == + m < 0 => inv(i) ** (-m) + n := m::NonNegativeInteger + v := numer i + intIdeal([qelt(v, j) ** n for j in minIndex v .. maxIndex v], + denom(i) ** n) -\begin{chunk}{domain GCNAALG GenericNonAssociativeAlgebra} -)abbrev domain GCNAALG GenericNonAssociativeAlgebra -++ Authors: J. Grabmeier, R. Wisbauer -++ Date Created: 26 June 1991 -++ Date Last Updated: 26 June 1991 -++ Reference: -++ A. Woerz-Busekros: Algebra in Genetics -++ Lectures Notes in Biomathematics 36, -++ Springer-Verlag, Heidelberg, 1980 -++ Description: -++ AlgebraGenericElementPackage allows you to create generic elements -++ of an algebra, i.e. the scalars are extended to include symbolic -++ coefficients + num2O v == + paren [qelt(v, i)::OutputForm + for i in minIndex v .. maxIndex v]$List(OutputForm) -GenericNonAssociativeAlgebra(R : CommutativeRing, n : PositiveInteger,_ - ls : List Symbol, gamma: Vector Matrix R ): public == private where + basis i == + v := numer i + d := inv(denom(i)::F) + [d * qelt(v, j) for j in minIndex v .. maxIndex v] - NNI ==> NonNegativeInteger - V ==> Vector - PR ==> Polynomial R - FPR ==> Fraction Polynomial R - SUP ==> SparseUnivariatePolynomial - S ==> Symbol + coerce(i:$):OutputForm == + nm := num2O numer i + (denom i = 1) => nm + (1::Integer::OutputForm) / (denom(i)::OutputForm) * nm - public ==> Join(FramedNonAssociativeAlgebra(FPR), _ - LeftModule(SquareMatrix(n,FPR)) ) with + if F has Finite then - coerce : Vector FPR -> % - ++ coerce(v) assumes that it is called with a vector - ++ of length equal to the dimension of the algebra, then - ++ a linear combination with the basis element is formed - leftUnits:() -> Union(Record(particular: %, basis: List %), "failed") - ++ leftUnits() returns the affine space of all left units of the - ++ algebra, or \spad{"failed"} if there is none - rightUnits:() -> Union(Record(particular: %, basis: List %), "failed") - ++ rightUnits() returns the affine space of all right units of the - ++ algebra, or \spad{"failed"} if there is none - generic : () -> % - ++ generic() returns a generic element, i.e. the linear combination - ++ of the fixed basis with the symbolic coefficients - ++ \spad{%x1,%x2,..} - generic : Symbol -> % - ++ generic(s) returns a generic element, i.e. the linear combination - ++ of the fixed basis with the symbolic coefficients - ++ \spad{s1,s2,..} - generic : Vector Symbol -> % - ++ generic(vs) returns a generic element, i.e. the linear combination - ++ of the fixed basis with the symbolic coefficients - ++ \spad{vs}; - ++ error, if the vector of symbols is too short - generic : Vector % -> % - ++ generic(ve) returns a generic element, i.e. the linear combination - ++ of \spad{ve} basis with the symbolic coefficients - ++ \spad{%x1,%x2,..} - generic : (Symbol, Vector %) -> % - ++ generic(s,v) returns a generic element, i.e. the linear combination - ++ of v with the symbolic coefficients - ++ \spad{s1,s2,..} - generic : (Vector Symbol, Vector %) -> % - ++ generic(vs,ve) returns a generic element, i.e. the linear combination - ++ of \spad{ve} with the symbolic coefficients \spad{vs} - ++ error, if the vector of symbols is shorter than the vector of - ++ elements - if R has IntegralDomain then - leftRankPolynomial : () -> SparseUnivariatePolynomial FPR - ++ leftRankPolynomial() returns the left minimimal polynomial - ++ of the generic element - genericLeftMinimalPolynomial : % -> SparseUnivariatePolynomial FPR - ++ genericLeftMinimalPolynomial(a) substitutes the coefficients - ++ of {em a} for the generic coefficients in - ++ \spad{leftRankPolynomial()} - genericLeftTrace : % -> FPR - ++ genericLeftTrace(a) substitutes the coefficients - ++ of \spad{a} for the generic coefficients into the - ++ coefficient of the second highest term in - ++ \spadfun{leftRankPolynomial} and changes the sign. - ++ This is a linear form - genericLeftNorm : % -> FPR - ++ genericLeftNorm(a) substitutes the coefficients - ++ of \spad{a} for the generic coefficients into the - ++ coefficient of the constant term in \spadfun{leftRankPolynomial} - ++ and changes the sign if the degree of this polynomial is odd. - ++ This is a form of degree k - rightRankPolynomial : () -> SparseUnivariatePolynomial FPR - ++ rightRankPolynomial() returns the right minimimal polynomial - ++ of the generic element - genericRightMinimalPolynomial : % -> SparseUnivariatePolynomial FPR - ++ genericRightMinimalPolynomial(a) substitutes the coefficients - ++ of \spad{a} for the generic coefficients in - ++ \spadfun{rightRankPolynomial} - genericRightTrace : % -> FPR - ++ genericRightTrace(a) substitutes the coefficients - ++ of \spad{a} for the generic coefficients into the - ++ coefficient of the second highest term in - ++ \spadfun{rightRankPolynomial} and changes the sign - genericRightNorm : % -> FPR - ++ genericRightNorm(a) substitutes the coefficients - ++ of \spad{a} for the generic coefficients into the - ++ coefficient of the constant term in \spadfun{rightRankPolynomial} - ++ and changes the sign if the degree of this polynomial is odd - genericLeftTraceForm : (%,%) -> FPR - ++ genericLeftTraceForm (a,b) is defined to be - ++ \spad{genericLeftTrace (a*b)}, this defines - ++ a symmetric bilinear form on the algebra - genericLeftDiscriminant: () -> FPR - ++ genericLeftDiscriminant() is the determinant of the - ++ generic left trace forms of all products of basis element, - ++ if the generic left trace form is associative, an algebra - ++ is separable if the generic left discriminant is invertible, - ++ if it is non-zero, there is some ring extension which - ++ makes the algebra separable - genericRightTraceForm : (%,%) -> FPR - ++ genericRightTraceForm (a,b) is defined to be - ++ \spadfun{genericRightTrace (a*b)}, this defines - ++ a symmetric bilinear form on the algebra - genericRightDiscriminant: () -> FPR - ++ genericRightDiscriminant() is the determinant of the - ++ generic left trace forms of all products of basis element, - ++ if the generic left trace form is associative, an algebra - ++ is separable if the generic left discriminant is invertible, - ++ if it is non-zero, there is some ring extension which - ++ makes the algebra separable - conditionsForIdempotents: Vector % -> List Polynomial R - ++ conditionsForIdempotents([v1,...,vn]) determines a complete list - ++ of polynomial equations for the coefficients of idempotents - ++ with respect to the \spad{R}-module basis \spad{v1},...,\spad{vn} - conditionsForIdempotents: () -> List Polynomial R - ++ conditionsForIdempotents() determines a complete list - ++ of polynomial equations for the coefficients of idempotents - ++ with respect to the fixed \spad{R}-module basis + randomLC(m, v) == + +/[random()$F * qelt(v, j) for j in minIndex v .. maxIndex v] - private ==> AlgebraGivenByStructuralConstants(FPR,n,ls,_ - coerce(gamma)$CoerceVectorMatrixPackage(R) ) add + else - listOfNumbers : List String := [PRINC_-TO_-STRING(q)$Lisp for q in 1..n] - symbolsForCoef : V Symbol := - [concat("%", concat("x", i))::Symbol for i in listOfNumbers] - genericElement : % := - v : Vector PR := - [monomial(1$PR, [symbolsForCoef.i],[1]) for i in 1..n] - convert map(coerce,v)$VectorFunctions2(PR,FPR) + randomLC(m, v) == + +/[(random()$Integer rem m::Integer) * qelt(v, j) + for j in minIndex v .. maxIndex v] - eval : (FPR, %) -> FPR - eval(rf,a) == - -- for the moment we only substitute the numerators - -- of the coefficients - coefOfa : List PR := - map(numer, entries coordinates a)$ListFunctions2(FPR,PR) - ls : List PR :=[monomial(1$PR, [s],[1]) for s in entries symbolsForCoef] - lEq : List Equation PR := [] - for i in 1..maxIndex ls repeat - lEq := cons(equation(ls.i,coefOfa.i)$Equation(PR) , lEq) - top : PR := eval(numer(rf),lEq)$PR - bot : PR := eval(numer(rf),lEq)$PR - top/bot + minimize i == + n := (#(nm := numer i)) + (n = 1) or (n < 3 and ret? nm) => i + nrm := retract(norm mkIdeal(nm, 1))@R + for range in 1..5 repeat + (u := tryRange(range, nm, nrm, i)) case $ => return(u::$) + i +\end{chunk} - if R has IntegralDomain then +\begin{chunk}{COQ FRIDEAL} +(* domain FRIDEAL *) +(* + import CommonDenominator(R, F, VF) + import MatrixCommonDenominator(UP, QF) + import InnerCommonDenominator(R, F, List R, List F) + import MatrixCategoryFunctions2(F, Vector F, Vector F, Matrix F, + UP, Vector UP, Vector UP, Matrix UP) + import MatrixCategoryFunctions2(UP, Vector UP, Vector UP, + Matrix UP, F, Vector F, Vector F, Matrix F) + import MatrixCategoryFunctions2(UP, Vector UP, Vector UP, + Matrix UP, QF, Vector QF, Vector QF, Matrix QF) - genericLeftTraceForm(a,b) == genericLeftTrace(a*b) - genericLeftDiscriminant() == - listBasis : List % := entries basis()$% - m : Matrix FPR := matrix - [[genericLeftTraceForm(a,b) for a in listBasis] for b in listBasis] - determinant m + Rep := Record(num:VA, den:R) - genericRightTraceForm(a,b) == genericRightTrace(a*b) - genericRightDiscriminant() == - listBasis : List % := entries basis()$% - m : Matrix FPR := matrix - [[genericRightTraceForm(a,b) for a in listBasis] for b in listBasis] - determinant m + poly : % -> UPA + invrep : Matrix F -> A + upmat : (A, NonNegativeInteger) -> Matrix UP + summat : % -> Matrix UP + num2O : VA -> OutputForm + agcd : List A -> R + vgcd : VF -> R + mkIdeal : (VA, R) -> % + intIdeal: (List A, R) -> % + ret? : VA -> Boolean + tryRange: (NonNegativeInteger, VA, R, %) -> Union(%, "failed") + 1 == [[1]$VA, 1] + numer i == i.num - leftRankPoly : SparseUnivariatePolynomial FPR := 0 - initLeft? : Boolean :=true + denom i == i.den - initializeLeft: () -> Void - initializeLeft() == - -- reset initialize flag - initLeft?:=false - leftRankPoly := leftMinimalPolynomial genericElement - void()$Void + mkIdeal(v, d) == [v, d] - rightRankPoly : SparseUnivariatePolynomial FPR := 0 - initRight? : Boolean :=true + invrep m == represents(transpose(m) * coordinates(1$A)) - initializeRight: () -> Void - initializeRight() == - -- reset initialize flag - initRight?:=false - rightRankPoly := rightMinimalPolynomial genericElement - void()$Void + upmat(x, i) == map(s +-> monomial(s, i)$UP, regularRepresentation x) - leftRankPolynomial() == - if initLeft? then initializeLeft() - leftRankPoly + ret? v == any?(s+->retractIfCan(s)@Union(F,"failed") case F, v) - rightRankPolynomial() == - if initRight? then initializeRight() - rightRankPoly + x = y == denom(x) = denom(y) and numer(x) = numer(y) - genericLeftMinimalPolynomial a == - if initLeft? then initializeLeft() - map(x+->eval(x,a),leftRankPoly)$SUP(FPR) + agcd l == reduce("gcd", [vgcd coordinates a for a in l]$List(R), 0) - genericRightMinimalPolynomial a == - if initRight? then initializeRight() - map(x+->eval(x,a),rightRankPoly)$SUP(FPR) + norm i == + ("gcd"/[retract(u)@R for u in coefficients determinant summat i]) + / denom(i) ** rank()$A - genericLeftTrace a == - if initLeft? then initializeLeft() - d1 : NNI := (degree leftRankPoly - 1) :: NNI - rf : FPR := coefficient(leftRankPoly, d1) - rf := eval(rf,a) - - rf + tryRange(range, nm, nrm, i) == + for j in 0..10 repeat + a := randomLC(10 * range, nm) + unit? gcd((retract(norm a)@R exquo nrm)::R, nrm) => + return intIdeal([nrm::F::A, a], denom i) + "failed" - genericRightTrace a == - if initRight? then initializeRight() - d1 : NNI := (degree rightRankPoly - 1) :: NNI - rf : FPR := coefficient(rightRankPoly, d1) - rf := eval(rf,a) - - rf + summat i == + m := minIndex(v := numer i) + reduce("+", + [upmat(qelt(v, j + m), j) for j in 0..#v-1]$List(Matrix UP)) - genericLeftNorm a == - if initLeft? then initializeLeft() - rf : FPR := coefficient(leftRankPoly, 1) - if odd? degree leftRankPoly then rf := - rf - rf + inv i == + m := inverse(map(s+->s::QF, summat i))::Matrix(QF) + cd := splitDenominator(denom(i)::F::UP::QF * m) + cd2 := splitDenominator coefficients(cd.den) + invd:= cd2.den / reduce("gcd", cd2.num) + d := reduce("max", [degree p for p in parts(cd.num)]) + ideal + [invd * invrep map(s+->coefficient(s, j), cd.num) for j in 0..d]$VA - genericRightNorm a == - if initRight? then initializeRight() - rf : FPR := coefficient(rightRankPoly, 1) - if odd? degree rightRankPoly then rf := - rf - rf + ideal v == + d := reduce("lcm", [commonDenominator coordinates qelt(v, i) + for i in minIndex v .. maxIndex v]$List(R)) + intIdeal([d::F * qelt(v, i) for i in minIndex v .. maxIndex v], d) - conditionsForIdempotents(b: V %) : List Polynomial R == - x : % := generic(b) - map(numer,entries coordinates(x*x-x,b))$ListFunctions2(FPR,PR) + intIdeal(l, d) == + lr := empty()$List(R) + nr := empty()$List(A) + for x in removeDuplicates l repeat + if (u := retractIfCan(x)@Union(F, "failed")) case F + then lr := concat(retract(u::F)@R, lr) + else nr := concat(x, nr) + r := reduce("gcd", lr, 0) + g := agcd nr + a := (r quo (b := gcd(gcd(d, r), g)))::F::A + d := d quo b + r ^= 0 and ((g exquo r) case R) => mkIdeal([a], d) + invb := inv(b::F) + va:VA := [invb * m for m in nr] + zero? a => mkIdeal(va, d) + mkIdeal(concat(a, va), d) - conditionsForIdempotents(): List Polynomial R == - x : % := genericElement - map(numer,entries coordinates(x*x-x))$ListFunctions2(FPR,PR) + vgcd v == + reduce("gcd", + [retract(v.i)@R for i in minIndex v .. maxIndex v]$List(R)) - generic() == genericElement + poly i == + m := minIndex(v := numer i) + +/[monomial(qelt(v, i + m), i) for i in 0..#v-1] - generic(vs:V S, ve: V %): % == - maxIndex v > maxIndex ve => - error "generic: too little symbols" - v : Vector PR := - [monomial(1$PR, [vs.i],[1]) for i in 1..maxIndex ve] - represents(map(coerce,v)$VectorFunctions2(PR,FPR),ve) + i1 * i2 == + intIdeal(coefficients(poly i1 * poly i2), denom i1 * denom i2) - generic(s: S, ve: V %): % == - lON : List String := [PRINC_-TO_-STRING(q)$Lisp for q in 1..maxIndex ve] - sFC : Vector Symbol := - [concat(s pretend String, i)::Symbol for i in lON] - generic(sFC, ve) + i:$ ** m:Integer == + m < 0 => inv(i) ** (-m) + n := m::NonNegativeInteger + v := numer i + intIdeal([qelt(v, j) ** n for j in minIndex v .. maxIndex v], + denom(i) ** n) - generic(ve : V %) == - lON : List String := [PRINC_-TO_-STRING(q)$Lisp for q in 1..maxIndex ve] - sFC : Vector Symbol := - [concat("%", concat("x", i))::Symbol for i in lON] - v : Vector PR := - [monomial(1$PR, [sFC.i],[1]) for i in 1..maxIndex ve] - represents(map(coerce,v)$VectorFunctions2(PR,FPR),ve) + num2O v == + paren [qelt(v, i)::OutputForm + for i in minIndex v .. maxIndex v]$List(OutputForm) - generic(vs:V S): % == generic(vs, basis()$%) + basis i == + v := numer i + d := inv(denom(i)::F) + [d * qelt(v, j) for j in minIndex v .. maxIndex v] - generic(s: S): % == generic(s, basis()$%) + coerce(i:$):OutputForm == + nm := num2O numer i + (denom i = 1) => nm + (1::Integer::OutputForm) / (denom(i)::OutputForm) * nm - -- variations on eval - --coefOfa : List FPR := entries coordinates a - --ls : List Symbol := entries symbolsForCoef - -- a very dangerous sequential implementation for the moment, - -- because the compiler doesn't manage the parallel code - -- also doesn't run: - -- not known that (Fraction (Polynomial R)) has (has (Polynomial R) - -- (Evalable (Fraction (Polynomial R)))) - --res : FPR := rf - --for eq in lEq repeat res := eval(res,eq)$FPR - --res - --rf - --eval(rf, le)$FPR - --eval(rf, entries symbolsForCoef, coefOfa)$FPR - --eval(rf, ls, coefOfa)$FPR - --le : List Equation PR := [equation(lh,rh) for lh in ls for rh in coefOfa] + if F has Finite then -\end{chunk} + randomLC(m, v) == + +/[random()$F * qelt(v, j) for j in minIndex v .. maxIndex v] + + else + + randomLC(m, v) == + +/[(random()$Integer rem m::Integer) * qelt(v, j) + for j in minIndex v .. maxIndex v] + + minimize i == + n := (#(nm := numer i)) + (n = 1) or (n < 3 and ret? nm) => i + nrm := retract(norm mkIdeal(nm, 1))@R + for range in 1..5 repeat + (u := tryRange(range, nm, nrm, i)) case $ => return(u::$) + i -\begin{chunk}{COQ GCNAALG} -(* domain GCNAALG *) -(* *) \end{chunk} -\begin{chunk}{GCNAALG.dotabb} -"GCNAALG" [color="#88FF44",href="bookvol10.3.pdf#nameddest=GCNAALG"] -"FRNAALG" [color="#4488FF",href="bookvol10.2.pdf#nameddest=FRNAALG"] -"GCNAALG" -> "FRNAALG" +\begin{chunk}{FRIDEAL.dotabb} +"FRIDEAL" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FRIDEAL"] +"FRAMALG" [color="#4488FF",href="bookvol10.2.pdf#nameddest=FRAMALG"] +"FRIDEAL" -> "FRAMALG" \end{chunk} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain GPOLSET GeneralPolynomialSet} +\section{domain FRMOD FramedModule} -\begin{chunk}{GeneralPolynomialSet.input} +\begin{chunk}{FramedModule.input} )set break resume -)sys rm -f GeneralPolynomialSet.output -)spool GeneralPolynomialSet.output +)sys rm -f FramedModule.output +)spool FramedModule.output )set message test on )set message auto off )clear all --S 1 of 1 -)show GeneralPolynomialSet +)show FramedModule --R ---R GeneralPolynomialSet(R: Ring,E: OrderedAbelianMonoidSup,VarSet: OrderedSet,P: RecursivePolynomialCategory(R,E,VarSet)) is a domain constructor ---R Abbreviation for GeneralPolynomialSet is GPOLSET +--R FramedModule(R: EuclideanDomain,F: QuotientFieldCategory(R),UP: UnivariatePolynomialCategory(F),A: FramedAlgebra(F,UP),ibasis: Vector(A)) is a domain constructor +--R Abbreviation for FramedModule is FRMOD --R This constructor is not exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for GPOLSET +--R Issue )edit bookvol10.3.pamphlet to see algebra source code for FRMOD --R --R------------------------------- Operations -------------------------------- ---R ?=? : (%,%) -> Boolean coerce : % -> List(P) ---R coerce : % -> OutputForm collect : (%,VarSet) -> % ---R collectUnder : (%,VarSet) -> % collectUpper : (%,VarSet) -> % ---R construct : List(P) -> % convert : List(P) -> % ---R copy : % -> % empty : () -> % ---R empty? : % -> Boolean eq? : (%,%) -> Boolean ---R hash : % -> SingleInteger latex : % -> String ---R mainVariables : % -> List(VarSet) map : ((P -> P),%) -> % ---R mvar : % -> VarSet retract : List(P) -> % ---R sample : () -> % trivialIdeal? : % -> Boolean ---R variables : % -> List(VarSet) ?~=? : (%,%) -> Boolean ---R #? : % -> NonNegativeInteger if $ has finiteAggregate ---R any? : ((P -> Boolean),%) -> Boolean if $ has finiteAggregate ---R convert : % -> InputForm if P has KONVERT(INFORM) ---R count : ((P -> Boolean),%) -> NonNegativeInteger if $ has finiteAggregate ---R count : (P,%) -> NonNegativeInteger if $ has finiteAggregate and P has SETCAT ---R eval : (%,List(Equation(P))) -> % if P has EVALAB(P) and P has SETCAT ---R eval : (%,Equation(P)) -> % if P has EVALAB(P) and P has SETCAT ---R eval : (%,P,P) -> % if P has EVALAB(P) and P has SETCAT ---R eval : (%,List(P),List(P)) -> % if P has EVALAB(P) and P has SETCAT ---R every? : ((P -> Boolean),%) -> Boolean if $ has finiteAggregate ---R find : ((P -> Boolean),%) -> Union(P,"failed") ---R headRemainder : (P,%) -> Record(num: P,den: R) if R has INTDOM ---R less? : (%,NonNegativeInteger) -> Boolean ---R mainVariable? : (VarSet,%) -> Boolean ---R map! : ((P -> P),%) -> % if $ has shallowlyMutable ---R member? : (P,%) -> Boolean if $ has finiteAggregate and P has SETCAT ---R members : % -> List(P) if $ has finiteAggregate ---R more? : (%,NonNegativeInteger) -> Boolean ---R parts : % -> List(P) if $ has finiteAggregate ---R reduce : (((P,P) -> P),%) -> P if $ has finiteAggregate ---R reduce : (((P,P) -> P),%,P) -> P if $ has finiteAggregate ---R reduce : (((P,P) -> P),%,P,P) -> P if $ has finiteAggregate and P has SETCAT ---R remainder : (P,%) -> Record(rnum: R,polnum: P,den: R) if R has INTDOM ---R remove : ((P -> Boolean),%) -> % if $ has finiteAggregate ---R remove : (P,%) -> % if $ has finiteAggregate and P has SETCAT ---R removeDuplicates : % -> % if $ has finiteAggregate and P has SETCAT ---R retractIfCan : List(P) -> Union(%,"failed") ---R rewriteIdealWithHeadRemainder : (List(P),%) -> List(P) if R has INTDOM ---R rewriteIdealWithRemainder : (List(P),%) -> List(P) if R has INTDOM ---R roughBase? : % -> Boolean if R has INTDOM ---R roughEqualIdeals? : (%,%) -> Boolean if R has INTDOM ---R roughSubIdeal? : (%,%) -> Boolean if R has INTDOM ---R roughUnitIdeal? : % -> Boolean if R has INTDOM ---R select : ((P -> Boolean),%) -> % if $ has finiteAggregate ---R size? : (%,NonNegativeInteger) -> Boolean ---R sort : (%,VarSet) -> Record(under: %,floor: %,upper: %) ---R triangular? : % -> Boolean if R has INTDOM +--R ?*? : (%,%) -> % ?**? : (%,NonNegativeInteger) -> % +--R ?**? : (%,PositiveInteger) -> % ?=? : (%,%) -> Boolean +--R 1 : () -> % ?^? : (%,NonNegativeInteger) -> % +--R ?^? : (%,PositiveInteger) -> % basis : % -> Vector(A) +--R coerce : % -> OutputForm hash : % -> SingleInteger +--R latex : % -> String module : Vector(A) -> % +--R norm : % -> F one? : % -> Boolean +--R recip : % -> Union(%,"failed") sample : () -> % +--R ?~=? : (%,%) -> Boolean +--R module : FractionalIdeal(R,F,UP,A) -> % if A has RETRACT(F) --R --E 1 )spool )lisp (bye) \end{chunk} -\begin{chunk}{GeneralPolynomialSet.help} +\begin{chunk}{FramedModule.help} ==================================================================== -GeneralPolynomialSet examples +FramedModule examples ==================================================================== -A domain for polynomial sets. +Module representation of fractional ideals. See Also: -o )show GeneralPolynomialSet +o )show FramedModule \end{chunk} -\pagehead{GeneralPolynomialSet}{GPOLSET} -\pagepic{ps/v103generalpolynomialset.ps}{GPOLSET}{1.00} +\pagehead{FramedModule}{FRMOD} +\pagepic{ps/v103framedmodule.ps}{FRMOD}{1.00} +{\bf See}\\ +\pageto{FractionalIdeal}{FRIDEAL} +\pageto{HyperellipticFiniteDivisor}{HELLFDIV} +\pageto{FiniteDivisor}{FDIV} {\bf Exports:}\\ -\begin{tabular}{ll} -\cross{GPOLSET}{any?} & -\cross{GPOLSET}{coerce} \\ -\cross{GPOLSET}{collect} & -\cross{GPOLSET}{collectUnder} \\ -\cross{GPOLSET}{collectUpper} & -\cross{GPOLSET}{construct} \\ -\cross{GPOLSET}{convert} & -\cross{GPOLSET}{copy} \\ -\cross{GPOLSET}{count} & -\cross{GPOLSET}{empty} \\ -\cross{GPOLSET}{empty?} & -\cross{GPOLSET}{eq?} \\ -\cross{GPOLSET}{eval} & -\cross{GPOLSET}{every?} \\ -\cross{GPOLSET}{find} & -\cross{GPOLSET}{hash} \\ -\cross{GPOLSET}{headRemainder} & -\cross{GPOLSET}{latex} \\ -\cross{GPOLSET}{less?} & -\cross{GPOLSET}{mainVariables} \\ -\cross{GPOLSET}{mainVariable?} & -\cross{GPOLSET}{map} \\ -\cross{GPOLSET}{map!} & -\cross{GPOLSET}{member?} \\ -\cross{GPOLSET}{members} & -\cross{GPOLSET}{more?} \\ -\cross{GPOLSET}{mvar} & -\cross{GPOLSET}{parts} \\ -\cross{GPOLSET}{reduce} & -\cross{GPOLSET}{remainder} \\ -\cross{GPOLSET}{remove} & -\cross{GPOLSET}{removeDuplicates} \\ -\cross{GPOLSET}{retract} & -\cross{GPOLSET}{retractIfCan} \\ -\cross{GPOLSET}{rewriteIdealWithHeadRemainder} & -\cross{GPOLSET}{rewriteIdealWithRemainder} \\ -\cross{GPOLSET}{roughBase?} & -\cross{GPOLSET}{roughEqualIdeals?} \\ -\cross{GPOLSET}{roughSubIdeal?} & -\cross{GPOLSET}{roughUnitIdeal?} \\ -\cross{GPOLSET}{sample} & -\cross{GPOLSET}{select} \\ -\cross{GPOLSET}{size?} & -\cross{GPOLSET}{sort} \\ -\cross{GPOLSET}{triangular?} & -\cross{GPOLSET}{trivialIdeal?} \\ -\cross{GPOLSET}{variables} & -\cross{GPOLSET}{\#{}?} \\ -\cross{GPOLSET}{?=?} & -\cross{GPOLSET}{?\~{}=?} +\begin{tabular}{lllll} +\cross{FRMOD}{1} & +\cross{FRMOD}{basis} & +\cross{FRMOD}{coerce} & +\cross{FRMOD}{hash} & +\cross{FRMOD}{latex} \\ +\cross{FRMOD}{module} & +\cross{FRMOD}{norm} & +\cross{FRMOD}{one?} & +\cross{FRMOD}{recip} & +\cross{FRMOD}{sample} \\ +\cross{FRMOD}{?\~{}=?} & +\cross{FRMOD}{?**?} & +\cross{FRMOD}{?\^{}?} & +\cross{FRMOD}{?*?} & +\cross{FRMOD}{?**?} \\ +\cross{FRMOD}{?=?} &&&& \end{tabular} -\begin{chunk}{domain GPOLSET GeneralPolynomialSet} -)abbrev domain GPOLSET GeneralPolynomialSet -++ Author: Marc Moreno Maza -++ Date Created: 04/26/1994 -++ Date Last Updated: 12/15/1998 -++ Description: -++ A domain for polynomial sets. - -GeneralPolynomialSet(R,E,VarSet,P) : Exports == Implementation where +\begin{chunk}{domain FRMOD FramedModule} +)abbrev domain FRMOD FramedModule +++ Author: Manuel Bronstein +++ Date Created: 27 Jan 1989 +++ Date Last Updated: 24 Jul 1990 +++ Description: +++ Module representation of fractional ideals. - R:Ring - VarSet:OrderedSet - E:OrderedAbelianMonoidSup - P:RecursivePolynomialCategory(R,E,VarSet) - LP ==> List P - PtoP ==> P -> P +FramedModule(R, F, UP, A, ibasis): Exports == Implementation where + R : EuclideanDomain + F : QuotientFieldCategory R + UP : UnivariatePolynomialCategory F + A : FramedAlgebra(F, UP) + ibasis: Vector A - Exports == PolynomialSetCategory(R,E,VarSet,P) with + VR ==> Vector R + VF ==> Vector F + VA ==> Vector A + M ==> Matrix F - convert : LP -> $ - ++ \axiom{convert(lp)} returns the polynomial set whose members - ++ are the polynomials of \axiom{lp}. + Exports ==> Monoid with + basis : % -> VA + ++ basis((f1,...,fn)) = the vector \spad{[f1,...,fn]}. + norm : % -> F + ++ norm(f) returns the norm of the module f. + module: VA -> % + ++ module([f1,...,fn]) = the module generated by \spad{(f1,...,fn)} + ++ over R. + if A has RetractableTo F then + module: FractionalIdeal(R, F, UP, A) -> % + ++ module(I) returns I viewed has a module over R. - finiteAggregate - shallowlyMutable + Implementation ==> add - Implementation == add + import MatrixCommonDenominator(R, F) + import ModularHermitianRowReduction(R) - Rep := List P + Rep := VA - construct lp == - (removeDuplicates(lp)$List(P))::$ + iflag?:Reference(Boolean) := ref true + wflag?:Reference(Boolean) := ref true + imat := new(#ibasis, #ibasis, 0)$M + wmat := new(#ibasis, #ibasis, 0)$M - copy ps == - construct(copy(members(ps)$$)$LP)$$ + rowdiv : (VR, R) -> VF + vectProd : (VA, VA) -> VA + wmatrix : VA -> M + W2A : VF -> A + intmat : () -> M + invintmat : () -> M + getintmat : () -> Boolean + getinvintmat: () -> Boolean - empty() == - [] + 1 == ibasis - parts ps == - ps pretend LP + module(v:VA) == v - map (f : PtoP, ps : $) : $ == - construct(map(f,members(ps))$LP)$$ + basis m == m pretend VA - map! (f : PtoP, ps : $) : $ == - construct(map!(f,members(ps))$LP)$$ + rowdiv(r, f) == [r.i / f for i in minIndex r..maxIndex r] - member? (p,ps) == - member?(p,members(ps))$LP + coerce(m:%):OutputForm == coerce(basis m)$VA - ps1 = ps2 == - {p for p in parts(ps1)} =$(Set P) {p for p in parts(ps2)} + W2A v == represents(v * intmat()) - coerce(ps:$) : OutputForm == - lp : List(P) := sort(infRittWu?,members(ps))$(List P) - brace([p::OutputForm for p in lp]$List(OutputForm))$OutputForm + wmatrix v == coordinates(v) * invintmat() - mvar ps == - empty? ps => error"Error from GPOLSET in mvar : #1 is empty" - lv : List VarSet := variables(ps) - empty? lv => - error "Error from GPOLSET in mvar : every polynomial in #1 is constant" - reduce(max,lv)$(List VarSet) + getinvintmat() == + m := inverse(intmat())::M + for i in minRowIndex m .. maxRowIndex m repeat + for j in minColIndex m .. maxColIndex m repeat + imat(i, j) := qelt(m, i, j) + false - retractIfCan(lp) == - (construct(lp))::Union($,"failed") + getintmat() == + m := coordinates ibasis + for i in minRowIndex m .. maxRowIndex m repeat + for j in minColIndex m .. maxColIndex m repeat + wmat(i, j) := qelt(m, i, j) + false - coerce(ps:$) : (List P) == - ps pretend (List P) + invintmat() == + if iflag?() then iflag?() := getinvintmat() + imat - convert(lp:LP) : $ == - construct lp + intmat() == + if wflag?() then wflag?() := getintmat() + wmat + + vectProd(v1, v2) == + k := minIndex(v := new(#v1 * #v2, 0)$VA) + for i in minIndex v1 .. maxIndex v1 repeat + for j in minIndex v2 .. maxIndex v2 repeat + qsetelt_!(v, k, qelt(v1, i) * qelt(v2, j)) + k := k + 1 + v pretend VA + + norm m == + #(basis m) ^= #ibasis => error "Module not of rank n" + determinant(coordinates(basis m) * invintmat()) + + m1 * m2 == + m := rowEch((cd := splitDenominator wmatrix( + vectProd(basis m1, basis m2))).num) + module [u for i in minRowIndex m .. maxRowIndex m | + (u := W2A rowdiv(row(m, i), cd.den)) ^= 0]$VA + + if A has RetractableTo F then + + module(i:FractionalIdeal(R, F, UP, A)) == + module(basis i) * module(ibasis) \end{chunk} -\begin{chunk}{COQ GPOLSET} -(* domain GPOLSET *) +\begin{chunk}{COQ FRMOD} +(* domain FRMOD *) (* -*) -\end{chunk} + import MatrixCommonDenominator(R, F) + import ModularHermitianRowReduction(R) -\begin{chunk}{GPOLSET.dotabb} -"GPOLSET" [color="#88FF44",href="bookvol10.3.pdf#nameddest=GPOLSET"] -"RPOLCAT" [color="#4488FF",href="bookvol10.2.pdf#nameddest=RPOLCAT"] -"GPOLSET" -> "RPOLCAT" + Rep := VA -\end{chunk} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain GSTBL GeneralSparseTable} + iflag?:Reference(Boolean) := ref true + wflag?:Reference(Boolean) := ref true + imat := new(#ibasis, #ibasis, 0)$M + wmat := new(#ibasis, #ibasis, 0)$M -\begin{chunk}{GeneralSparseTable.input} -)set break resume -)sys rm -f GeneralSparseTable.output -)spool GeneralSparseTable.output -)set message test on -)set message auto off -)set break resume -)clear all + rowdiv : (VR, R) -> VF + vectProd : (VA, VA) -> VA + wmatrix : VA -> M + W2A : VF -> A + intmat : () -> M + invintmat : () -> M + getintmat : () -> Boolean + getinvintmat: () -> Boolean ---S 1 of 8 -patrons: GeneralSparseTable(String, Integer, KeyedAccessFile(Integer), 0) := table() ; ---E 1 + 1 == ibasis ---S 2 of 8 -patrons."Smith" := 10500 ---E 2 + module(v:VA) == v ---S 3 of 8 -patrons."Jones" := 22000 ---E 3 + basis m == m pretend VA ---S 4 of 8 -patrons."Jones" ---E 4 + rowdiv(r, f) == [r.i / f for i in minIndex r..maxIndex r] ---S 5 of 8 -patrons."Stingy" ---E 5 + coerce(m:%):OutputForm == coerce(basis m)$VA ---S 6 of 8 -reduce(+, entries patrons) ---E 6 + W2A v == represents(v * intmat()) ---S 7 of 8 -)system rm -r kaf*.sdata ---E 7 + wmatrix v == coordinates(v) * invintmat() ---S 8 of 8 -)show GeneralSparseTable ---R ---R GeneralSparseTable(Key: SetCategory,Entry: SetCategory,Tbl: TableAggregate(Key,Entry),dent: Entry) is a domain constructor ---R Abbreviation for GeneralSparseTable is GSTBL ---R This constructor is not exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for GSTBL ---R ---R------------------------------- Operations -------------------------------- ---R copy : % -> % dictionary : () -> % ---R elt : (%,Key,Entry) -> Entry ?.? : (%,Key) -> Entry ---R empty : () -> % empty? : % -> Boolean ---R entries : % -> List(Entry) eq? : (%,%) -> Boolean ---R index? : (Key,%) -> Boolean indices : % -> List(Key) ---R key? : (Key,%) -> Boolean keys : % -> List(Key) ---R map : ((Entry -> Entry),%) -> % qelt : (%,Key) -> Entry ---R sample : () -> % setelt : (%,Key,Entry) -> Entry ---R table : () -> % ---R #? : % -> NonNegativeInteger if $ has finiteAggregate ---R ?=? : (%,%) -> Boolean if Record(key: Key,entry: Entry) has SETCAT or Entry has SETCAT ---R any? : ((Entry -> Boolean),%) -> Boolean if $ has finiteAggregate ---R any? : ((Record(key: Key,entry: Entry) -> Boolean),%) -> Boolean if $ has finiteAggregate ---R bag : List(Record(key: Key,entry: Entry)) -> % ---R coerce : % -> OutputForm if Record(key: Key,entry: Entry) has SETCAT or Entry has SETCAT ---R construct : List(Record(key: Key,entry: Entry)) -> % ---R convert : % -> InputForm if Record(key: Key,entry: Entry) has KONVERT(INFORM) ---R count : ((Entry -> Boolean),%) -> NonNegativeInteger if $ has finiteAggregate ---R count : (Entry,%) -> NonNegativeInteger if $ has finiteAggregate and Entry has SETCAT ---R count : (Record(key: Key,entry: Entry),%) -> NonNegativeInteger if $ has finiteAggregate and Record(key: Key,entry: Entry) has SETCAT ---R count : ((Record(key: Key,entry: Entry) -> Boolean),%) -> NonNegativeInteger if $ has finiteAggregate ---R dictionary : List(Record(key: Key,entry: Entry)) -> % ---R entry? : (Entry,%) -> Boolean if $ has finiteAggregate and Entry has SETCAT ---R eval : (%,List(Equation(Entry))) -> % if Entry has EVALAB(Entry) and Entry has SETCAT ---R eval : (%,Equation(Entry)) -> % if Entry has EVALAB(Entry) and Entry has SETCAT ---R eval : (%,Entry,Entry) -> % if Entry has EVALAB(Entry) and Entry has SETCAT ---R eval : (%,List(Entry),List(Entry)) -> % if Entry has EVALAB(Entry) and Entry has SETCAT ---R eval : (%,List(Record(key: Key,entry: Entry)),List(Record(key: Key,entry: Entry))) -> % if Record(key: Key,entry: Entry) has EVALAB(Record(key: Key,entry: Entry)) and Record(key: Key,entry: Entry) has SETCAT ---R eval : (%,Record(key: Key,entry: Entry),Record(key: Key,entry: Entry)) -> % if Record(key: Key,entry: Entry) has EVALAB(Record(key: Key,entry: Entry)) and Record(key: Key,entry: Entry) has SETCAT ---R eval : (%,Equation(Record(key: Key,entry: Entry))) -> % if Record(key: Key,entry: Entry) has EVALAB(Record(key: Key,entry: Entry)) and Record(key: Key,entry: Entry) has SETCAT ---R eval : (%,List(Equation(Record(key: Key,entry: Entry)))) -> % if Record(key: Key,entry: Entry) has EVALAB(Record(key: Key,entry: Entry)) and Record(key: Key,entry: Entry) has SETCAT ---R every? : ((Entry -> Boolean),%) -> Boolean if $ has finiteAggregate ---R every? : ((Record(key: Key,entry: Entry) -> Boolean),%) -> Boolean if $ has finiteAggregate ---R extract! : % -> Record(key: Key,entry: Entry) ---R fill! : (%,Entry) -> % if $ has shallowlyMutable ---R find : ((Record(key: Key,entry: Entry) -> Boolean),%) -> Union(Record(key: Key,entry: Entry),"failed") ---R first : % -> Entry if Key has ORDSET ---R hash : % -> SingleInteger if Record(key: Key,entry: Entry) has SETCAT or Entry has SETCAT ---R insert! : (Record(key: Key,entry: Entry),%) -> % ---R inspect : % -> Record(key: Key,entry: Entry) ---R latex : % -> String if Record(key: Key,entry: Entry) has SETCAT or Entry has SETCAT ---R less? : (%,NonNegativeInteger) -> Boolean ---R map : (((Entry,Entry) -> Entry),%,%) -> % ---R map : ((Record(key: Key,entry: Entry) -> Record(key: Key,entry: Entry)),%) -> % ---R map! : ((Entry -> Entry),%) -> % if $ has shallowlyMutable ---R map! : ((Record(key: Key,entry: Entry) -> Record(key: Key,entry: Entry)),%) -> % if $ has shallowlyMutable ---R maxIndex : % -> Key if Key has ORDSET ---R member? : (Entry,%) -> Boolean if $ has finiteAggregate and Entry has SETCAT ---R member? : (Record(key: Key,entry: Entry),%) -> Boolean if $ has finiteAggregate and Record(key: Key,entry: Entry) has SETCAT ---R members : % -> List(Entry) if $ has finiteAggregate ---R members : % -> List(Record(key: Key,entry: Entry)) if $ has finiteAggregate ---R minIndex : % -> Key if Key has ORDSET ---R more? : (%,NonNegativeInteger) -> Boolean ---R parts : % -> List(Entry) if $ has finiteAggregate ---R parts : % -> List(Record(key: Key,entry: Entry)) if $ has finiteAggregate ---R qsetelt! : (%,Key,Entry) -> Entry if $ has shallowlyMutable ---R reduce : (((Record(key: Key,entry: Entry),Record(key: Key,entry: Entry)) -> Record(key: Key,entry: Entry)),%) -> Record(key: Key,entry: Entry) if $ has finiteAggregate ---R reduce : (((Record(key: Key,entry: Entry),Record(key: Key,entry: Entry)) -> Record(key: Key,entry: Entry)),%,Record(key: Key,entry: Entry)) -> Record(key: Key,entry: Entry) if $ has finiteAggregate ---R reduce : (((Record(key: Key,entry: Entry),Record(key: Key,entry: Entry)) -> Record(key: Key,entry: Entry)),%,Record(key: Key,entry: Entry),Record(key: Key,entry: Entry)) -> Record(key: Key,entry: Entry) if $ has finiteAggregate and Record(key: Key,entry: Entry) has SETCAT ---R remove : ((Record(key: Key,entry: Entry) -> Boolean),%) -> % if $ has finiteAggregate ---R remove : (Record(key: Key,entry: Entry),%) -> % if $ has finiteAggregate and Record(key: Key,entry: Entry) has SETCAT ---R remove! : (Key,%) -> Union(Entry,"failed") ---R remove! : ((Record(key: Key,entry: Entry) -> Boolean),%) -> % if $ has finiteAggregate ---R remove! : (Record(key: Key,entry: Entry),%) -> % if $ has finiteAggregate ---R removeDuplicates : % -> % if $ has finiteAggregate and Record(key: Key,entry: Entry) has SETCAT ---R search : (Key,%) -> Union(Entry,"failed") ---R select : ((Record(key: Key,entry: Entry) -> Boolean),%) -> % if $ has finiteAggregate ---R select! : ((Record(key: Key,entry: Entry) -> Boolean),%) -> % if $ has finiteAggregate ---R size? : (%,NonNegativeInteger) -> Boolean ---R swap! : (%,Key,Key) -> Void if $ has shallowlyMutable ---R table : List(Record(key: Key,entry: Entry)) -> % ---R ?~=? : (%,%) -> Boolean if Record(key: Key,entry: Entry) has SETCAT or Entry has SETCAT ---R ---E 8 + getinvintmat() == + m := inverse(intmat())::M + for i in minRowIndex m .. maxRowIndex m repeat + for j in minColIndex m .. maxColIndex m repeat + imat(i, j) := qelt(m, i, j) + false -)spool -)lisp (bye) -\end{chunk} -\begin{chunk}{GeneralSparseTable.help} -==================================================================== -GeneralSparseTable -==================================================================== + getintmat() == + m := coordinates ibasis + for i in minRowIndex m .. maxRowIndex m repeat + for j in minColIndex m .. maxColIndex m repeat + wmat(i, j) := qelt(m, i, j) + false -Sometimes when working with tables there is a natural value to use as -the entry in all but a few cases. The GeneralSparseTable constructor -can be used to provide any table type with a default value for -entries. + invintmat() == + if iflag?() then iflag?() := getinvintmat() + imat -Suppose we launched a fund-raising campaign to raise fifty thousand -dollars. To record the contributions, we want a table with strings as -keys (for the names) and integer entries (for the amount). In a data -base of cash contributions, unless someone has been explicitly -entered, it is reasonable to assume they have made a zero dollar -contribution. + intmat() == + if wflag?() then wflag?() := getintmat() + wmat -This creates a keyed access file with default entry 0. + vectProd(v1, v2) == + k := minIndex(v := new(#v1 * #v2, 0)$VA) + for i in minIndex v1 .. maxIndex v1 repeat + for j in minIndex v2 .. maxIndex v2 repeat + qsetelt_!(v, k, qelt(v1, i) * qelt(v2, j)) + k := k + 1 + v pretend VA - patrons: GeneralSparseTable(String, Integer, KeyedAccessFile(Integer), 0) := table() ; + norm m == + #(basis m) ^= #ibasis => error "Module not of rank n" + determinant(coordinates(basis m) * invintmat()) -Now patrons can be used just as any other table. Here we record two gifts. + m1 * m2 == + m := rowEch((cd := splitDenominator wmatrix( + vectProd(basis m1, basis m2))).num) + module [u for i in minRowIndex m .. maxRowIndex m | + (u := W2A rowdiv(row(m, i), cd.den)) ^= 0]$VA - patrons."Smith" := 10500 + if A has RetractableTo F then - patrons."Jones" := 22000 + module(i:FractionalIdeal(R, F, UP, A)) == + module(basis i) * module(ibasis) -Now let us look up the size of the contributions from Jones and Stingy. +*) - patrons."Jones" +\end{chunk} - patrons."Stingy" +\begin{chunk}{FRMOD.dotabb} +"FRMOD" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FRMOD"] +"FRAMALG" [color="#4488FF",href="bookvol10.2.pdf#nameddest=FRAMALG"] +"FRMOD" -> "FRAMALG" -Have we met our seventy thousand dollar goal? +\end{chunk} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{domain FAGROUP FreeAbelianGroup} - reduce(+, entries patrons) +\begin{chunk}{FreeAbelianGroup.input} +)set break resume +)sys rm -f FreeAbelianGroup.output +)spool FreeAbelianGroup.output +)set message test on +)set message auto off +)clear all -So the project is cancelled and we can delete the data base: +--S 1 of 1 +)show FreeAbelianGroup +--R +--R FreeAbelianGroup(S: SetCategory) is a domain constructor +--R Abbreviation for FreeAbelianGroup is FAGROUP +--R This constructor is not exposed in this frame. +--R Issue )edit bookvol10.3.pamphlet to see algebra source code for FAGROUP +--R +--R------------------------------- Operations -------------------------------- +--R ?*? : (Integer,S) -> % ?*? : (%,Integer) -> % +--R ?*? : (Integer,%) -> % ?*? : (NonNegativeInteger,%) -> % +--R ?*? : (PositiveInteger,%) -> % ?+? : (S,%) -> % +--R ?+? : (%,%) -> % ?-? : (%,%) -> % +--R -? : % -> % ?=? : (%,%) -> Boolean +--R 0 : () -> % coefficient : (S,%) -> Integer +--R coerce : S -> % coerce : % -> OutputForm +--R hash : % -> SingleInteger latex : % -> String +--R mapGen : ((S -> S),%) -> % max : (%,%) -> % if S has ORDSET +--R min : (%,%) -> % if S has ORDSET nthCoef : (%,Integer) -> Integer +--R nthFactor : (%,Integer) -> S retract : % -> S +--R sample : () -> % size : % -> NonNegativeInteger +--R zero? : % -> Boolean ?~=? : (%,%) -> Boolean +--R ? Boolean if S has ORDSET +--R ?<=? : (%,%) -> Boolean if S has ORDSET +--R ?>? : (%,%) -> Boolean if S has ORDSET +--R ?>=? : (%,%) -> Boolean if S has ORDSET +--R highCommonTerms : (%,%) -> % if Integer has OAMON +--R mapCoef : ((Integer -> Integer),%) -> % +--R retractIfCan : % -> Union(S,"failed") +--R subtractIfCan : (%,%) -> Union(%,"failed") +--R terms : % -> List(Record(gen: S,exp: Integer)) +--R +--E 1 - )system rm -r kaf*.sdata +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{FreeAbelianGroup.help} +==================================================================== +FreeAbelianGroup examples +==================================================================== + +Free abelian group on any set of generators +The free abelian group on a set S is the monoid of finite sums of +the form reduce(+,[ni * si]) where the si's are in S, and the ni's +are integers. The operation is commutative. See Also: -o )show GeneralSparseTable +o )show FreeAbelianGroup \end{chunk} -\pagehead{GeneralSparseTable}{GSTBL} -\pagepic{ps/v103generalsparsetable.ps}{GSTBL}{1.00} + +\pagehead{FreeAbelianGroup}{FAGROUP} +\pagepic{ps/v103freeabeliangroup.ps}{FAGROUP}{1.00} {\bf See}\\ -\pageto{HashTable}{HASHTBL} -\pageto{InnerTable}{INTABL} -\pageto{Table}{TABLE} -\pageto{EqTable}{EQTBL} -\pageto{StringTable}{STRTBL} -\pageto{SparseTable}{STBL} +\pageto{ListMonoidOps}{LMOPS} +\pageto{FreeMonoid}{FMONOID} +\pageto{FreeGroup}{FGROUP} +\pageto{InnerFreeAbelianMonoid}{IFAMON} +\pageto{FreeAbelianMonoid}{FAMONOID} {\bf Exports:}\\ \begin{tabular}{lllll} -\cross{GSTBL}{any?} & -\cross{GSTBL}{bag} & -\cross{GSTBL}{coerce} & -\cross{GSTBL}{construct} & -\cross{GSTBL}{convert} \\ -\cross{GSTBL}{copy} & -\cross{GSTBL}{count} & -\cross{GSTBL}{dictionary} & -\cross{GSTBL}{elt} & -\cross{GSTBL}{empty} \\ -\cross{GSTBL}{empty?} & -\cross{GSTBL}{entries} & -\cross{GSTBL}{entry?} & -\cross{GSTBL}{eq?} & -\cross{GSTBL}{eval} \\ -\cross{GSTBL}{every?} & -\cross{GSTBL}{extract!} & -\cross{GSTBL}{fill!} & -\cross{GSTBL}{find} & -\cross{GSTBL}{first} \\ -\cross{GSTBL}{hash} & -\cross{GSTBL}{index?} & -\cross{GSTBL}{indices} & -\cross{GSTBL}{insert!} & -\cross{GSTBL}{inspect} \\ -\cross{GSTBL}{key?} & -\cross{GSTBL}{keys} & -\cross{GSTBL}{latex} & -\cross{GSTBL}{less?} & -\cross{GSTBL}{map} \\ -\cross{GSTBL}{map!} & -\cross{GSTBL}{maxIndex} & -\cross{GSTBL}{member?} & -\cross{GSTBL}{members} & -\cross{GSTBL}{minIndex} \\ -\cross{GSTBL}{more?} & -\cross{GSTBL}{parts} & -\cross{GSTBL}{qelt} & -\cross{GSTBL}{qsetelt!} & -\cross{GSTBL}{reduce} \\ -\cross{GSTBL}{remove} & -\cross{GSTBL}{remove!} & -\cross{GSTBL}{removeDuplicates} & -\cross{GSTBL}{sample} & -\cross{GSTBL}{search} \\ -\cross{GSTBL}{select} & -\cross{GSTBL}{select!} & -\cross{GSTBL}{setelt} & -\cross{GSTBL}{size?} & -\cross{GSTBL}{swap!} \\ -\cross{GSTBL}{table} & -\cross{GSTBL}{\#{}?} & -\cross{GSTBL}{?=?} & -\cross{GSTBL}{?\~{}=?} & -\cross{GSTBL}{?.?} +\cross{FAGROUP}{0} & +\cross{FAGROUP}{coefficient} & +\cross{FAGROUP}{coerce} & +\cross{FAGROUP}{hash} & +\cross{FAGROUP}{highCommonTerms} \\ +\cross{FAGROUP}{latex} & +\cross{FAGROUP}{mapCoef} & +\cross{FAGROUP}{mapGen} & +\cross{FAGROUP}{max} & +\cross{FAGROUP}{min} \\ +\cross{FAGROUP}{nthCoef} & +\cross{FAGROUP}{nthFactor} & +\cross{FAGROUP}{retract} & +\cross{FAGROUP}{retractIfCan} & +\cross{FAGROUP}{sample} \\ +\cross{FAGROUP}{size} & +\cross{FAGROUP}{subtractIfCan} & +\cross{FAGROUP}{terms} & +\cross{FAGROUP}{zero?} & +\cross{FAGROUP}{?\~{}=?} \\ +\cross{FAGROUP}{?*?} & +\cross{FAGROUP}{?$<$?} & +\cross{FAGROUP}{?$<=$?} & +\cross{FAGROUP}{?$>$?} & +\cross{FAGROUP}{?$>=$?} \\ +\cross{FAGROUP}{?+?} & +\cross{FAGROUP}{?-?} & +\cross{FAGROUP}{-?} & +\cross{FAGROUP}{?=?} & \end{tabular} -\begin{chunk}{domain GSTBL GeneralSparseTable} -)abbrev domain GSTBL GeneralSparseTable -++ Author: Stephen M. Watt -++ Date Created: 1986 -++ Date Last Updated: June 21, 1991 +\begin{chunk}{domain FAGROUP FreeAbelianGroup} +)abbrev domain FAGROUP FreeAbelianGroup +++ Author: Manuel Bronstein +++ Date Created: November 1989 +++ Date Last Updated: 6 June 1991 ++ Description: -++ A sparse table has a default entry, which is returned if no other -++ value has been explicitly stored for a key. +++ Free abelian group on any set of generators +++ The free abelian group on a set S is the monoid of finite sums of +++ the form \spad{reduce(+,[ni * si])} where the si's are in S, and the ni's +++ are integers. The operation is commutative. -GeneralSparseTable(Key, Entry, Tbl, dent): TableAggregate(Key, Entry) == Impl - where - Key, Entry: SetCategory - Tbl: TableAggregate(Key, Entry) - dent: Entry +FreeAbelianGroup(S:SetCategory): Exports == Implementation where + Exports ==> Join(AbelianGroup, Module Integer, + FreeAbelianMonoidCategory(S, Integer)) with + if S has OrderedSet then OrderedSet - Impl ==> Tbl add - Rep := Tbl + Implementation ==> InnerFreeAbelianMonoid(S, Integer, 1) add - elt(t:%, k:Key) == - (u := search(k, t)$Rep) case "failed" => dent - u::Entry + - f == mapCoef("-", f) - setelt(t:%, k:Key, e:Entry) == - e = dent => (remove_!(k, t); e) - setelt(t, k, e)$Rep + if S has OrderedSet then - search(k:Key, t:%) == - (u := search(k, t)$Rep) case "failed" => dent - u + inmax: List Record(gen: S, exp: Integer) -> Record(gen: S, exp:Integer) + + inmax l == + mx := first l + for t in rest l repeat + if mx.gen < t.gen then mx := t + mx + + -- lexicographic order + a < b == + zero? a => + zero? b => false + 0 < (inmax terms b).exp + ta := inmax terms a + zero? b => ta.exp < 0 + tb := inmax terms b + ta.gen < tb.gen => 0 < tb.exp + tb.gen < ta.gen => ta.exp < 0 + ta.exp < tb.exp => true + tb.exp < ta.exp => false + lc := ta.exp * ta.gen + (a - lc) < (b - lc) \end{chunk} -\begin{chunk}{COQ GSTBL} -(* domain GSTBL *) +\begin{chunk}{COQ FAGROUP} +(* domain FAGROUP *) (* + InnerFreeAbelianMonoid(S, Integer, 1) add + + - f == mapCoef("-", f) + + if S has OrderedSet then + + inmax: List Record(gen: S, exp: Integer) -> Record(gen: S, exp:Integer) + + inmax l == + mx := first l + for t in rest l repeat + if mx.gen < t.gen then mx := t + mx + + -- lexicographic order + a < b == + zero? a => + zero? b => false + 0 < (inmax terms b).exp + ta := inmax terms a + zero? b => ta.exp < 0 + tb := inmax terms b + ta.gen < tb.gen => 0 < tb.exp + tb.gen < ta.gen => ta.exp < 0 + ta.exp < tb.exp => true + tb.exp < ta.exp => false + lc := ta.exp * ta.gen + (a - lc) < (b - lc) + *) \end{chunk} -\begin{chunk}{GSTBL.dotabb} -"GSTBL" [color="#88FF44",href="bookvol10.3.pdf#nameddest=GSTBL"] -"TBAGG" [color="#4488FF",href="bookvol10.2.pdf#nameddest=TBAGG"] -"GSTBL" -> "TBAGG" +\begin{chunk}{FAGROUP.dotabb} +"FAGROUP" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FAGROUP"] +"PID" [color="#4488FF",href="bookvol10.2.pdf#nameddest=PID"] +"OAGROUP" [color="#4488FF",href="bookvol10.2.pdf#nameddest=OAGROUP"] +"FAGROUP" -> "PID" +"FAGROUP" -> "OAGROUP" \end{chunk} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain GTSET GeneralTriangularSet} +\section{domain FAMONOID FreeAbelianMonoid} -\begin{chunk}{GeneralTriangularSet.input} +\begin{chunk}{FreeAbelianMonoid.input} )set break resume -)sys rm -f GeneralTriangularSet.output -)spool GeneralTriangularSet.output +)sys rm -f FreeAbelianMonoid.output +)spool FreeAbelianMonoid.output )set message test on )set message auto off )clear all --S 1 of 1 -)show GeneralTriangularSet +)show FreeAbelianMonoid --R ---R GeneralTriangularSet(R: IntegralDomain,E: OrderedAbelianMonoidSup,V: OrderedSet,P: RecursivePolynomialCategory(R,E,V)) is a domain constructor ---R Abbreviation for GeneralTriangularSet is GTSET +--R FreeAbelianMonoid(S: SetCategory) is a domain constructor +--R Abbreviation for FreeAbelianMonoid is FAMONOID --R This constructor is not exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for GTSET +--R Issue )edit bookvol10.3.pamphlet to see algebra source code for FAMONOID --R --R------------------------------- Operations -------------------------------- ---R ?=? : (%,%) -> Boolean algebraic? : (V,%) -> Boolean ---R algebraicVariables : % -> List(V) coerce : % -> List(P) ---R coerce : % -> OutputForm collect : (%,V) -> % ---R collectQuasiMonic : % -> % collectUnder : (%,V) -> % ---R collectUpper : (%,V) -> % construct : List(P) -> % ---R copy : % -> % degree : % -> NonNegativeInteger ---R empty : () -> % empty? : % -> Boolean ---R eq? : (%,%) -> Boolean extend : (%,P) -> % ---R first : % -> Union(P,"failed") hash : % -> SingleInteger ---R headReduce : (P,%) -> P headReduced? : % -> Boolean ---R headReduced? : (P,%) -> Boolean infRittWu? : (%,%) -> Boolean ---R initiallyReduce : (P,%) -> P initiallyReduced? : % -> Boolean ---R initials : % -> List(P) last : % -> Union(P,"failed") ---R latex : % -> String mainVariable? : (V,%) -> Boolean ---R mainVariables : % -> List(V) map : ((P -> P),%) -> % ---R mvar : % -> V normalized? : % -> Boolean ---R normalized? : (P,%) -> Boolean reduceByQuasiMonic : (P,%) -> P ---R removeZero : (P,%) -> P rest : % -> Union(%,"failed") ---R retract : List(P) -> % sample : () -> % ---R select : (%,V) -> Union(P,"failed") stronglyReduce : (P,%) -> P ---R stronglyReduced? : % -> Boolean stronglyReduced? : (P,%) -> Boolean ---R trivialIdeal? : % -> Boolean variables : % -> List(V) ---R zeroSetSplit : List(P) -> List(%) ?~=? : (%,%) -> Boolean ---R #? : % -> NonNegativeInteger if $ has finiteAggregate ---R any? : ((P -> Boolean),%) -> Boolean if $ has finiteAggregate ---R autoReduced? : (%,((P,List(P)) -> Boolean)) -> Boolean ---R basicSet : (List(P),(P -> Boolean),((P,P) -> Boolean)) -> Union(Record(bas: %,top: List(P)),"failed") ---R basicSet : (List(P),((P,P) -> Boolean)) -> Union(Record(bas: %,top: List(P)),"failed") ---R coHeight : % -> NonNegativeInteger if V has FINITE ---R convert : % -> InputForm if P has KONVERT(INFORM) ---R count : ((P -> Boolean),%) -> NonNegativeInteger if $ has finiteAggregate ---R count : (P,%) -> NonNegativeInteger if $ has finiteAggregate and P has SETCAT ---R eval : (%,List(Equation(P))) -> % if P has EVALAB(P) and P has SETCAT ---R eval : (%,Equation(P)) -> % if P has EVALAB(P) and P has SETCAT ---R eval : (%,P,P) -> % if P has EVALAB(P) and P has SETCAT ---R eval : (%,List(P),List(P)) -> % if P has EVALAB(P) and P has SETCAT ---R every? : ((P -> Boolean),%) -> Boolean if $ has finiteAggregate ---R extendIfCan : (%,P) -> Union(%,"failed") ---R find : ((P -> Boolean),%) -> Union(P,"failed") ---R headRemainder : (P,%) -> Record(num: P,den: R) if R has INTDOM ---R initiallyReduced? : (P,%) -> Boolean ---R less? : (%,NonNegativeInteger) -> Boolean ---R map! : ((P -> P),%) -> % if $ has shallowlyMutable ---R member? : (P,%) -> Boolean if $ has finiteAggregate and P has SETCAT ---R members : % -> List(P) if $ has finiteAggregate ---R more? : (%,NonNegativeInteger) -> Boolean ---R parts : % -> List(P) if $ has finiteAggregate ---R quasiComponent : % -> Record(close: List(P),open: List(P)) ---R reduce : (P,%,((P,P) -> P),((P,P) -> Boolean)) -> P ---R reduce : (((P,P) -> P),%) -> P if $ has finiteAggregate ---R reduce : (((P,P) -> P),%,P) -> P if $ has finiteAggregate ---R reduce : (((P,P) -> P),%,P,P) -> P if $ has finiteAggregate and P has SETCAT ---R reduced? : (P,%,((P,P) -> Boolean)) -> Boolean ---R remainder : (P,%) -> Record(rnum: R,polnum: P,den: R) if R has INTDOM ---R remove : ((P -> Boolean),%) -> % if $ has finiteAggregate ---R remove : (P,%) -> % if $ has finiteAggregate and P has SETCAT ---R removeDuplicates : % -> % if $ has finiteAggregate and P has SETCAT ---R retractIfCan : List(P) -> Union(%,"failed") ---R rewriteIdealWithHeadRemainder : (List(P),%) -> List(P) if R has INTDOM ---R rewriteIdealWithRemainder : (List(P),%) -> List(P) if R has INTDOM ---R rewriteSetWithReduction : (List(P),%,((P,P) -> P),((P,P) -> Boolean)) -> List(P) ---R roughBase? : % -> Boolean if R has INTDOM ---R roughEqualIdeals? : (%,%) -> Boolean if R has INTDOM ---R roughSubIdeal? : (%,%) -> Boolean if R has INTDOM ---R roughUnitIdeal? : % -> Boolean if R has INTDOM ---R select : ((P -> Boolean),%) -> % if $ has finiteAggregate ---R size? : (%,NonNegativeInteger) -> Boolean ---R sort : (%,V) -> Record(under: %,floor: %,upper: %) ---R triangular? : % -> Boolean if R has INTDOM ---R zeroSetSplitIntoTriangularSystems : List(P) -> List(Record(close: %,open: List(P))) +--R ?*? : (NonNegativeInteger,S) -> % ?*? : (NonNegativeInteger,%) -> % +--R ?*? : (PositiveInteger,%) -> % ?+? : (S,%) -> % +--R ?+? : (%,%) -> % ?=? : (%,%) -> Boolean +--R 0 : () -> % coerce : S -> % +--R coerce : % -> OutputForm hash : % -> SingleInteger +--R latex : % -> String mapGen : ((S -> S),%) -> % +--R nthFactor : (%,Integer) -> S retract : % -> S +--R sample : () -> % size : % -> NonNegativeInteger +--R zero? : % -> Boolean ?~=? : (%,%) -> Boolean +--R coefficient : (S,%) -> NonNegativeInteger +--R highCommonTerms : (%,%) -> % if NonNegativeInteger has OAMON +--R mapCoef : ((NonNegativeInteger -> NonNegativeInteger),%) -> % +--R nthCoef : (%,Integer) -> NonNegativeInteger +--R retractIfCan : % -> Union(S,"failed") +--R subtractIfCan : (%,%) -> Union(%,"failed") +--R terms : % -> List(Record(gen: S,exp: NonNegativeInteger)) --R --E 1 )spool )lisp (bye) \end{chunk} -\begin{chunk}{GeneralTriangularSet.help} +\begin{chunk}{FreeAbelianMonoid.help} ==================================================================== -GeneralTriangularSet examples +FreeAbelianMonoid examples ==================================================================== -A domain constructor of the category TriangularSetCategory. The only -requirement for a list of polynomials to be a member of such a domain -is the following: no polynomial is constant and two distinct -polynomials have distinct main variables. Such a triangular set may -not be auto-reduced or consistent. Triangular sets are stored as -sorted lists w.r.t. the main variables of their members but they are -displayed in reverse order. +Free abelian monoid on any set of generators +The free abelian monoid on a set S is the monoid of finite sums of +the form reduce(+,[ni * si]) where the si's are in S, and the ni's +are non-negative integers. The operation is commutative. See Also: -o )show GeneralTriangularSet +o )show FreeAbelianMonoid \end{chunk} -\pagehead{GeneralTriangularSet}{GTSET} -\pagepic{ps/v103generaltriangularset.ps}{GTSET}{1.00} +\pagehead{FreeAbelianMonoid}{FAMONOID} +\pagepic{ps/v103freeabelianmonoid.ps}{FAMONOID}{1.00} {\bf See}\\ -\pageto{WuWenTsunTriangularSet}{WUTSET} +\pageto{ListMonoidOps}{LMOPS} +\pageto{FreeMonoid}{FMONOID} +\pageto{FreeGroup}{FGROUP} +\pageto{InnerFreeAbelianMonoid}{IFAMON} +\pageto{FreeAbelianGroup}{FAGROUP} {\bf Exports:}\\ -\begin{tabular}{ll} -\cross{GTSET}{algebraic?} & -\cross{GTSET}{algebraicVariables} \\ -\cross{GTSET}{any?} & -\cross{GTSET}{autoReduced?} \\ -\cross{GTSET}{basicSet} & -\cross{GTSET}{coerce} \\ -\cross{GTSET}{collect} & -\cross{GTSET}{collectQuasiMonic} \\ -\cross{GTSET}{collectUnder} & -\cross{GTSET}{collectUpper} \\ -\cross{GTSET}{coHeight} & -\cross{GTSET}{construct} \\ -\cross{GTSET}{convert} & -\cross{GTSET}{copy} \\ -\cross{GTSET}{count} & -\cross{GTSET}{degree} \\ -\cross{GTSET}{empty} & -\cross{GTSET}{empty?} \\ -\cross{GTSET}{eq?} & -\cross{GTSET}{eval} \\ -\cross{GTSET}{every?} & -\cross{GTSET}{extend} \\ -\cross{GTSET}{extendIfCan} & -\cross{GTSET}{find} \\ -\cross{GTSET}{first} & -\cross{GTSET}{hash} \\ -\cross{GTSET}{headReduce} & -\cross{GTSET}{headReduced?} \\ -\cross{GTSET}{headReduced?} & -\cross{GTSET}{headRemainder} \\ -\cross{GTSET}{infRittWu?} & -\cross{GTSET}{initiallyReduce} \\ -\cross{GTSET}{initiallyReduced?} & -\cross{GTSET}{initials} \\ -\cross{GTSET}{last} & -\cross{GTSET}{latex} \\ -\cross{GTSET}{less?} & -\cross{GTSET}{mainVariable?} \\ -\cross{GTSET}{mainVariables} & -\cross{GTSET}{map} \\ -\cross{GTSET}{map!} & -\cross{GTSET}{member?} \\ -\cross{GTSET}{members} & -\cross{GTSET}{more?} \\ -\cross{GTSET}{mvar} & -\cross{GTSET}{normalized?} \\ -\cross{GTSET}{normalized?} & -\cross{GTSET}{parts} \\ -\cross{GTSET}{quasiComponent} & -\cross{GTSET}{reduce} \\ -\cross{GTSET}{reduceByQuasiMonic} & -\cross{GTSET}{reduced?} \\ -\cross{GTSET}{remainder} & -\cross{GTSET}{remove} \\ -\cross{GTSET}{removeDuplicates} & -\cross{GTSET}{removeZero} \\ -\cross{GTSET}{rest} & -\cross{GTSET}{retract} \\ -\cross{GTSET}{retractIfCan} & -\cross{GTSET}{rewriteIdealWithHeadRemainder} \\ -\cross{GTSET}{rewriteIdealWithRemainder} & -\cross{GTSET}{rewriteSetWithReduction} \\ -\cross{GTSET}{roughBase?} & -\cross{GTSET}{roughEqualIdeals?} \\ -\cross{GTSET}{roughSubIdeal?} & -\cross{GTSET}{roughUnitIdeal?} \\ -\cross{GTSET}{sample} & -\cross{GTSET}{select} \\ -\cross{GTSET}{size?} & -\cross{GTSET}{sort} \\ -\cross{GTSET}{stronglyReduce} & -\cross{GTSET}{stronglyReduced?} \\ -\cross{GTSET}{triangular?} & -\cross{GTSET}{trivialIdeal?} \\ -\cross{GTSET}{variables} & -\cross{GTSET}{zeroSetSplit} \\ -\cross{GTSET}{zeroSetSplitIntoTriangularSystems} & -\cross{GTSET}{\#{}?} \\ -\cross{GTSET}{?=?} & -\cross{GTSET}{?\~{}=?} +\begin{tabular}{lllll} +\cross{FAMONOID}{0} & +\cross{FAMONOID}{coefficient} & +\cross{FAMONOID}{coerce} & +\cross{FAMONOID}{hash} & +\cross{FAMONOID}{highCommonTerms} \\ +\cross{FAMONOID}{latex} & +\cross{FAMONOID}{mapCoef} & +\cross{FAMONOID}{mapGen} & +\cross{FAMONOID}{nthCoef} & +\cross{FAMONOID}{nthFactor} \\ +\cross{FAMONOID}{retract} & +\cross{FAMONOID}{retractIfCan} & +\cross{FAMONOID}{sample} & +\cross{FAMONOID}{size} & +\cross{FAMONOID}{subtractIfCan} \\ +\cross{FAMONOID}{terms} & +\cross{FAMONOID}{zero?} & +\cross{FAMONOID}{?\~{}=?} & +\cross{FAMONOID}{?*?} & +\cross{FAMONOID}{?+?} \\ +\cross{FAMONOID}{?=?} &&&& \end{tabular} -\begin{chunk}{domain GTSET GeneralTriangularSet} -)abbrev domain GTSET GeneralTriangularSet -++ Author: Marc Moreno Maza (marc@nag.co.uk) -++ Date Created: 10/06/1995 -++ Date Last Updated: 06/12/1996 -++ References : -++ [1] P. AUBRY, D. LAZARD and M. MORENO MAZA "On the Theories -++ of Triangular Sets" Journal of Symbol. Comp. (to appear) -++ Description: -++ A domain constructor of the category \axiomType{TriangularSetCategory}. -++ The only requirement for a list of polynomials to be a member of such -++ a domain is the following: no polynomial is constant and two distinct -++ polynomials have distinct main variables. Such a triangular set may -++ not be auto-reduced or consistent. Triangular sets are stored -++ as sorted lists w.r.t. the main variables of their members but they -++ are displayed in reverse order. - -GeneralTriangularSet(R,E,V,P) : Exports == Implementation where - - R : IntegralDomain - E : OrderedAbelianMonoidSup - V : OrderedSet - P : RecursivePolynomialCategory(R,E,V) - N ==> NonNegativeInteger - Z ==> Integer - B ==> Boolean - LP ==> List P - PtoP ==> P -> P - - Exports == TriangularSetCategory(R,E,V,P) - - Implementation == add - - Rep ==> LP - - rep(s:$):Rep == s pretend Rep - per(l:Rep):$ == l pretend $ - - copy ts == - per(copy(rep(ts))$LP) - empty() == - per([]) - empty?(ts:$) == - empty?(rep(ts)) - parts ts == - rep(ts) - members ts == - rep(ts) - map (f : PtoP, ts : $) : $ == - construct(map(f,rep(ts))$LP)$$ - map! (f : PtoP, ts : $) : $ == - construct(map!(f,rep(ts))$LP)$$ - member? (p,ts) == - member?(p,rep(ts))$LP - - unitIdealIfCan() == - "failed"::Union($,"failed") - roughUnitIdeal? ts == - false - - -- the following assume that rep(ts) is decreasingly sorted - -- w.r.t. the main variavles of the polynomials in rep(ts) - coerce(ts:$) : OutputForm == - lp : List(P) := reverse(rep(ts)) - brace([p::OutputForm for p in lp]$List(OutputForm))$OutputForm - mvar ts == - empty? ts => error"failed in mvar : $ -> V from GTSET" - mvar(first(rep(ts)))$P - first ts == - empty? ts => "failed"::Union(P,"failed") - first(rep(ts))::Union(P,"failed") - last ts == - empty? ts => "failed"::Union(P,"failed") - last(rep(ts))::Union(P,"failed") - rest ts == - empty? ts => "failed"::Union($,"failed") - per(rest(rep(ts)))::Union($,"failed") - coerce(ts:$) : (List P) == - rep(ts) - collectUpper (ts,v) == - empty? ts => ts - lp := rep(ts) - newlp : Rep := [] - while (not empty? lp) and (mvar(first(lp)) > v) repeat - newlp := cons(first(lp),newlp) - lp := rest lp - per(reverse(newlp)) - collectUnder (ts,v) == - empty? ts => ts - lp := rep(ts) - while (not empty? lp) and (mvar(first(lp)) >= v) repeat - lp := rest lp - per(lp) +\begin{chunk}{domain FAMONOID FreeAbelianMonoid} +)abbrev domain FAMONOID FreeAbelianMonoid +++ Author: Manuel Bronstein +++ Date Created: November 1989 +++ Date Last Updated: 6 June 1991 +++ Description: +++ Free abelian monoid on any set of generators +++ The free abelian monoid on a set S is the monoid of finite sums of +++ the form \spad{reduce(+,[ni * si])} where the si's are in S, and the ni's +++ are non-negative integers. The operation is commutative. - -- for another domain of TSETCAT build on this domain GTSET - -- the following operations must be redefined - extendIfCan(ts:$,p:P) == - ground? p => "failed"::Union($,"failed") - empty? ts => (per([unitCanonical(p)]$LP))::Union($,"failed") - not (mvar(ts) < mvar(p)) => "failed"::Union($,"failed") - (per(cons(p,rep(ts))))::Union($,"failed") +FreeAbelianMonoid(S: SetCategory): + FreeAbelianMonoidCategory(S, NonNegativeInteger) + == InnerFreeAbelianMonoid(S, NonNegativeInteger, 1) \end{chunk} -\begin{chunk}{COQ GTSET} -(* domain GTSET *) +\begin{chunk}{COQ FAMONOID} +(* domain FAMONOID *) (* *) \end{chunk} -\begin{chunk}{GTSET.dotabb} -"GTSET" [color="#88FF44",href="bookvol10.3.pdf#nameddest=GTSET"] -"RPOLCAT" [color="#4488FF",href="bookvol10.2.pdf#nameddest=RPOLCAT"] -"GTSET" -> "RPOLCAT" +\begin{chunk}{FAMONOID.dotabb} +"FAMONOID" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FAMONOID"] +"OAMONS" [color="#4488FF",href="bookvol10.2.pdf#nameddest=OAMONS"] +"FAMONOID" -> "OAMONS" \end{chunk} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain GSERIES GeneralUnivariatePowerSeries} +\section{domain FGROUP FreeGroup} -\begin{chunk}{GeneralUnivariatePowerSeries.input} +\begin{chunk}{FreeGroup.input} )set break resume -)sys rm -f GeneralUnivariatePowerSeries.output -)spool GeneralUnivariatePowerSeries.output +)sys rm -f FreeGroup.output +)spool FreeGroup.output )set message test on )set message auto off )clear all --S 1 of 1 -)show GeneralUnivariatePowerSeries +)show FreeGroup --R ---R GeneralUnivariatePowerSeries(Coef: Ring,var: Symbol,cen: Coef) is a domain constructor ---R Abbreviation for GeneralUnivariatePowerSeries is GSERIES ---R This constructor is exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for GSERIES +--R FreeGroup(S: SetCategory) is a domain constructor +--R Abbreviation for FreeGroup is FGROUP +--R This constructor is not exposed in this frame. +--R Issue )edit bookvol10.3.pamphlet to see algebra source code for FGROUP --R --R------------------------------- Operations -------------------------------- ---R ?*? : (Coef,%) -> % ?*? : (%,Coef) -> % ---R ?*? : (%,%) -> % ?*? : (Integer,%) -> % ---R ?*? : (NonNegativeInteger,%) -> % ?*? : (PositiveInteger,%) -> % ---R ?**? : (%,NonNegativeInteger) -> % ?**? : (%,PositiveInteger) -> % ---R ?+? : (%,%) -> % ?-? : (%,%) -> % ---R -? : % -> % ?=? : (%,%) -> Boolean ---R 1 : () -> % 0 : () -> % ---R ?^? : (%,NonNegativeInteger) -> % ?^? : (%,PositiveInteger) -> % ---R center : % -> Coef coerce : % -> % if Coef has INTDOM ---R coerce : Variable(var) -> % coerce : Integer -> % ---R coerce : % -> OutputForm complete : % -> % ---R degree : % -> Fraction(Integer) ?.? : (%,Fraction(Integer)) -> Coef ---R hash : % -> SingleInteger inv : % -> % if Coef has FIELD ---R latex : % -> String leadingCoefficient : % -> Coef ---R leadingMonomial : % -> % map : ((Coef -> Coef),%) -> % ---R monomial? : % -> Boolean one? : % -> Boolean ---R order : % -> Fraction(Integer) pole? : % -> Boolean ---R recip : % -> Union(%,"failed") reductum : % -> % ---R sample : () -> % variable : % -> Symbol ---R zero? : % -> Boolean ?~=? : (%,%) -> Boolean ---R ?*? : (%,Fraction(Integer)) -> % if Coef has ALGEBRA(FRAC(INT)) ---R ?*? : (Fraction(Integer),%) -> % if Coef has ALGEBRA(FRAC(INT)) ---R ?**? : (%,Fraction(Integer)) -> % if Coef has ALGEBRA(FRAC(INT)) ---R ?**? : (%,%) -> % if Coef has ALGEBRA(FRAC(INT)) ---R ?**? : (%,Integer) -> % if Coef has FIELD ---R ?/? : (%,%) -> % if Coef has FIELD ---R ?/? : (%,Coef) -> % if Coef has FIELD ---R D : % -> % if Coef has *: (Fraction(Integer),Coef) -> Coef ---R D : (%,NonNegativeInteger) -> % if Coef has *: (Fraction(Integer),Coef) -> Coef ---R D : (%,Symbol) -> % if Coef has *: (Fraction(Integer),Coef) -> Coef and Coef has PDRING(SYMBOL) ---R D : (%,List(Symbol)) -> % if Coef has *: (Fraction(Integer),Coef) -> Coef and Coef has PDRING(SYMBOL) ---R D : (%,Symbol,NonNegativeInteger) -> % if Coef has *: (Fraction(Integer),Coef) -> Coef and Coef has PDRING(SYMBOL) ---R D : (%,List(Symbol),List(NonNegativeInteger)) -> % if Coef has *: (Fraction(Integer),Coef) -> Coef and Coef has PDRING(SYMBOL) ---R ?^? : (%,Integer) -> % if Coef has FIELD ---R acos : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R acosh : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R acot : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R acoth : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R acsc : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R acsch : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R approximate : (%,Fraction(Integer)) -> Coef if Coef has **: (Coef,Fraction(Integer)) -> Coef and Coef has coerce: Symbol -> Coef ---R asec : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R asech : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R asin : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R asinh : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R associates? : (%,%) -> Boolean if Coef has INTDOM ---R atan : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R atanh : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R characteristic : () -> NonNegativeInteger ---R charthRoot : % -> Union(%,"failed") if Coef has CHARNZ ---R coefficient : (%,Fraction(Integer)) -> Coef ---R coerce : Fraction(Integer) -> % if Coef has ALGEBRA(FRAC(INT)) ---R coerce : UnivariatePuiseuxSeries(Coef,var,cen) -> % ---R coerce : Coef -> % if Coef has COMRING ---R cos : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R cosh : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R cot : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R coth : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R csc : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R csch : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R differentiate : (%,Variable(var)) -> % ---R differentiate : % -> % if Coef has *: (Fraction(Integer),Coef) -> Coef ---R differentiate : (%,NonNegativeInteger) -> % if Coef has *: (Fraction(Integer),Coef) -> Coef ---R differentiate : (%,Symbol) -> % if Coef has *: (Fraction(Integer),Coef) -> Coef and Coef has PDRING(SYMBOL) ---R differentiate : (%,List(Symbol)) -> % if Coef has *: (Fraction(Integer),Coef) -> Coef and Coef has PDRING(SYMBOL) ---R differentiate : (%,Symbol,NonNegativeInteger) -> % if Coef has *: (Fraction(Integer),Coef) -> Coef and Coef has PDRING(SYMBOL) ---R differentiate : (%,List(Symbol),List(NonNegativeInteger)) -> % if Coef has *: (Fraction(Integer),Coef) -> Coef and Coef has PDRING(SYMBOL) ---R divide : (%,%) -> Record(quotient: %,remainder: %) if Coef has FIELD ---R ?.? : (%,%) -> % if Fraction(Integer) has SGROUP ---R euclideanSize : % -> NonNegativeInteger if Coef has FIELD ---R eval : (%,Coef) -> Stream(Coef) if Coef has **: (Coef,Fraction(Integer)) -> Coef ---R exp : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R expressIdealMember : (List(%),%) -> Union(List(%),"failed") if Coef has FIELD ---R exquo : (%,%) -> Union(%,"failed") if Coef has INTDOM ---R extend : (%,Fraction(Integer)) -> % ---R extendedEuclidean : (%,%) -> Record(coef1: %,coef2: %,generator: %) if Coef has FIELD ---R extendedEuclidean : (%,%,%) -> Union(Record(coef1: %,coef2: %),"failed") if Coef has FIELD ---R factor : % -> Factored(%) if Coef has FIELD ---R gcd : (%,%) -> % if Coef has FIELD ---R gcd : List(%) -> % if Coef has FIELD ---R gcdPolynomial : (SparseUnivariatePolynomial(%),SparseUnivariatePolynomial(%)) -> SparseUnivariatePolynomial(%) if Coef has FIELD ---R integrate : (%,Variable(var)) -> % if Coef has ALGEBRA(FRAC(INT)) ---R integrate : (%,Symbol) -> % if Coef has integrate: (Coef,Symbol) -> Coef and Coef has variables: Coef -> List(Symbol) and Coef has ALGEBRA(FRAC(INT)) or Coef has ACFS(INT) and Coef has ALGEBRA(FRAC(INT)) and Coef has PRIMCAT and Coef has TRANFUN ---R integrate : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R lcm : (%,%) -> % if Coef has FIELD ---R lcm : List(%) -> % if Coef has FIELD ---R lcmCoef : (%,%) -> Record(llcmres: %,coeff1: %,coeff2: %) if Coef has FIELD ---R log : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R monomial : (%,List(SingletonAsOrderedSet),List(Fraction(Integer))) -> % ---R monomial : (%,SingletonAsOrderedSet,Fraction(Integer)) -> % ---R monomial : (Coef,Fraction(Integer)) -> % ---R multiEuclidean : (List(%),%) -> Union(List(%),"failed") if Coef has FIELD ---R multiplyExponents : (%,Fraction(Integer)) -> % ---R multiplyExponents : (%,PositiveInteger) -> % ---R nthRoot : (%,Integer) -> % if Coef has ALGEBRA(FRAC(INT)) ---R order : (%,Fraction(Integer)) -> Fraction(Integer) ---R pi : () -> % if Coef has ALGEBRA(FRAC(INT)) ---R prime? : % -> Boolean if Coef has FIELD ---R principalIdeal : List(%) -> Record(coef: List(%),generator: %) if Coef has FIELD ---R ?quo? : (%,%) -> % if Coef has FIELD ---R ?rem? : (%,%) -> % if Coef has FIELD ---R sec : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R sech : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R series : (NonNegativeInteger,Stream(Record(k: Fraction(Integer),c: Coef))) -> % ---R sin : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R sinh : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R sizeLess? : (%,%) -> Boolean if Coef has FIELD ---R sqrt : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R squareFree : % -> Factored(%) if Coef has FIELD ---R squareFreePart : % -> % if Coef has FIELD ---R subtractIfCan : (%,%) -> Union(%,"failed") ---R tan : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R tanh : % -> % if Coef has ALGEBRA(FRAC(INT)) ---R terms : % -> Stream(Record(k: Fraction(Integer),c: Coef)) ---R truncate : (%,Fraction(Integer),Fraction(Integer)) -> % ---R truncate : (%,Fraction(Integer)) -> % ---R unit? : % -> Boolean if Coef has INTDOM ---R unitCanonical : % -> % if Coef has INTDOM ---R unitNormal : % -> Record(unit: %,canonical: %,associate: %) if Coef has INTDOM ---R variables : % -> List(SingletonAsOrderedSet) +--R ?*? : (%,S) -> % ?*? : (S,%) -> % +--R ?*? : (%,%) -> % ?**? : (S,Integer) -> % +--R ?**? : (%,Integer) -> % ?**? : (%,NonNegativeInteger) -> % +--R ?**? : (%,PositiveInteger) -> % ?/? : (%,%) -> % +--R ?=? : (%,%) -> Boolean 1 : () -> % +--R ?^? : (%,Integer) -> % ?^? : (%,NonNegativeInteger) -> % +--R ?^? : (%,PositiveInteger) -> % coerce : S -> % +--R coerce : % -> OutputForm commutator : (%,%) -> % +--R conjugate : (%,%) -> % hash : % -> SingleInteger +--R inv : % -> % latex : % -> String +--R mapGen : ((S -> S),%) -> % nthExpon : (%,Integer) -> Integer +--R nthFactor : (%,Integer) -> S one? : % -> Boolean +--R recip : % -> Union(%,"failed") retract : % -> S +--R sample : () -> % size : % -> NonNegativeInteger +--R ?~=? : (%,%) -> Boolean +--R factors : % -> List(Record(gen: S,exp: Integer)) +--R mapExpon : ((Integer -> Integer),%) -> % +--R retractIfCan : % -> Union(S,"failed") --R --E 1 )spool )lisp (bye) \end{chunk} -\begin{chunk}{GeneralUnivariatePowerSeries.help} +\begin{chunk}{FreeGroup.help} ==================================================================== -GeneralUnivariatePowerSeries examples +FreeGroup examples ==================================================================== -This is a category of univariate Puiseux series constructed from -univariate Laurent series. A Puiseux series is represented by a pair -[r,f(x)], where r is a positive rational number and f(x) is a Laurent -series. This pair represents the Puiseux series f(x\^r). - -See Also: -o )show GeneralUnivariatePowerSeries +Free group on any set of generators +The free group on a set S is the group of finite products of +the form reduce(*,[si ** ni]) where the si's are in S, and the ni's +are integers. The multiplication is not commutative. + +See Also: +o )show FreeGroup \end{chunk} -\pagehead{GeneralUnivariatePowerSeries}{GSERIES} -\pagepic{ps/v103generalunivariatepowerseries.ps}{GSERIES}{1.00} +\pagehead{FreeGroup}{FGROUP} +\pagepic{ps/v103freegroup.ps}{FGROUP}{1.00} +{\bf See}\\ +\pageto{ListMonoidOps}{LMOPS} +\pageto{FreeMonoid}{FMONOID} +\pageto{InnerFreeAbelianMonoid}{IFAMON} +\pageto{FreeAbelianMonoid}{FAMONOID} +\pageto{FreeAbelianGroup}{FAGROUP} {\bf Exports:}\\ -\begin{tabular}{llll} -\cross{GSERIES}{0} & -\cross{GSERIES}{1} & -\cross{GSERIES}{acos} & -\cross{GSERIES}{acosh} \\ -\cross{GSERIES}{acot} & -\cross{GSERIES}{acoth} & -\cross{GSERIES}{acsc} & -\cross{GSERIES}{acsch} \\ -\cross{GSERIES}{approximate} & -\cross{GSERIES}{asec} & -\cross{GSERIES}{asech} & -\cross{GSERIES}{asin} \\ -\cross{GSERIES}{asinh} & -\cross{GSERIES}{associates?} & -\cross{GSERIES}{atan} & -\cross{GSERIES}{atanh} \\ -\cross{GSERIES}{center} & -\cross{GSERIES}{characteristic} & -\cross{GSERIES}{charthRoot} & -\cross{GSERIES}{coefficient} \\ -\cross{GSERIES}{coerce} & -\cross{GSERIES}{complete} & -\cross{GSERIES}{cos} & -\cross{GSERIES}{cosh} \\ -\cross{GSERIES}{cot} & -\cross{GSERIES}{coth} & -\cross{GSERIES}{csc} & -\cross{GSERIES}{csch} \\ -\cross{GSERIES}{D} & -\cross{GSERIES}{degree} & -\cross{GSERIES}{differentiate} & -\cross{GSERIES}{divide} \\ -\cross{GSERIES}{euclideanSize} & -\cross{GSERIES}{eval} & -\cross{GSERIES}{exp} & -\cross{GSERIES}{expressIdealMember} \\ -\cross{GSERIES}{exquo} & -\cross{GSERIES}{extend} & -\cross{GSERIES}{extendedEuclidean} & -\cross{GSERIES}{factor} \\ -\cross{GSERIES}{gcd} & -\cross{GSERIES}{gcdPolynomial} & -\cross{GSERIES}{hash} & -\cross{GSERIES}{integrate} \\ -\cross{GSERIES}{inv} & -\cross{GSERIES}{latex} & -\cross{GSERIES}{lcm} & -\cross{GSERIES}{leadingCoefficient} \\ -\cross{GSERIES}{leadingMonomial} & -\cross{GSERIES}{log} & -\cross{GSERIES}{map} & -\cross{GSERIES}{monomial} \\ -\cross{GSERIES}{monomial?} & -\cross{GSERIES}{multiEuclidean} & -\cross{GSERIES}{multiplyExponents} & -\cross{GSERIES}{nthRoot} \\ -\cross{GSERIES}{one?} & -\cross{GSERIES}{order} & -\cross{GSERIES}{pi} & -\cross{GSERIES}{pole?} \\ -\cross{GSERIES}{prime?} & -\cross{GSERIES}{principalIdeal} & -\cross{GSERIES}{recip} & -\cross{GSERIES}{reductum} \\ -\cross{GSERIES}{sample} & -\cross{GSERIES}{sec} & -\cross{GSERIES}{sech} & -\cross{GSERIES}{series} \\ -\cross{GSERIES}{sin} & -\cross{GSERIES}{sinh} & -\cross{GSERIES}{sizeLess?} & -\cross{GSERIES}{sqrt} \\ -\cross{GSERIES}{squareFree} & -\cross{GSERIES}{squareFreePart} & -\cross{GSERIES}{subtractIfCan} & -\cross{GSERIES}{tan} \\ -\cross{GSERIES}{tanh} & -\cross{GSERIES}{terms} & -\cross{GSERIES}{truncate} & -\cross{GSERIES}{unit?} \\ -\cross{GSERIES}{unitCanonical} & -\cross{GSERIES}{unitNormal} & -\cross{GSERIES}{variable} & -\cross{GSERIES}{variables} \\ -\cross{GSERIES}{zero?} & -\cross{GSERIES}{?+?} & -\cross{GSERIES}{?-?} & -\cross{GSERIES}{-?} \\ -\cross{GSERIES}{?=?} & -\cross{GSERIES}{?\^{}?} & -\cross{GSERIES}{?\~{}=?} & -\cross{GSERIES}{?*?} \\ -\cross{GSERIES}{?**?} & -\cross{GSERIES}{?/?} & -\cross{GSERIES}{?.?} \\ -\cross{GSERIES}{?quo?} & -\cross{GSERIES}{?rem?} && +\begin{tabular}{lllll} +\cross{FGROUP}{1} & +\cross{FGROUP}{coerce} & +\cross{FGROUP}{commutator} & +\cross{FGROUP}{conjugate} & +\cross{FGROUP}{factors} \\ +\cross{FGROUP}{hash} & +\cross{FGROUP}{inv} & +\cross{FGROUP}{latex} & +\cross{FGROUP}{mapExpon} & +\cross{FGROUP}{mapGen} \\ +\cross{FGROUP}{nthExpon} & +\cross{FGROUP}{nthFactor} & +\cross{FGROUP}{one?} & +\cross{FGROUP}{recip} & +\cross{FGROUP}{retract} \\ +\cross{FGROUP}{retractIfCan} & +\cross{FGROUP}{sample} & +\cross{FGROUP}{size} & +\cross{FGROUP}{?\~{}=?} & +\cross{FGROUP}{?**?} \\ +\cross{FGROUP}{?\^{}?} & +\cross{FGROUP}{?*?} & +\cross{FGROUP}{?/?} & +\cross{FGROUP}{?=?} & \end{tabular} -\begin{chunk}{domain GSERIES GeneralUnivariatePowerSeries} -)abbrev domain GSERIES GeneralUnivariatePowerSeries -++ Author: Clifton J. Williamson -++ Date Created: 22 September 1993 -++ Date Last Updated: 23 September 1993 +\begin{chunk}{domain FGROUP FreeGroup} +)abbrev domain FGROUP FreeGroup +++ Author: Stephen M. Watt +++ Date Last Updated: 6 June 1991 ++ Description: -++ This is a category of univariate Puiseux series constructed -++ from univariate Laurent series. A Puiseux series is represented -++ by a pair \spad{[r,f(x)]}, where r is a positive rational number and -++ \spad{f(x)} is a Laurent series. This pair represents the Puiseux -++ series \spad{f(x\^r)}. +++ Free group on any set of generators +++ The free group on a set S is the group of finite products of +++ the form \spad{reduce(*,[si ** ni])} where the si's are in S, and the ni's +++ are integers. The multiplication is not commutative. -GeneralUnivariatePowerSeries(Coef,var,cen): Exports == Implementation where - Coef : Ring - var : Symbol - cen : Coef - I ==> Integer - UTS ==> UnivariateTaylorSeries - ULS ==> UnivariateLaurentSeries - UPXS ==> UnivariatePuiseuxSeries - EFULS ==> ElementaryFunctionsUnivariateLaurentSeries - EFUPXS ==> ElementaryFunctionsUnivariatePuiseuxSeries - FS2UPS ==> FunctionSpaceToUnivariatePowerSeries +FreeGroup(S: SetCategory): Join(Group, RetractableTo S) with + "*": (S, $) -> $ + ++ s * x returns the product of x by s on the left. + "*": ($, S) -> $ + ++ x * s returns the product of x by s on the right. + "**" : (S, Integer) -> $ + ++ s ** n returns the product of s by itself n times. + size : $ -> NonNegativeInteger + ++ size(x) returns the number of monomials in x. + nthExpon : ($, Integer) -> Integer + ++ nthExpon(x, n) returns the exponent of the n^th monomial of x. + nthFactor : ($, Integer) -> S + ++ nthFactor(x, n) returns the factor of the n^th monomial of x. + mapExpon : (Integer -> Integer, $) -> $ + ++ mapExpon(f, a1\^e1 ... an\^en) returns + ++ \spad{a1\^f(e1) ... an\^f(en)}. + mapGen : (S -> S, $) -> $ + ++ mapGen(f, a1\^e1 ... an\^en) returns + ++ \spad{f(a1)\^e1 ... f(an)\^en}. + factors : $ -> List Record(gen: S, exp: Integer) + ++ factors(a1\^e1,...,an\^en) returns \spad{[[a1, e1],...,[an, en]]}. + == ListMonoidOps(S, Integer, 1) add - Exports ==> UnivariatePuiseuxSeriesCategory Coef with - coerce: Variable(var) -> % - ++ coerce(var) converts the series variable \spad{var} into a - ++ Puiseux series. - coerce: UPXS(Coef,var,cen) -> % - ++ coerce(f) converts a Puiseux series to a general power series. - differentiate: (%,Variable(var)) -> % - ++ \spad{differentiate(f(x),x)} returns the derivative of - ++ \spad{f(x)} with respect to \spad{x}. - if Coef has Algebra Fraction Integer then - integrate: (%,Variable(var)) -> % - ++ \spad{integrate(f(x))} returns an anti-derivative of the power - ++ series \spad{f(x)} with constant coefficient 0. - ++ We may integrate a series when we can divide coefficients - ++ by integers. + Rep := ListMonoidOps(S, Integer, 1) - Implementation ==> UnivariatePuiseuxSeries(Coef,var,cen) add + 1 == makeUnit() - coerce(upxs:UPXS(Coef,var,cen)) == upxs pretend % + one? f == empty? listOfMonoms f - puiseux: % -> UPXS(Coef,var,cen) - puiseux f == f pretend UPXS(Coef,var,cen) + s:S ** n:Integer == makeTerm(s, n) - if Coef has Algebra Fraction Integer then + f:$ * s:S == rightMult(f, s) - differentiate f == - str1 : String := "'differentiate' unavailable on this domain; " - str2 : String := "use 'approximate' first" - error concat(str1,str2) + s:S * f:$ == leftMult(s, f) - differentiate(f:%,v:Variable(var)) == differentiate f + inv f == reverse_! mapExpon("-", f) - if Coef has PartialDifferentialRing(Symbol) then - differentiate(f:%,s:Symbol) == - (s = variable(f)) => - str1 : String := "'differentiate' unavailable on this domain; " - str2 : String := "use 'approximate' first" - error concat(str1,str2) - dcds := differentiate(center f,s) - deriv := differentiate(puiseux f) :: % - map(x+->differentiate(x,s),f) - dcds * deriv + factors f == copy listOfMonoms f - integrate f == - str1 : String := "'integrate' unavailable on this domain; " - str2 : String := "use 'approximate' first" - error concat(str1,str2) + mapExpon(f, x) == mapExpon(f, x)$Rep - integrate(f:%,v:Variable(var)) == integrate f + mapGen(f, x) == mapGen(f, x)$Rep - if Coef has integrate: (Coef,Symbol) -> Coef and _ - Coef has variables: Coef -> List Symbol then + coerce(f:$):OutputForm == outputForm(f, "*", "**", 1) - integrate(f:%,s:Symbol) == - (s = variable(f)) => - str1 : String := "'integrate' unavailable on this domain; " - str2 : String := "use 'approximate' first" - error concat(str1,str2) - not entry?(s,variables center f) => map(x+->integrate(x,s),f) - error "integrate: center is a function of variable of integration" + f:$ * g:$ == + one? f => g + one? g => f + r := reverse listOfMonoms f + q := copy listOfMonoms g + while not empty? r and not empty? q and r.first.gen = q.first.gen + and r.first.exp = -q.first.exp repeat + r := rest r + q := rest q + empty? r => makeMulti q + empty? q => makeMulti reverse_! r + r.first.gen = q.first.gen => + setlast_!(h := reverse_! r, + [q.first.gen, q.first.exp + r.first.exp]) + makeMulti concat_!(h, rest q) + makeMulti concat_!(reverse_! r, q) - if Coef has TranscendentalFunctionCategory and _ - Coef has PrimitiveFunctionCategory and _ - Coef has AlgebraicallyClosedFunctionSpace Integer then +\end{chunk} - integrateWithOneAnswer: (Coef,Symbol) -> Coef - integrateWithOneAnswer(f,s) == - res := integrate(f,s)$FunctionSpaceIntegration(Integer,Coef) - res case Coef => res :: Coef - first(res :: List Coef) +\begin{chunk}{COQ FGROUP} +(* domain FGROUP *) +(* - integrate(f:%,s:Symbol) == - (s = variable(f)) => - str1 : String := "'integrate' unavailable on this domain; " - str2 : String := "use 'approximate' first" - error concat(str1,str2) - not entry?(s,variables center f) => - map(x+->integrateWithOneAnswer(x,s),f) - error "integrate: center is a function of variable of integration" + Rep := ListMonoidOps(S, Integer, 1) -\end{chunk} + 1 == makeUnit() + + one? f == empty? listOfMonoms f + + s:S ** n:Integer == makeTerm(s, n) + + f:$ * s:S == rightMult(f, s) + + s:S * f:$ == leftMult(s, f) + + inv f == reverse_! mapExpon("-", f) + + factors f == copy listOfMonoms f + + mapExpon(f, x) == mapExpon(f, x)$Rep + + mapGen(f, x) == mapGen(f, x)$Rep + + coerce(f:$):OutputForm == outputForm(f, "*", "**", 1) + + f:$ * g:$ == + one? f => g + one? g => f + r := reverse listOfMonoms f + q := copy listOfMonoms g + while not empty? r and not empty? q and r.first.gen = q.first.gen + and r.first.exp = -q.first.exp repeat + r := rest r + q := rest q + empty? r => makeMulti q + empty? q => makeMulti reverse_! r + r.first.gen = q.first.gen => + setlast_!(h := reverse_! r, + [q.first.gen, q.first.exp + r.first.exp]) + makeMulti concat_!(h, rest q) + makeMulti concat_!(reverse_! r, q) -\begin{chunk}{COQ GSERIES} -(* domain GSERIES *) -(* *) \end{chunk} -\begin{chunk}{GSERIES.dotabb} -"GSERIES" [color="#88FF44",href="bookvol10.3.pdf#nameddest=GSERIES"] -"ACFS" [color="#4488FF",href="bookvol10.2.pdf#nameddest=ACFS"] -"GSERIES" -> "ACFS" +\begin{chunk}{FGROUP.dotabb} +"FGROUP" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FGROUP"] +"FLAGG" [color="#4488FF",href="bookvol10.2.pdf#nameddest=FLAGG"] +"FLAGG-" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FLAGG"] +"FGROUP" -> "FLAGG" +"FGROUP" -> "FLAGG-" \end{chunk} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain GRIMAGE GraphImage} +\section{domain FM FreeModule} -\begin{chunk}{GraphImage.input} +\begin{chunk}{FreeModule.input} )set break resume -)sys rm -f GraphImage.output -)spool GraphImage.output +)sys rm -f FreeModule.output +)spool FreeModule.output )set message test on )set message auto off )clear all --S 1 of 1 -)show GraphImage +)show FreeModule --R ---R GraphImage is a domain constructor ---R Abbreviation for GraphImage is GRIMAGE +--R FreeModule(R: Ring,S: OrderedSet) is a domain constructor +--R Abbreviation for FreeModule is FM --R This constructor is not exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for GRIMAGE +--R Issue )edit bookvol10.3.pamphlet to see algebra source code for FM --R --R------------------------------- Operations -------------------------------- ---R ?=? : (%,%) -> Boolean coerce : % -> OutputForm ---R graphImage : () -> % hash : % -> SingleInteger ---R key : % -> Integer latex : % -> String ---R makeGraphImage : % -> % ranges : % -> List(Segment(Float)) ---R units : % -> List(Float) ?~=? : (%,%) -> Boolean ---R appendPoint : (%,Point(DoubleFloat)) -> Void ---R coerce : List(List(Point(DoubleFloat))) -> % ---R component : (%,Point(DoubleFloat),Palette,Palette,PositiveInteger) -> Void ---R component : (%,Point(DoubleFloat)) -> Void ---R component : (%,List(Point(DoubleFloat)),Palette,Palette,PositiveInteger) -> Void ---R figureUnits : List(List(Point(DoubleFloat))) -> List(DoubleFloat) ---R makeGraphImage : (List(List(Point(DoubleFloat))),List(Palette),List(Palette),List(PositiveInteger),List(DrawOption)) -> % ---R makeGraphImage : (List(List(Point(DoubleFloat))),List(Palette),List(Palette),List(PositiveInteger)) -> % ---R makeGraphImage : List(List(Point(DoubleFloat))) -> % ---R point : (%,Point(DoubleFloat),Palette) -> Void ---R pointLists : % -> List(List(Point(DoubleFloat))) ---R putColorInfo : (List(List(Point(DoubleFloat))),List(Palette)) -> List(List(Point(DoubleFloat))) ---R ranges : (%,List(Segment(Float))) -> List(Segment(Float)) ---R units : (%,List(Float)) -> List(Float) +--R ?*? : (%,R) -> % ?*? : (R,%) -> % +--R ?*? : (Integer,%) -> % ?*? : (NonNegativeInteger,%) -> % +--R ?*? : (PositiveInteger,%) -> % ?+? : (%,%) -> % +--R ?-? : (%,%) -> % -? : % -> % +--R ?=? : (%,%) -> Boolean 0 : () -> % +--R coerce : % -> OutputForm hash : % -> SingleInteger +--R latex : % -> String leadingCoefficient : % -> R +--R leadingSupport : % -> S map : ((R -> R),%) -> % +--R monomial : (R,S) -> % reductum : % -> % +--R sample : () -> % zero? : % -> Boolean +--R ?~=? : (%,%) -> Boolean +--R subtractIfCan : (%,%) -> Union(%,"failed") --R --E 1 )spool )lisp (bye) \end{chunk} -\begin{chunk}{GraphImage.help} +\begin{chunk}{FreeModule.help} ==================================================================== -GraphImage examples +FreeModule examples ==================================================================== -TwoDimensionalGraph creates virtual two dimensional graphs -(to be displayed on TwoDimensionalViewports). +A bi-module is a free module over a ring with generators indexed by an +ordered set. Each element can be expressed as a finite linear +combination of generators. Only non-zero terms are stored. See Also: -o )show GraphImage +o )show FreeModule \end{chunk} -\pagehead{GraphImage}{GRIMAGE} -\pagepic{ps/v103graphimage.ps}{GRIMAGE}{1.00} +\pagehead{FreeModule}{FM} +\pagepic{ps/v103freemodule.ps}{FM}{1.00} +{\bf See}\\ +\pageto{PolynomialRing}{PR} +\pageto{SparseUnivariatePolynomial}{SUP} +\pageto{UnivariatePolynomial}{UP} {\bf Exports:}\\ \begin{tabular}{lllll} -\cross{GRIMAGE}{appendPoint} & -\cross{GRIMAGE}{coerce} & -\cross{GRIMAGE}{component} & -\cross{GRIMAGE}{figureUnits} & -\cross{GRIMAGE}{graphImage} \\ -\cross{GRIMAGE}{hash} & -\cross{GRIMAGE}{key} & -\cross{GRIMAGE}{latex} & -\cross{GRIMAGE}{makeGraphImage} & -\cross{GRIMAGE}{point} \\ -\cross{GRIMAGE}{pointLists} & -\cross{GRIMAGE}{putColorInfo} & -\cross{GRIMAGE}{ranges} & -\cross{GRIMAGE}{units} & -\cross{GRIMAGE}{?\~{}=?} \\ -\cross{GRIMAGE}{?=?} &&&& +\cross{FM}{0} & +\cross{FM}{coerce} & +\cross{FM}{hash} & +\cross{FM}{latex} & +\cross{FM}{leadingCoefficient} \\ +\cross{FM}{leadingSupport} & +\cross{FM}{map} & +\cross{FM}{monomial} & +\cross{FM}{reductum} & +\cross{FM}{sample} \\ +\cross{FM}{subtractIfCan} & +\cross{FM}{zero?} & +\cross{FM}{?\~{}=?} & +\cross{FM}{?*?} & +\cross{FM}{?+?} \\ +\cross{FM}{?-?} & +\cross{FM}{-?} & +\cross{FM}{?=?} && \end{tabular} -\begin{chunk}{domain GRIMAGE GraphImage} -)abbrev domain GRIMAGE GraphImage -++ Author: Jim Wen -++ Date Created: 27 April 1989 -++ Date Last Updated: 1995 September 20, Mike Richardson (MGR) +\begin{chunk}{domain FM FreeModule} +)abbrev domain FM FreeModule +++ Author: Dave Barton, James Davenport, Barry Trager ++ Description: -++ TwoDimensionalGraph creates virtual two dimensional graphs -++ (to be displayed on TwoDimensionalViewports). - -GraphImage (): Exports == Implementation where - - VIEW ==> VIEWPORTSERVER$Lisp - sendI ==> SOCK_-SEND_-INT - sendSF ==> SOCK_-SEND_-FLOAT - sendSTR ==> SOCK_-SEND_-STRING - getI ==> SOCK_-GET_-INT - getSF ==> SOCK_-GET_-FLOAT - - typeGRAPH ==> 2 - typeVIEW2D ==> 3 - - makeGRAPH ==> (-1)$SingleInteger - makeVIEW2D ==> (-1)$SingleInteger - - I ==> Integer - PI ==> PositiveInteger - NNI ==> NonNegativeInteger - SF ==> DoubleFloat - F ==> Float - L ==> List - P ==> Point(SF) - V ==> Vector - SEG ==> Segment - RANGESF ==> L SEG SF - RANGEF ==> L SEG F - UNITSF ==> L SF - UNITF ==> L F - PAL ==> Palette - E ==> OutputForm - DROP ==> DrawOption - PP ==> PointPackage(SF) - COORDSYS ==> CoordinateSystems(SF) +++ A bi-module is a free module +++ over a ring with generators indexed by an ordered set. +++ Each element can be expressed as a finite linear combination of +++ generators. Only non-zero terms are stored. - Exports ==> SetCategory with - graphImage : () -> $ - ++ graphImage() returns an empty graph with 0 point lists - ++ of the domain \spadtype{GraphImage}. A graph image contains - ++ the graph data component of a two dimensional viewport. - makeGraphImage : $ -> $ - ++ makeGraphImage(gi) takes the given graph, \spad{gi} of the - ++ domain \spadtype{GraphImage}, and sends it's data to the - ++ viewport manager where it waits to be included in a two-dimensional - ++ viewport window. \spad{gi} cannot be an empty graph, and it's - ++ elements must have been created using the \spadfun{point} or - ++ \spadfun{component} functions, not by a previous - ++ \spadfun{makeGraphImage}. - makeGraphImage : (L L P) -> $ - ++ makeGraphImage(llp) returns a graph of the domain - ++ \spadtype{GraphImage} which is composed of the points and - ++ lines from the list of lists of points, \spad{llp}, with - ++ default point size and default point and line colours. The graph - ++ data is then sent to the viewport manager where it waits to be - ++ included in a two-dimensional viewport window. - makeGraphImage : (L L P,L PAL,L PAL,L PI) -> $ - ++ makeGraphImage(llp,lpal1,lpal2,lp) returns a graph of the - ++ domain \spadtype{GraphImage} which is composed of the points - ++ and lines from the list of lists of points, \spad{llp}, whose - ++ point colors are indicated by the list of palette colors, - ++ \spad{lpal1}, and whose lines are colored according to the list - ++ of palette colors, \spad{lpal2}. The paramater lp is a list of - ++ integers which denote the size of the data points. The graph - ++ data is then sent to the viewport manager where it waits to be - ++ included in a two-dimensional viewport window. - makeGraphImage : (L L P,L PAL,L PAL,L PI,L DROP) -> $ - ++ makeGraphImage(llp,lpal1,lpal2,lp,lopt) returns a graph of - ++ the domain \spadtype{GraphImage} which is composed of the - ++ points and lines from the list of lists of points, \spad{llp}, - ++ whose point colors are indicated by the list of palette colors, - ++ \spad{lpal1}, and whose lines are colored according to the list - ++ of palette colors, \spad{lpal2}. The paramater lp is a list of - ++ integers which denote the size of the data points, and \spad{lopt} - ++ is the list of draw command options. The graph data is then sent - ++ to the viewport manager where it waits to be included in a - ++ two-dimensional viewport window. - pointLists : $ -> L L P - ++ pointLists(gi) returns the list of lists of points which compose - ++ the given graph, \spad{gi}, of the domain \spadtype{GraphImage}. - key : $ -> I - ++ key(gi) returns the process ID of the given graph, \spad{gi}, - ++ of the domain \spadtype{GraphImage}. - ranges : $ -> RANGEF - ++ ranges(gi) returns the list of ranges of the point components from - ++ the indicated graph, \spad{gi}, of the domain \spadtype{GraphImage}. - ranges : ($,RANGEF) -> RANGEF - ++ ranges(gi,lr) modifies the list of ranges for the given graph, - ++ \spad{gi} of the domain \spadtype{GraphImage}, to be that of the - ++ list of range segments, \spad{lr}, and returns the new range list - ++ for \spad{gi}. - units : $ -> UNITF - ++ units(gi) returns the list of unit increments for the x and y - ++ axes of the indicated graph, \spad{gi}, of the domain - ++ \spadtype{GraphImage}. - units : ($,UNITF) -> UNITF - ++ units(gi,lu) modifies the list of unit increments for the x and y - ++ axes of the given graph, \spad{gi} of the domain - ++ \spadtype{GraphImage}, to be that of the list of unit increments, - ++ \spad{lu}, and returns the new list of units for \spad{gi}. - component : ($,L P,PAL,PAL,PI) -> Void - ++ component(gi,lp,pal1,pal2,p) sets the components of the - ++ graph, \spad{gi} of the domain \spadtype{GraphImage}, to the - ++ values given. The point list for \spad{gi} is set to the list - ++ \spad{lp}, the color of the points in \spad{lp} is set to - ++ the palette color \spad{pal1}, the color of the lines which - ++ connect the points \spad{lp} is set to the palette color - ++ \spad{pal2}, and the size of the points in \spad{lp} is given - ++ by the integer p. - component : ($,P) -> Void - ++ component(gi,pt) modifies the graph \spad{gi} of the domain - ++ \spadtype{GraphImage} to contain one point component, \spad{pt} - ++ whose point color, line color and point size are determined by - ++ the default functions \spadfun{pointColorDefault}, - ++ \spadfun{lineColorDefault}, and \spadfun{pointSizeDefault}. - component : ($,P,PAL,PAL,PI) -> Void - ++ component(gi,pt,pal1,pal2,ps) modifies the graph \spad{gi} of - ++ the domain \spadtype{GraphImage} to contain one point component, - ++ \spad{pt} whose point color is set to the palette color \spad{pal1}, - ++ line color is set to the palette color \spad{pal2}, and point - ++ size is set to the positive integer \spad{ps}. - appendPoint : ($,P) -> Void - ++ appendPoint(gi,pt) appends the point \spad{pt} to the end - ++ of the list of points component for the graph, \spad{gi}, which is - ++ of the domain \spadtype{GraphImage}. - point : ($,P,PAL) -> Void - ++ point(gi,pt,pal) modifies the graph \spad{gi} of the domain - ++ \spadtype{GraphImage} to contain one point component, \spad{pt} - ++ whose point color is set to be the palette color \spad{pal}, and - ++ whose line color and point size are determined by the default - ++ functions \spadfun{lineColorDefault} and \spadfun{pointSizeDefault}. - coerce : L L P -> $ - ++ coerce(llp) - ++ component(gi,pt) creates and returns a graph of the domain - ++ \spadtype{GraphImage} which is composed of the list of list - ++ of points given by \spad{llp}, and whose point colors, line colors - ++ and point sizes are determined by the default functions - ++ \spadfun{pointColorDefault}, \spadfun{lineColorDefault}, and - ++ \spadfun{pointSizeDefault}. The graph data is then sent to the - ++ viewport manager where it waits to be included in a two-dimensional - ++ viewport window. - coerce : $ -> E - ++ coerce(gi) returns the indicated graph, \spad{gi}, of domain - ++ \spadtype{GraphImage} as output of the domain \spadtype{OutputForm}. - putColorInfo : (L L P,L PAL) -> L L P - ++ putColorInfo(llp,lpal) takes a list of list of points, \spad{llp}, - ++ and returns the points with their hue and shade components - ++ set according to the list of palette colors, \spad{lpal}. - figureUnits : L L P -> UNITSF +FreeModule(R:Ring,S:OrderedSet): + Join(BiModule(R,R),IndexedDirectProductCategory(R,S)) with + if R has CommutativeRing then Module(R) + == IndexedDirectProductAbelianGroup(R,S) add - Implementation ==> add - import Color() - import Palette() - import ViewDefaultsPackage() - import PlotTools() - import DrawOptionFunctions0 - import P - import PP - import COORDSYS + --representations + Term:= Record(k:S,c:R) + Rep:= List Term - Rep := Record(key: I, rangesField: RANGESF, unitsField: UNITSF, _ - llPoints: L L P, pointColors: L PAL, lineColors: L PAL, pointSizes: L PI, _ - optionsField: L DROP) + --declarations + x,y: % + r: R + n: Integer + f: R -> R + s: S ---%Internal Functions + --define - graph : RANGEF -> $ - scaleStep : SF -> SF - makeGraph : $ -> $ + if R has EntireRing then + r * x == + zero? r => 0 + (r = 1) => x + --map(r*#1,x) + [[u.k,r*u.c] for u in x ] - numberCheck(nums:Point SF):Void == - for i in minIndex(nums)..maxIndex(nums) repeat - COMPLEXP(nums.(i::PositiveInteger))$Lisp => - error "An unexpected complex number was encountered in the calculations." - + else - doOptions(g:Rep):Void == - lr : RANGEF := ranges(g.optionsField,ranges g) - if (#lr > 1$I) then - g.rangesField := [segment(convert(lo(lr.1))@SF,convert(hi(lr.1))@SF)$(Segment(SF)), - segment(convert(lo(lr.2))@SF,convert(hi(lr.2))@SF)$(Segment(SF))] - else - g.rangesField := [] - lu : UNITF := units(g.optionsField,units g) - if (#lu > 1$I) then - g.unitsField := [convert(lu.1)@SF,convert(lu.2)@SF] - else - g.unitsField := [] - -- etc - graphimage specific stuff... + r * x == + zero? r => 0 + (r = 1) => x + --map(r*#1,x) + [[u.k,a] for u in x | (a:=r*u.c) ^= 0$R] - putColorInfo(llp,listOfPalettes) == - llp2 : L L P := [] - for lp in llp for pal in listOfPalettes repeat - lp2 : L P := [] - daHue := (hue(hue pal))::SF - daShade := (shade pal)::SF - for p in lp repeat - if (d := dimension p) < 3 then - p := extend(p,[daHue,daShade]) - else - p.3 := daHue - d < 4 => p := extend(p,[daShade]) - p.4 := daShade - lp2 := cons(p,lp2) - llp2 := cons(reverse_! lp2,llp2) - reverse_! llp2 + if R has EntireRing then - graph demRanges == - null demRanges => [ 0, [], [], [], [], [], [], [] ] - demRangesSF : RANGESF := _ - [ segment(convert(lo demRanges.1)@SF,convert(hi demRanges.1)@SF)$(Segment(SF)), _ - segment(convert(lo demRanges.1)@SF,convert(hi demRanges.1)@SF)$(Segment(SF)) ] - [ 0, demRangesSF, [], [], [], [], [], [] ] + x * r == + zero? r => 0 + (r = 1) => x + --map(r*#1,x) + [[u.k,u.c*r] for u in x ] - scaleStep(range) == -- MGR - - adjust:NNI - tryStep:SF - scaleDown:SF - numerals:String - adjust := 0 - while range < 100.0::SF repeat - adjust := adjust + 1 - range := range * 10.0::SF -- might as well take big steps - tryStep := range/10.0::SF - numerals := string(((retract(ceiling(tryStep)$SF)$SF)@I))$String - scaleDown := (10@I **$I (((#(numerals)@I) - 1$I) pretend PI))::SF - scaleDown*ceiling(tryStep/scaleDown - 0.5::SF)/((10 **$I adjust)::SF) + else - figureUnits(listOfListsOfPoints) == - -- figure out the min/max and divide by 10 for unit markers - xMin := xMax := xCoord first first listOfListsOfPoints - yMin := yMax := yCoord first first listOfListsOfPoints - if xMin ~= xMin then xMin:=max() - if xMax ~= xMax then xMax:=min() - if yMin ~= yMin then yMin:=max() - if yMax ~= yMax then yMax:=min() - for pL in listOfListsOfPoints repeat - for p in pL repeat - if ((px := (xCoord p)) < xMin) then - xMin := px - if px > xMax then - xMax := px - if ((py := (yCoord p)) < yMin) then - yMin := py - if py > yMax then - yMax := py - if xMin = xMax then - xMin := xMin - convert(0.5)$Float - xMax := xMax + convert(0.5)$Float - if yMin = yMax then - yMin := yMin - convert(0.5)$Float - yMax := yMax + convert(0.5)$Float - [scaleStep(xMax-xMin),scaleStep(yMax-yMin)] + x * r == + zero? r => 0 + (r = 1) => x + --map(r*#1,x) + [[u.k,a] for u in x | (a:=u.c*r) ^= 0$R] - plotLists(graf:Rep,listOfListsOfPoints:L L P,listOfPointColors:L PAL,listOfLineColors:L PAL,listOfPointSizes:L PI):$ == - givenLen := #listOfListsOfPoints - -- take out point lists that are actually empty - listOfListsOfPoints := [ l for l in listOfListsOfPoints | ^null l ] - if (null listOfListsOfPoints) then - error "GraphImage was given a list that contained no valid point lists" - if ((len := #listOfListsOfPoints) ^= givenLen) then - sayBrightly([" Warning: Ignoring pointless point list"::E]$List(E))$Lisp - graf.llPoints := listOfListsOfPoints - -- do point colors - if ((givenLen := #listOfPointColors) > len) then - -- pad or discard elements if given list has length different from the point list - graf.pointColors := concat(listOfPointColors, - new((len - givenLen)::NonNegativeInteger + 1, pointColorDefault())) - else graf.pointColors := first(listOfPointColors, len) - -- do line colors - if ((givenLen := #listOfLineColors) > len) then - graf.lineColors := concat(listOfLineColors, - new((len - givenLen)::NonNegativeInteger + 1, lineColorDefault())) - else graf.lineColors := first(listOfLineColors, len) - -- do point sizes - if ((givenLen := #listOfPointSizes) > len) then - graf.pointSizes := concat(listOfPointSizes, - new((len - givenLen)::NonNegativeInteger + 1, pointSizeDefault())) - else graf.pointSizes := first(listOfPointSizes, len) - graf + coerce(x) : OutputForm == + null x => (0$R) :: OutputForm + le : List OutputForm := nil + for rec in reverse x repeat + rec.c = 1 => le := cons(rec.k :: OutputForm, le) + le := cons(rec.c :: OutputForm * rec.k :: OutputForm, le) + reduce("+",le) - makeGraph graf == - doOptions(graf) - (s := #(graf.llPoints)) = 0 => - error "You are trying to make a graph with no points" - key graf ^= 0 => - error "You are trying to draw over an existing graph" - transform := coord(graf.optionsField,cartesian$COORDSYS)$DrawOptionFunctions0 - graf.llPoints:= putColorInfo(graf.llPoints,graf.pointColors) - if null(ranges graf) then -- figure out best ranges for points - graf.rangesField := calcRanges(graf.llPoints) --::V SEG SF - if null(units graf) then -- figure out best ranges for points - graf.unitsField := figureUnits(graf.llPoints) --::V SEG SF - sayBrightly([" Graph data being transmitted to the viewport manager..."::E]$List(E))$Lisp - sendI(VIEW,typeGRAPH)$Lisp - sendI(VIEW,makeGRAPH)$Lisp - tonto := (graf.rangesField)::RANGESF - sendSF(VIEW,lo(first tonto))$Lisp - sendSF(VIEW,hi(first tonto))$Lisp - sendSF(VIEW,lo(second tonto))$Lisp - sendSF(VIEW,hi(second tonto))$Lisp - sendSF(VIEW,first (graf.unitsField))$Lisp - sendSF(VIEW,second (graf.unitsField))$Lisp - sendI(VIEW,s)$Lisp -- how many lists of points are being sent - for aList in graf.llPoints for pColor in graf.pointColors for lColor in graf.lineColors for s in graf.pointSizes repeat - sendI(VIEW,#aList)$Lisp -- how many points in this list - for p in aList repeat - aPoint := transform p - sendSF(VIEW,xCoord aPoint)$Lisp - sendSF(VIEW,yCoord aPoint)$Lisp - sendSF(VIEW,hue(p)$PP)$Lisp -- ?use aPoint as well...? - sendSF(VIEW,shade(p)$PP)$Lisp - hueShade := hue hue pColor + shade pColor * numberOfHues() - sendI(VIEW,hueShade)$Lisp - hueShade := (hue hue lColor -1)*5 + shade lColor - sendI(VIEW,hueShade)$Lisp - sendI(VIEW,s)$Lisp - graf.key := getI(VIEW)$Lisp - graf +\end{chunk} +\begin{chunk}{COQ FM} +(* domain FM *) +(* + IndexedDirectProductAbelianGroup(R,S) add ---%Exported Functions - makeGraphImage(graf:$) == makeGraph graf - key graf == graf.key - pointLists graf == graf.llPoints - ranges graf == - null graf.rangesField => [] - [segment(convert(lo graf.rangesField.1)@F,convert(hi graf.rangesField.1)@F), _ - segment(convert(lo graf.rangesField.2)@F,convert(hi graf.rangesField.2)@F)] - ranges(graf,rangesList) == - graf.rangesField := - [segment(convert(lo rangesList.1)@SF,convert(hi rangesList.1)@SF), _ - segment(convert(lo rangesList.2)@SF,convert(hi rangesList.2)@SF)] - rangesList - units graf == - null(graf.unitsField) => [] - [convert(graf.unitsField.1)@F,convert(graf.unitsField.2)@F] - units (graf,unitsToBe) == - graf.unitsField := [convert(unitsToBe.1)@SF,convert(unitsToBe.2)@SF] - unitsToBe - graphImage == graph [] + --representations + Term:= Record(k:S,c:R) + Rep:= List Term - makeGraphImage(llp) == - makeGraphImage(llp, - [pointColorDefault() for i in 1..(l:=#llp)], - [lineColorDefault() for i in 1..l], - [pointSizeDefault() for i in 1..l]) + --declarations + x,y: % + r: R + n: Integer + f: R -> R + s: S - makeGraphImage(llp,lpc,llc,lps) == - makeGraphImage(llp,lpc,llc,lps,[]) + --define - makeGraphImage(llp,lpc,llc,lps,opts) == - graf := graph(ranges(opts,[])) - graf.optionsField := opts - graf := plotLists(graf,llp,lpc,llc,lps) - transform := coord(graf.optionsField,cartesian$COORDSYS)$DrawOptionFunctions0 - for aList in graf.llPoints repeat - for p in aList repeat - aPoint := transform p - numberCheck aPoint - makeGraph graf + if R has EntireRing then - component (graf:$,ListOfPoints:L P,PointColor:PAL,LineColor:PAL,PointSize:PI) == - graf.llPoints := append(graf.llPoints,[ListOfPoints]) - graf.pointColors := append(graf.pointColors,[PointColor]) - graf.lineColors := append(graf.lineColors,[LineColor]) - graf.pointSizes := append(graf.pointSizes,[PointSize]) + r * x == + zero? r => 0 + (r = 1) => x + --map(r*#1,x) + [[u.k,r*u.c] for u in x ] - component (graf,aPoint) == - component(graf,aPoint,pointColorDefault(),lineColorDefault(),pointSizeDefault()) + else - component (graf:$,aPoint:P,PointColor:PAL,LineColor:PAL,PointSize:PI) == - component (graf,[aPoint],PointColor,LineColor,PointSize) + r * x == + zero? r => 0 + (r = 1) => x + --map(r*#1,x) + [[u.k,a] for u in x | (a:=r*u.c) ^= 0$R] - appendPoint (graf,aPoint) == - num : I := #(graf.llPoints) - 1 - num < 0 => error "No point lists to append to!" - (graf.llPoints.num) := append((graf.llPoints.num),[aPoint]) + if R has EntireRing then - point (graf,aPoint,PointColor) == - component(graf,aPoint,PointColor,lineColorDefault(),pointSizeDefault()) + x * r == + zero? r => 0 + (r = 1) => x + --map(r*#1,x) + [[u.k,u.c*r] for u in x ] - coerce (llp : L L P) : $ == - makeGraphImage(llp, - [pointColorDefault() for i in 1..(l:=#llp)], - [lineColorDefault() for i in 1..l], - [pointSizeDefault() for i in 1..l]) + else - coerce (graf : $) : E == - hconcat( ["Graph with " :: E,(p := # pointLists graf) :: E, - (p=1 => " point list"; " point lists") :: E]) + x * r == + zero? r => 0 + (r = 1) => x + --map(r*#1,x) + [[u.k,a] for u in x | (a:=u.c*r) ^= 0$R] -\end{chunk} + coerce(x) : OutputForm == + null x => (0$R) :: OutputForm + le : List OutputForm := nil + for rec in reverse x repeat + rec.c = 1 => le := cons(rec.k :: OutputForm, le) + le := cons(rec.c :: OutputForm * rec.k :: OutputForm, le) + reduce("+",le) -\begin{chunk}{COQ GRIMAGE} -(* domain GRIMAGE *) -(* *) \end{chunk} -\begin{chunk}{GRIMAGE.dotabb} -"GRIMAGE" [color="#88FF44",href="bookvol10.3.pdf#nameddest=GRIMAGE"] -"STRING" [color="#88FF44",href="bookvol10.3.pdf#nameddest=STRING"] -"GRIMAGE" -> "STRING" +\begin{chunk}{FM.dotabb} +"FM" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FM"] +"FLAGG" [color="#4488FF",href="bookvol10.2.pdf#nameddest=FLAGG"] +"FM" -> "FLAGG" \end{chunk} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain GOPT GuessOption} +\section{domain FM1 FreeModule1} -\begin{chunk}{GuessOption.input} +\begin{chunk}{FreeModule1.input} )set break resume -)sys rm -f GuessOption.output -)spool GuessOption.output +)sys rm -f FreeModule1.output +)spool FreeModule1.output )set message test on )set message auto off )clear all --S 1 of 1 -)show GuessOption +)show FreeModule1 --R ---R GuessOption is a domain constructor ---R Abbreviation for GuessOption is GOPT ---R This constructor is exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for GOPT +--R FreeModule1(R: Ring,S: OrderedSet) is a domain constructor +--R Abbreviation for FreeModule1 is FM1 +--R This constructor is not exposed in this frame. +--R Issue )edit bookvol10.3.pamphlet to see algebra source code for FM1 --R --R------------------------------- Operations -------------------------------- ---R ?=? : (%,%) -> Boolean allDegrees : Boolean -> % ---R checkExtraValues : Boolean -> % coerce : % -> OutputForm ---R debug : Boolean -> % displayKind : Symbol -> % ---R functionName : Symbol -> % functionNames : List(Symbol) -> % ---R hash : % -> SingleInteger indexName : Symbol -> % ---R latex : % -> String one : Boolean -> % ---R safety : NonNegativeInteger -> % variableName : Symbol -> % +--R ?*? : (S,R) -> % ?*? : (R,S) -> % +--R ?*? : (%,R) -> % ?*? : (R,%) -> % +--R ?*? : (Integer,%) -> % ?*? : (NonNegativeInteger,%) -> % +--R ?*? : (PositiveInteger,%) -> % ?+? : (%,%) -> % +--R ?-? : (%,%) -> % -? : % -> % +--R ?=? : (%,%) -> Boolean 0 : () -> % +--R coefficient : (%,S) -> R coefficients : % -> List(R) +--R coerce : S -> % coerce : % -> OutputForm +--R hash : % -> SingleInteger latex : % -> String +--R leadingCoefficient : % -> R leadingMonomial : % -> S +--R map : ((R -> R),%) -> % monom : (S,R) -> % +--R monomial? : % -> Boolean monomials : % -> List(%) +--R reductum : % -> % retract : % -> S +--R sample : () -> % zero? : % -> Boolean --R ?~=? : (%,%) -> Boolean ---R Somos : Union(PositiveInteger,Boolean) -> % ---R check : Union(skip,MonteCarlo,deterministic) -> % ---R homogeneous : Union(PositiveInteger,Boolean) -> % ---R maxDegree : Union(NonNegativeInteger,arbitrary) -> % ---R maxDerivative : Union(NonNegativeInteger,arbitrary) -> % ---R maxLevel : Union(NonNegativeInteger,arbitrary) -> % ---R maxMixedDegree : NonNegativeInteger -> % ---R maxPower : Union(PositiveInteger,arbitrary) -> % ---R maxShift : Union(NonNegativeInteger,arbitrary) -> % ---R maxSubst : Union(PositiveInteger,arbitrary) -> % ---R option : (List(%),Symbol) -> Union(Any,"failed") +--R leadingTerm : % -> Record(k: S,c: R) +--R listOfTerms : % -> List(Record(k: S,c: R)) +--R numberOfMonomials : % -> NonNegativeInteger +--R retractIfCan : % -> Union(S,"failed") +--R subtractIfCan : (%,%) -> Union(%,"failed") --R --E 1 )spool )lisp (bye) \end{chunk} -\begin{chunk}{GuessOption.help} +\begin{chunk}{FreeModule1.help} ==================================================================== -GuessOption examples +FreeModule1 examples ==================================================================== -GuessOption is a domain whose elements are various options used by Guess. +This domain implements linear combinations of elements from the domain +S with coefficients in the domain R where S is an ordered set and R is +a ring (which may be non-commutative). This domain is used by domains +of non-commutative algebra such as: XDistributedPolynomial, +XRecursivePolynomial. See Also: -o )show GuessOption +o )show FreeModule1 \end{chunk} -\pagehead{GuessOption}{GOPT} -\pagepic{ps/v103guessoption.ps}{GOPT}{1.00} +\pagehead{FreeModule1}{FM1} +\pagepic{ps/v103freemodule1.ps}{FM1}{1.00} {\bf Exports:}\\ \begin{tabular}{lllll} -\cross{GOPT}{?=?} & -\cross{GOPT}{?\~{}=?} & -\cross{GOPT}{Somos} & -\cross{GOPT}{allDegrees} & -\cross{GOPT}{check} \\ -\cross{GOPT}{checkExtraValues} & -\cross{GOPT}{coerce} & -\cross{GOPT}{debug} & -\cross{GOPT}{displayKind} & -\cross{GOPT}{functionName} \\ -\cross{GOPT}{functionNames} & -\cross{GOPT}{hash} & -\cross{GOPT}{homogeneous} & -\cross{GOPT}{indexName} & -\cross{GOPT}{latex} \\ -\cross{GOPT}{maxDegree} & -\cross{GOPT}{maxDerivative} & -\cross{GOPT}{maxLevel} & -\cross{GOPT}{maxMixedDegree} & -\cross{GOPT}{maxPower} \\ -\cross{GOPT}{maxShift} & -\cross{GOPT}{maxSubst} & -\cross{GOPT}{one} & -\cross{GOPT}{option} & -\cross{GOPT}{safety} -\cross{GOPT}{variableName} -\end{tabular} - -\begin{chunk}{domain GOPT GuessOption} -)abbrev domain GOPT GuessOption -++ Author: Martin Rubey -++ Description: -++ GuessOption is a domain whose elements are various options used -++ by Guess. -GuessOption(): Exports == Implementation where - - Exports == SetCategory with - - maxDerivative: Union(NonNegativeInteger, "arbitrary") -> % - ++ maxDerivative(d) specifies the maximum derivative in an algebraic - ++ differential equation. This option is expressed in the form - ++ \spad{maxDerivative == d}. - - maxShift: Union(NonNegativeInteger, "arbitrary") -> % - ++ maxShift(d) specifies the maximum shift in a recurrence - ++ equation. This option is expressed in the form \spad{maxShift == d}. - - maxSubst: Union(PositiveInteger, "arbitrary") -> % - ++ maxSubst(d) specifies the maximum degree of the monomial substituted - ++ into the function we are looking for. That is, if \spad{maxSubst == - ++ d}, we look for polynomials such that $p(f(x), f(x^2), ..., - ++ f(x^d))=0$. equation. This option is expressed in the form - ++ \spad{maxSubst == d}. +\cross{FM1}{0} & +\cross{FM1}{coefficient} & +\cross{FM1}{coefficients} & +\cross{FM1}{coerce} & +\cross{FM1}{hash} \\ +\cross{FM1}{latex} & +\cross{FM1}{leadingCoefficient} & +\cross{FM1}{leadingMonomial} & +\cross{FM1}{leadingTerm} & +\cross{FM1}{listOfTerms} \\ +\cross{FM1}{map} & +\cross{FM1}{monom} & +\cross{FM1}{monomial?} & +\cross{FM1}{monomials} & +\cross{FM1}{numberOfMonomials} \\ +\cross{FM1}{reductum} & +\cross{FM1}{retract} & +\cross{FM1}{retractIfCan} & +\cross{FM1}{sample} & +\cross{FM1}{subtractIfCan} \\ +\cross{FM1}{zero?} & +\cross{FM1}{?\~{}=?} & +\cross{FM1}{?*?} & +\cross{FM1}{?+?} & +\cross{FM1}{?-?} \\ +\cross{FM1}{-?} & +\cross{FM1}{?=?} &&& +\end{tabular} - maxPower: Union(PositiveInteger, "arbitrary") -> % - ++ maxPower(d) specifies the maximum degree in an algebraic differential - ++ equation. For example, the degree of (f'')^3 f' is 4. maxPower(-1) - ++ specifies that the maximum exponent can be arbitrary. This option is - ++ expressed in the form \spad{maxPower == d}. +\begin{chunk}{domain FM1 FreeModule1} +)abbrev domain FM1 FreeModule1 +++ Author: Michel Petitot petitot@lifl.fr +++ Date Created: 91 +++ Date Last Updated: 7 Juillet 92 +++ Fix History: compilation v 2.1 le 13 dec 98 +++ Description: +++ This domain implements linear combinations +++ of elements from the domain \spad{S} with coefficients +++ in the domain \spad{R} where \spad{S} is an ordered set +++ and \spad{R} is a ring (which may be non-commutative). +++ This domain is used by domains of non-commutative algebra such as: +++ XDistributedPolynomial, XRecursivePolynomial. - homogeneous: Union(PositiveInteger, Boolean) -> % - ++ homogeneous(d) specifies whether we allow only homogeneous algebraic - ++ differential equations. This option is expressed in the form - ++ \spad{homogeneous == d}. If true, then maxPower must be - ++ set, too, and ADEs with constant total degree are allowed. - ++ If a PositiveInteger is given, only ADE's with this total degree are - ++ allowed. +FreeModule1(R:Ring,S:OrderedSet): FMcat == FMdef where + EX ==> OutputForm + TERM ==> Record(k:S,c:R) - Somos: Union(PositiveInteger, Boolean) -> % - ++ Somos(d) specifies whether we want that the total degree of the - ++ differential operators is constant, and equal to d, or maxDerivative - ++ if true. If true, maxDerivative must be set, too. + FMcat == FreeModuleCat(R,S) with + "*":(S,R) -> % + ++ \spad{s*r} returns the product \spad{r*s} + ++ used by \spadtype{XRecursivePolynomial} + FMdef == FreeModule(R,S) add - maxLevel: Union(NonNegativeInteger, "arbitrary") -> % - ++ maxLevel(d) specifies the maximum number of recursion levels operators - ++ guessProduct and guessSum will be applied. This option is expressed in - ++ the form spad{maxLevel == d}. + -- representation + Rep := List TERM - maxDegree: Union(NonNegativeInteger, "arbitrary") -> % - ++ maxDegree(d) specifies the maximum degree of the coefficient - ++ polynomials in an algebraic differential equation or a recursion with - ++ polynomial coefficients. For rational functions with an exponential - ++ term, \spad{maxDegree} bounds the degree of the denominator - ++ polynomial. - ++ This option is expressed in the form \spad{maxDegree == d}. + -- declarations + lt: List TERM + x : % + r : R + s : S - maxMixedDegree: NonNegativeInteger -> % - ++ maxMixedDegree(d) specifies the maximum q-degree of the coefficient - ++ polynomials in a recurrence with polynomial coefficients, in the case - ++ of mixed shifts. Although slightly inconsistent, maxMixedDegree(0) - ++ specifies that no mixed shifts are allowed. This option is expressed - ++ in the form \spad{maxMixedDegree == d}. + -- define + numberOfMonomials p == + # (p::Rep) - allDegrees: Boolean -> % - ++ allDegrees(d) specifies whether all possibilities of the degree vector - ++ - taking into account maxDegree - should be tried. This is mainly - ++ interesting for rational interpolation. This option is expressed in - ++ the form \spad{allDegrees == d}. + listOfTerms(x) == x:List TERM - safety: NonNegativeInteger -> % - ++ safety(d) specifies the number of values reserved for testing any - ++ solutions found. This option is expressed in the form \spad{safety == - ++ d}. + leadingTerm x == x.first - check: Union("skip", "MonteCarlo", "deterministic") -> % - ++ check(d) specifies how we want to check the solution. If - ++ the value is "skip", we return the solutions found by the - ++ interpolation routine without checking. If the value is - ++ "MonteCarlo", we use a probabilistic check. This option is - ++ expressed in the form \spad{check == d} + leadingMonomial x == x.first.k - checkExtraValues: Boolean -> % - ++ checkExtraValues(d) specifies whether we want to check the - ++ solution beyond the order given by the degree bounds. This - ++ option is expressed in the form \spad{checkExtraValues == d} + coefficients x == [t.c for t in x] - one: Boolean -> % - ++ one(d) specifies whether we are happy with one solution. This option - ++ is expressed in the form \spad{one == d}. + monomials x == [ monom (t.k, t.c) for t in x] - debug: Boolean -> % - ++ debug(d) specifies whether we want additional output on the - ++ progress. This option is expressed in the form \spad{debug == d}. + retractIfCan x == + numberOfMonomials(x) ^= 1 => "failed" + x.first.c = 1 => x.first.k + "failed" - functionName: Symbol -> % - ++ functionName(d) specifies the name of the function given by the - ++ algebraic differential equation or recurrence. This option is - ++ expressed in the form \spad{functionName == d}. + coerce(s:S):% == [[s,1$R]] - functionNames: List(Symbol) -> % - ++ functionNames(d) specifies the names for the function in - ++ algebraic dependence. This option is - ++ expressed in the form \spad{functionNames == d}. + retract x == + (rr := retractIfCan x) case "failed" => error "FM1.retract impossible" + rr :: S - variableName: Symbol -> % - ++ variableName(d) specifies the variable used in by the algebraic - ++ differential equation. This option is expressed in the form - ++ \spad{variableName == d}. + if R has noZeroDivisors then - indexName: Symbol -> % - ++ indexName(d) specifies the index variable used for the formulas. This - ++ option is expressed in the form \spad{indexName == d}. + r * x == + r = 0 => 0 + [[u.k,r * u.c]$TERM for u in x] - displayKind: Symbol -> % - ++ displayKind(d) specifies kind of the result: generating function, - ++ recurrence or equation. This option should not be set by the - ++ user, but rather by the HP-specification. + x * r == + r = 0 => 0 + [[u.k,u.c * r]$TERM for u in x] - option : (List %, Symbol) -> Union(Any, "failed") - ++ option(l, option) returns which options are given. + else - Implementation ==> add - import AnyFunctions1(Boolean) - import AnyFunctions1(Symbol) - import AnyFunctions1(NonNegativeInteger) - import AnyFunctions1(Union(NonNegativeInteger, "arbitrary")) - import AnyFunctions1(Union(PositiveInteger, "arbitrary")) - import AnyFunctions1(Union(PositiveInteger, Boolean)) - import AnyFunctions1(Union("skip", "MonteCarlo", "deterministic")) + r * x == + r = 0 => 0 + [[u.k,a] for u in x | not (a:=r*u.c)= 0$R] - Rep := Record(keyword: Symbol, value: Any) + x * r == + r = 0 => 0 + [[u.k,a] for u in x | not (a:=u.c*r)= 0$R] - maxLevel d == ['maxLevel, d::Any] - maxDerivative d == ['maxDerivative, d::Any] - maxShift d == maxDerivative d - maxSubst d == - if d case PositiveInteger - then maxDerivative((d::Integer-1)::NonNegativeInteger) - else maxDerivative d - maxDegree d == ['maxDegree, d::Any] - maxMixedDegree d == ['maxMixedDegree, d::Any] - allDegrees d == ['allDegrees, d::Any] - maxPower d == ['maxPower, d::Any] - safety d == ['safety, d::Any] - homogeneous d == ['homogeneous, d::Any] - Somos d == ['Somos, d::Any] - debug d == ['debug, d::Any] - check d == ['check, d::Any] - checkExtraValues d == ['checkExtraValues, d::Any] - one d == ['one, d::Any] - functionName d == ['functionName, d::Any] - functionNames d == - ['functionNames, coerce(d)$AnyFunctions1(List(Symbol))] - variableName d == ['variableName, d::Any] - indexName d == ['indexName, d::Any] - displayKind d == ['displayKind, d::Any] + r * s == + r = 0 => 0 + [[s,r]$TERM] - coerce(x:%):OutputForm == x.keyword::OutputForm = x.value::OutputForm - x:% = y:% == x.keyword = y.keyword and x.value = y.value + s * r == + r = 0 => 0 + [[s,r]$TERM] - option(l, s) == - for x in l repeat - x.keyword = s => return(x.value) - "failed" + monom(b,r):% == [[b,r]$TERM] + + outTerm(r:R, s:S):EX == + r=1 => s::EX + r::EX * s::EX + + coerce(a:%):EX == + empty? a => (0$R)::EX + reduce(_+, reverse_! [outTerm(t.c, t.k) for t in a])$List(EX) + + coefficient(x,s) == + null x => 0$R + x.first.k > s => coefficient(rest x,s) + x.first.k = s => x.first.c + 0$R \end{chunk} -\begin{chunk}{COQ GOPT} -(* domain GOPT *) +\begin{chunk}{COQ FM1} +(* domain FM1 *) (* + FreeModule(R,S) add + + -- representation + Rep := List TERM + + -- declarations + lt: List TERM + x : % + r : R + s : S + + -- define + numberOfMonomials p == + # (p::Rep) + + listOfTerms(x) == x:List TERM + + leadingTerm x == x.first + + leadingMonomial x == x.first.k + + coefficients x == [t.c for t in x] + + monomials x == [ monom (t.k, t.c) for t in x] + + retractIfCan x == + numberOfMonomials(x) ^= 1 => "failed" + x.first.c = 1 => x.first.k + "failed" + + coerce(s:S):% == [[s,1$R]] + + retract x == + (rr := retractIfCan x) case "failed" => error "FM1.retract impossible" + rr :: S + + if R has noZeroDivisors then + + r * x == + r = 0 => 0 + [[u.k,r * u.c]$TERM for u in x] + + x * r == + r = 0 => 0 + [[u.k,u.c * r]$TERM for u in x] + + else + + r * x == + r = 0 => 0 + [[u.k,a] for u in x | not (a:=r*u.c)= 0$R] + + x * r == + r = 0 => 0 + [[u.k,a] for u in x | not (a:=u.c*r)= 0$R] + + r * s == + r = 0 => 0 + [[s,r]$TERM] + + s * r == + r = 0 => 0 + [[s,r]$TERM] + + monom(b,r):% == [[b,r]$TERM] + + outTerm(r:R, s:S):EX == + r=1 => s::EX + r::EX * s::EX + + coerce(a:%):EX == + empty? a => (0$R)::EX + reduce(_+, reverse_! [outTerm(t.c, t.k) for t in a])$List(EX) + + coefficient(x,s) == + null x => 0$R + x.first.k > s => coefficient(rest x,s) + x.first.k = s => x.first.c + 0$R + *) \end{chunk} -\begin{chunk}{GOPT.dotabb} -"GOPT" [color="#88FF44",href="bookvol10.3.pdf#nameddest=GOPT"] -"ALIST" [color="#88FF44",href="bookvol10.3.pdf#nameddest=ALIST"] -"GOPT" -> "ALIST" +\begin{chunk}{FM1.dotabb} +"FM1" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FM1"] +"FLAGG" [color="#4488FF",href="bookvol10.2.pdf#nameddest=FLAGG"] +"FM1" -> "FLAGG" \end{chunk} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain GOPT0 GuessOptionFunctions0} +\section{domain FMONOID FreeMonoid} -\begin{chunk}{GuessOptionFunctions0.input} +\begin{chunk}{FreeMonoid.input} )set break resume -)sys rm -f GuessOptionFunctions0.output -)spool GuessOptionFunctions0.output +)sys rm -f FreeMonoid.output +)spool FreeMonoid.output )set message test on )set message auto off )clear all --S 1 of 1 -)show GuessOptionFunctions0 +)show FreeMonoid --R ---R GuessOptionFunctions0 is a domain constructor ---R Abbreviation for GuessOptionFunctions0 is GOPT0 +--R FreeMonoid(S: SetCategory) is a domain constructor +--R Abbreviation for FreeMonoid is FMONOID --R This constructor is not exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for GOPT0 +--R Issue )edit bookvol10.3.pamphlet to see algebra source code for FMONOID --R --R------------------------------- Operations -------------------------------- ---R ?=? : (%,%) -> Boolean coerce : % -> OutputForm ---R debug : List(GuessOption) -> Boolean hash : % -> SingleInteger ---R latex : % -> String one : List(GuessOption) -> Boolean ---R ?~=? : (%,%) -> Boolean ---R Somos : List(GuessOption) -> Union(PositiveInteger,Boolean) ---R allDegrees : List(GuessOption) -> Boolean ---R check : List(GuessOption) -> Union(skip,MonteCarlo,deterministic) ---R checkExtraValues : List(GuessOption) -> Boolean ---R checkOptions : List(GuessOption) -> Void ---R displayAsGF : List(GuessOption) -> Boolean ---R functionName : List(GuessOption) -> Symbol ---R homogeneous : List(GuessOption) -> Union(PositiveInteger,Boolean) ---R indexName : List(GuessOption) -> Symbol ---R maxDegree : List(GuessOption) -> Union(NonNegativeInteger,arbitrary) ---R maxDerivative : List(GuessOption) -> Union(NonNegativeInteger,arbitrary) ---R maxLevel : List(GuessOption) -> Union(NonNegativeInteger,arbitrary) ---R maxMixedDegree : List(GuessOption) -> NonNegativeInteger ---R maxPower : List(GuessOption) -> Union(PositiveInteger,arbitrary) ---R maxShift : List(GuessOption) -> Union(NonNegativeInteger,arbitrary) ---R maxSubst : List(GuessOption) -> Union(PositiveInteger,arbitrary) ---R safety : List(GuessOption) -> NonNegativeInteger ---R variableName : List(GuessOption) -> Symbol +--R ?*? : (%,S) -> % ?*? : (S,%) -> % +--R ?*? : (%,%) -> % ?**? : (S,NonNegativeInteger) -> % +--R ?**? : (%,NonNegativeInteger) -> % ?**? : (%,PositiveInteger) -> % +--R ?=? : (%,%) -> Boolean 1 : () -> % +--R ?^? : (%,NonNegativeInteger) -> % ?^? : (%,PositiveInteger) -> % +--R coerce : S -> % coerce : % -> OutputForm +--R hash : % -> SingleInteger hclf : (%,%) -> % +--R hcrf : (%,%) -> % latex : % -> String +--R lquo : (%,%) -> Union(%,"failed") mapGen : ((S -> S),%) -> % +--R max : (%,%) -> % if S has ORDSET min : (%,%) -> % if S has ORDSET +--R nthFactor : (%,Integer) -> S one? : % -> Boolean +--R recip : % -> Union(%,"failed") retract : % -> S +--R rquo : (%,%) -> Union(%,"failed") sample : () -> % +--R size : % -> NonNegativeInteger ?~=? : (%,%) -> Boolean +--R ? Boolean if S has ORDSET +--R ?<=? : (%,%) -> Boolean if S has ORDSET +--R ?>? : (%,%) -> Boolean if S has ORDSET +--R ?>=? : (%,%) -> Boolean if S has ORDSET +--R divide : (%,%) -> Union(Record(lm: %,rm: %),"failed") +--R factors : % -> List(Record(gen: S,exp: NonNegativeInteger)) +--R mapExpon : ((NonNegativeInteger -> NonNegativeInteger),%) -> % +--R nthExpon : (%,Integer) -> NonNegativeInteger +--R overlap : (%,%) -> Record(lm: %,mm: %,rm: %) +--R retractIfCan : % -> Union(S,"failed") --R --E 1 )spool )lisp (bye) \end{chunk} -\begin{chunk}{GuessOptionFunctions0.help} +\begin{chunk}{FreeMonoid.help} ==================================================================== -GuessOptionFunctions0 examples +FreeMonoid examples ==================================================================== -GuessOptionFunctions0 provides operations that extract the -values of options for Guess. +Free monoid on any set of generators. The free monoid on a set S is +the monoid of finite products of the form reduce(*,[si ** ni]) where +the si's are in S, and the ni's are nonnegative integers. The +multiplication is not commutative. See Also: -o )show GuessOptionFunctions0 +o )show FreeMonoid \end{chunk} -\pagehead{GuessOptionFunctions0}{GOPT0} -\pagepic{ps/v103guessoptionfunctions0.eps}{GOPT0}{1.00} + +\pagehead{FreeMonoid}{FMONOID} +\pagepic{ps/v103freemonoid.ps}{FMONOID}{1.00} +{\bf See}\\ +\pageto{ListMonoidOps}{LMOPS} +\pageto{FreeGroup}{FGROUP} +\pageto{InnerFreeAbelianMonoid}{IFAMON} +\pageto{FreeAbelianMonoid}{FAMONOID} +\pageto{FreeAbelianGroup}{FAGROUP} {\bf Exports:}\\ \begin{tabular}{lllll} -\cross{GOPT0}{?=?} & -\cross{GOPT0}{?\~{}=?} & -\cross{GOPT0}{MonteCarlo} & -\cross{GOPT0}{Somos} & -\cross{GOPT0}{allDegrees} \\ -\cross{GOPT0}{check} & -\cross{GOPT0}{checkOptions} & -\cross{GOPT0}{coerce} & -\cross{GOPT0}{debug} & -\cross{GOPT0}{displayAsGF} \\ -\cross{GOPT0}{functionName} & -\cross{GOPT0}{hash} & -\cross{GOPT0}{homogeneous} & -\cross{GOPT0}{indexName} & -\cross{GOPT0}{latex} \\ -\cross{GOPT0}{maxDegree} & -\cross{GOPT0}{maxDerivative} & -\cross{GOPT0}{maxLevel} & -\cross{GOPT0}{maxMixedDegree} & -\cross{GOPT0}{maxPower} \\ -\cross{GOPT0}{maxShift} & -\cross{GOPT0}{maxSubst} & -\cross{GOPT0}{one} & -\cross{GOPT0}{safety} & -\cross{GOPT0}{variableName} +\cross{FMONOID}{1} & +\cross{FMONOID}{coerce} & +\cross{FMONOID}{divide} & +\cross{FMONOID}{factors} & +\cross{FMONOID}{hash} \\ +\cross{FMONOID}{hclf} & +\cross{FMONOID}{hcrf} & +\cross{FMONOID}{latex} & +\cross{FMONOID}{lquo} & +\cross{FMONOID}{mapExpon} \\ +\cross{FMONOID}{mapGen} & +\cross{FMONOID}{max} & +\cross{FMONOID}{min} & +\cross{FMONOID}{nthExpon} & +\cross{FMONOID}{nthFactor} \\ +\cross{FMONOID}{one?} & +\cross{FMONOID}{overlap} & +\cross{FMONOID}{recip} & +\cross{FMONOID}{rquo} & +\cross{FMONOID}{retract} \\ +\cross{FMONOID}{retractIfCan} & +\cross{FMONOID}{sample} & +\cross{FMONOID}{size} & +\cross{FMONOID}{?\~{}=?} & +\cross{FMONOID}{?**?} \\ +\cross{FMONOID}{?$<$?} & +\cross{FMONOID}{?$<=$?} & +\cross{FMONOID}{?$>$?} & +\cross{FMONOID}{?$>=$?} & +\cross{FMONOID}{?\^{}?} \\ +\cross{FMONOID}{?*?} & +\cross{FMONOID}{?=?} &&& \end{tabular} -\begin{chunk}{domain GOPT0 GuessOptionFunctions0} -)abbrev domain GOPT0 GuessOptionFunctions0 -++ Author: Martin Rubey -++ Description: -++ GuessOptionFunctions0 provides operations that extract the -++ values of options for Guess. -GuessOptionFunctions0(): Exports == Implementation where - - LGOPT ==> List GuessOption - - Exports == SetCategory with - - maxDerivative: LGOPT -> Union(NonNegativeInteger, "arbitrary") - ++ maxDerivative returns the specified maxDerivative. - - maxShift: LGOPT -> Union(NonNegativeInteger, "arbitrary") - ++ maxShift returns the specified maxShift. - - maxSubst: LGOPT -> Union(PositiveInteger, "arbitrary") - ++ maxSubst returns the specified maxSubst. - - maxPower: LGOPT -> Union(PositiveInteger, "arbitrary") - ++ maxPower returns the specified maxPower. - - homogeneous: LGOPT -> Union(PositiveInteger, Boolean) - ++ homogeneous returns whether we allow only homogeneous algebraic - ++ differential equations, default being false - - Somos: LGOPT -> Union(PositiveInteger, Boolean) - ++ Somos returns whether we allow only Somos-like operators, default - ++ being false - - maxLevel: LGOPT -> Union(NonNegativeInteger, "arbitrary") - ++ maxLevel returns the specified maxLevel. - - maxDegree: LGOPT -> Union(NonNegativeInteger, "arbitrary") - ++ maxDegree returns the specified maxDegree. - - maxMixedDegree: LGOPT -> NonNegativeInteger - ++ maxMixedDegree returns the specified maxMixedDegree. +\begin{chunk}{domain FMONOID FreeMonoid} +)abbrev domain FMONOID FreeMonoid +++ Author: Stephen M. Watt +++ Date Last Updated: 6 June 1991 +++ Description: +++ Free monoid on any set of generators +++ The free monoid on a set S is the monoid of finite products of +++ the form \spad{reduce(*,[si ** ni])} where the si's are in S, and the ni's +++ are nonnegative integers. The multiplication is not commutative. - allDegrees: LGOPT -> Boolean - ++ allDegrees returns whether all possibilities of the degree vector - ++ should be tried, the default being false. +FreeMonoid(S: SetCategory): FMcategory == FMdefinition where + NNI ==> NonNegativeInteger + REC ==> Record(gen: S, exp: NonNegativeInteger) + Ex ==> OutputForm - safety: LGOPT -> NonNegativeInteger - ++ safety returns the specified safety or 1 as default. + FMcategory ==> Join(Monoid, RetractableTo S) with + "*": (S, $) -> $ + ++ s * x returns the product of x by s on the left. + "*": ($, S) -> $ + ++ x * s returns the product of x by s on the right. + "**": (S, NonNegativeInteger) -> $ + ++ s ** n returns the product of s by itself n times. + hclf: ($, $) -> $ + ++ hclf(x, y) returns the highest common left factor of x and y, + ++ i.e. the largest d such that \spad{x = d a} and \spad{y = d b}. + hcrf: ($, $) -> $ + ++ hcrf(x, y) returns the highest common right factor of x and y, + ++ i.e. the largest d such that \spad{x = a d} and \spad{y = b d}. + lquo: ($, $) -> Union($, "failed") + ++ lquo(x, y) returns the exact left quotient of x by y i.e. + ++ q such that \spad{x = y * q}, + ++ "failed" if x is not of the form \spad{y * q}. + rquo: ($, $) -> Union($, "failed") + ++ rquo(x, y) returns the exact right quotient of x by y i.e. + ++ q such that \spad{x = q * y}, + ++ "failed" if x is not of the form \spad{q * y}. + divide: ($, $) -> Union(Record(lm: $, rm: $), "failed") + ++ divide(x, y) returns the left and right exact quotients of + ++ x by y, i.e. \spad{[l, r]} such that \spad{x = l * y * r}, + ++ "failed" if x is not of the form \spad{l * y * r}. + overlap: ($, $) -> Record(lm: $, mm: $, rm: $) + ++ overlap(x, y) returns \spad{[l, m, r]} such that + ++ \spad{x = l * m}, \spad{y = m * r} and l and r have no overlap, + ++ i.e. \spad{overlap(l, r) = [l, 1, r]}. + size : $ -> NNI + ++ size(x) returns the number of monomials in x. + factors : $ -> List Record(gen: S, exp: NonNegativeInteger) + ++ factors(a1\^e1,...,an\^en) returns \spad{[[a1, e1],...,[an, en]]}. + nthExpon : ($, Integer) -> NonNegativeInteger + ++ nthExpon(x, n) returns the exponent of the n^th monomial of x. + nthFactor : ($, Integer) -> S + ++ nthFactor(x, n) returns the factor of the n^th monomial of x. + mapExpon : (NNI -> NNI, $) -> $ + ++ mapExpon(f, a1\^e1 ... an\^en) + ++ returns \spad{a1\^f(e1) ... an\^f(en)}. + mapGen : (S -> S, $) -> $ + ++ mapGen(f, a1\^e1 ... an\^en) returns + ++\spad{f(a1)\^e1 ... f(an)\^en}. + if S has OrderedSet then OrderedSet - check: LGOPT -> Union("skip", "MonteCarlo", "deterministic") - ++ check(d) specifies how we want to check the solution. If - ++ the value is "skip", we return the solutions found by the - ++ interpolation routine without checking. If the value is - ++ "MonteCarlo", we use a probabilistic check. The default is - ++ "deterministic". + FMdefinition ==> ListMonoidOps(S, NonNegativeInteger, 1) add - checkExtraValues: LGOPT -> Boolean - ++ checkExtraValues(d) specifies whether we want to check the - ++ solution beyond the order given by the degree bounds. The - ++ default is true. + Rep := ListMonoidOps(S, NonNegativeInteger, 1) - one: LGOPT -> Boolean - ++ one returns whether we need only one solution, default being true. + 1 == makeUnit() - functionName: LGOPT -> Symbol - ++ functionName returns the name of the function given by the algebraic - ++ differential equation, default being f + one? f == empty? listOfMonoms f - variableName: LGOPT -> Symbol - ++ variableName returns the name of the variable used in by the - ++ algebraic differential equation, default being x + coerce(f:$): Ex == outputForm(f, "*", "**", 1) - indexName: LGOPT -> Symbol - ++ indexName returns the name of the index variable used for the - ++ formulas, default being n + hcrf(f, g) == reverse_! hclf(reverse f, reverse g) - displayAsGF: LGOPT -> Boolean - ++ displayAsGF specifies whether the result is a generating function - ++ or a recurrence. This option should not be set by the user, but rather - ++ by the HP-specification, therefore, there is no default. + f:$ * s:S == rightMult(f, s) - debug: LGOPT -> Boolean - ++ debug returns whether we want additional output on the progress, - ++ default being false + s:S * f:$ == leftMult(s, f) - checkOptions: LGOPT -> Void - ++ checkOptions checks whether the given options are consistent, and - ++ yields an error otherwise + factors f == copy listOfMonoms f - Implementation == add + mapExpon(f, x) == mapExpon(f, x)$Rep - maxLevel l == - if (opt := option(l, 'maxLevel)) case "failed" then - "arbitrary" - else - retract(opt::Any)$AnyFunctions1(Union(NonNegativeInteger, "arbitrary")) + mapGen(f, x) == mapGen(f, x)$Rep - maxDerivative l == - if (opt := option(l, 'maxDerivative)) case "failed" then - "arbitrary" - else - retract(opt::Any)$AnyFunctions1(Union(NonNegativeInteger, "arbitrary")) + s:S ** n:NonNegativeInteger == makeTerm(s, n) - maxShift l == maxDerivative l + f:$ * g:$ == + (f = 1) => g + (g = 1) => f + lg := listOfMonoms g + ls := last(lf := listOfMonoms f) + ls.gen = lg.first.gen => + setlast_!(h := copy lf,[lg.first.gen,lg.first.exp+ls.exp]) + makeMulti concat(h, rest lg) + makeMulti concat(lf, lg) - maxSubst l == - d := maxDerivative l - if d case NonNegativeInteger - then (d+1)::PositiveInteger - else d + overlap(la, ar) == + (la = 1) or (ar = 1) => [la, 1, ar] + lla := la0 := listOfMonoms la + lar := listOfMonoms ar + l:List(REC) := empty() + while not empty? lla repeat + if lla.first.gen = lar.first.gen then + if lla.first.exp < lar.first.exp and empty? rest lla then + return [makeMulti l, + makeTerm(lla.first.gen, lla.first.exp), + makeMulti concat([lar.first.gen, + (lar.first.exp - lla.first.exp)::NNI], + rest lar)] + if lla.first.exp >= lar.first.exp then + if (ru:= lquo(makeMulti rest lar, + makeMulti rest lla)) case $ then + if lla.first.exp > lar.first.exp then + l := concat_!(l, [lla.first.gen, + (lla.first.exp - lar.first.exp)::NNI]) + m := concat([lla.first.gen, lar.first.exp], + rest lla) + else m := lla + return [makeMulti l, makeMulti m, ru::$] + l := concat_!(l, lla.first) + lla := rest lla + [makeMulti la0, 1, makeMulti lar] - maxDegree l == - if (opt := option(l, 'maxDegree)) case "failed" then - "arbitrary" - else - retract(opt::Any)$AnyFunctions1(Union(NonNegativeInteger, "arbitrary")) + divide(lar, a) == + (a = 1) => [lar, 1] + Na : Integer := #(la := listOfMonoms a) + Nlar : Integer := #(llar := listOfMonoms lar) + l:List(REC) := empty() + while Na <= Nlar repeat + if llar.first.gen = la.first.gen and + llar.first.exp >= la.first.exp then + -- Can match a portion of this lar factor. + -- Now match tail. + (q:=lquo(makeMulti rest llar,makeMulti rest la))case $ => + if llar.first.exp > la.first.exp then + l := concat_!(l, [la.first.gen, + (llar.first.exp - la.first.exp)::NNI]) + return [makeMulti l, q::$] + l := concat_!(l, first llar) + llar := rest llar + Nlar := Nlar - 1 + "failed" - maxMixedDegree l == - if (opt := option(l, 'maxMixedDegree)) case "failed" then - 0 - else - retract(opt :: Any)$AnyFunctions1(NonNegativeInteger) + hclf(f, g) == + h:List(REC) := empty() + for f0 in listOfMonoms f for g0 in listOfMonoms g repeat + f0.gen ^= g0.gen => return makeMulti h + h := concat_!(h, [f0.gen, min(f0.exp, g0.exp)]) + f0.exp ^= g0.exp => return makeMulti h + makeMulti h - allDegrees l == - if (opt := option(l, 'allDegrees)) case "failed" then - false - else - retract(opt :: Any)$AnyFunctions1(Boolean) + lquo(aq, a) == + size a > #(laq := copy listOfMonoms aq) => "failed" + for a0 in listOfMonoms a repeat + a0.gen ^= laq.first.gen or a0.exp > laq.first.exp => + return "failed" + if a0.exp = laq.first.exp then laq := rest laq + else setfirst_!(laq, [laq.first.gen, + (laq.first.exp - a0.exp)::NNI]) + makeMulti laq - maxPower l == - if (opt := option(l, 'maxPower)) case "failed" then - "arbitrary" - else - retract(opt :: Any)$AnyFunctions1(Union(PositiveInteger, "arbitrary")) + rquo(qa, a) == + (u := lquo(reverse qa, reverse a)) case "failed" => "failed" + reverse_!(u::$) - safety l == - if (opt := option(l, 'safety)) case "failed" then - 1$NonNegativeInteger - else - retract(opt :: Any)$AnyFunctions1(NonNegativeInteger) + if S has OrderedSet then + a < b == + la := listOfMonoms a + lb := listOfMonoms b + na: Integer := #la + nb: Integer := #lb + while na > 0 and nb > 0 repeat + la.first.gen > lb.first.gen => return false + la.first.gen < lb.first.gen => return true + if la.first.exp = lb.first.exp then + la:=rest la + lb:=rest lb + na:=na - 1 + nb:=nb - 1 + else if la.first.exp > lb.first.exp then + la:=concat([la.first.gen, + (la.first.exp - lb.first.exp)::NNI], rest lb) + lb:=rest lb + nb:=nb - 1 + else + lb:=concat([lb.first.gen, + (lb.first.exp-la.first.exp)::NNI], rest la) + la:=rest la + na:=na-1 + empty? la and not empty? lb - check l == - if (opt := option(l, 'check)) case "failed" then - "deterministic" - else - retract(opt::Any)$AnyFunctions1(_ - Union("skip", "MonteCarlo", "deterministic")) +\end{chunk} - checkExtraValues l == - if (opt := option(l, 'checkExtraValues)) case "failed" then - true - else - retract(opt :: Any)$AnyFunctions1(Boolean) +\begin{chunk}{COQ FMONOID} +(* domain FMONOID *) +(* - one l == - if (opt := option(l, 'one)) case "failed" then - true - else - retract(opt :: Any)$AnyFunctions1(Boolean) + Rep := ListMonoidOps(S, NonNegativeInteger, 1) - debug l == - if (opt := option(l, 'debug)) case "failed" then - false - else - retract(opt :: Any)$AnyFunctions1(Boolean) + 1 == makeUnit() - homogeneous l == - if (opt := option(l, 'homogeneous)) case "failed" then - false - else - retract(opt :: Any)$AnyFunctions1(Union(PositiveInteger, Boolean)) + one? f == empty? listOfMonoms f - Somos l == - if (opt := option(l, 'Somos)) case "failed" then - false - else - retract(opt :: Any)$AnyFunctions1(Union(PositiveInteger, Boolean)) + coerce(f:$): Ex == outputForm(f, "*", "**", 1) - variableName l == - if (opt := option(l, 'variableName)) case "failed" then - 'x - else - retract(opt :: Any)$AnyFunctions1(Symbol) + hcrf(f, g) == reverse_! hclf(reverse f, reverse g) - functionName l == - if (opt := option(l, 'functionName)) case "failed" then - 'f - else - retract(opt :: Any)$AnyFunctions1(Symbol) + f:$ * s:S == rightMult(f, s) - indexName l == - if (opt := option(l, 'indexName)) case "failed" then - 'n - else - retract(opt :: Any)$AnyFunctions1(Symbol) + s:S * f:$ == leftMult(s, f) - displayAsGF l == - if (opt := option(l, 'displayAsGF)) case "failed" then - error "GuessOption: displayAsGF not set" - else - retract(opt :: Any)$AnyFunctions1(Boolean) + factors f == copy listOfMonoms f - NNI ==> NonNegativeInteger - PI ==> PositiveInteger + mapExpon(f, x) == mapExpon(f, x)$Rep - checkOptions l == - maxD := maxDerivative l - maxP := maxPower l - homo := homogeneous l - Somo := Somos l + mapGen(f, x) == mapGen(f, x)$Rep - if Somo case PI then - if one? Somo then - error "Guess: Somos must be Boolean or at least two" + s:S ** n:NonNegativeInteger == makeTerm(s, n) - if maxP case PI and one? maxP then - error "Guess: Somos requires that maxPower is at least two" + f:$ * g:$ == + (f = 1) => g + (g = 1) => f + lg := listOfMonoms g + ls := last(lf := listOfMonoms f) + ls.gen = lg.first.gen => + setlast_!(h := copy lf,[lg.first.gen,lg.first.exp+ls.exp]) + makeMulti concat(h, rest lg) + makeMulti concat(lf, lg) - if maxD case NNI and maxD > Somo then - err:String:=concat [_ - "Guess: if Somos is an integer, it should be larger than ",_ - "maxDerivative/maxShift or at least as big as maxSubst" ] - error err - else - if Somo then - if maxP case PI and one? maxP then - error "Guess: Somos requires that maxPower is at least two" + overlap(la, ar) == + (la = 1) or (ar = 1) => [la, 1, ar] + lla := la0 := listOfMonoms la + lar := listOfMonoms ar + l:List(REC) := empty() + while not empty? lla repeat + if lla.first.gen = lar.first.gen then + if lla.first.exp < lar.first.exp and empty? rest lla then + return [makeMulti l, + makeTerm(lla.first.gen, lla.first.exp), + makeMulti concat([lar.first.gen, + (lar.first.exp - lla.first.exp)::NNI], + rest lar)] + if lla.first.exp >= lar.first.exp then + if (ru:= lquo(makeMulti rest lar, + makeMulti rest lla)) case $ then + if lla.first.exp > lar.first.exp then + l := concat_!(l, [lla.first.gen, + (lla.first.exp - lar.first.exp)::NNI]) + m := concat([lla.first.gen, lar.first.exp], + rest lla) + else m := lla + return [makeMulti l, makeMulti m, ru::$] + l := concat_!(l, lla.first) + lla := rest lla + [makeMulti la0, 1, makeMulti lar] - if not (maxD case NNI) or zero? maxD or one? maxD then - err:String:= concat [_ - "Guess: Somos==true requires that maxDerivative/maxShift",_ - " is an integer, at least two, or maxSubst is an ",_ - "integer, at least three" ] - error err + divide(lar, a) == + (a = 1) => [lar, 1] + Na : Integer := #(la := listOfMonoms a) + Nlar : Integer := #(llar := listOfMonoms lar) + l:List(REC) := empty() + while Na <= Nlar repeat + if llar.first.gen = la.first.gen and + llar.first.exp >= la.first.exp then + -- Can match a portion of this lar factor. + -- Now match tail. + (q:=lquo(makeMulti rest llar,makeMulti rest la))case $ => + if llar.first.exp > la.first.exp then + l := concat_!(l, [la.first.gen, + (llar.first.exp - la.first.exp)::NNI]) + return [makeMulti l, q::$] + l := concat_!(l, first llar) + llar := rest llar + Nlar := Nlar - 1 + "failed" - if not (maxP case PI) and homo case Boolean and not homo then - err:String:= concat [_ - "Guess: Somos requires that maxPower is set or ", _ - "homogeneous is not false" ] - error err + hclf(f, g) == + h:List(REC) := empty() + for f0 in listOfMonoms f for g0 in listOfMonoms g repeat + f0.gen ^= g0.gen => return makeMulti h + h := concat_!(h, [f0.gen, min(f0.exp, g0.exp)]) + f0.exp ^= g0.exp => return makeMulti h + makeMulti h - if homo case PI then - if maxP case PI and maxP ~= homo then - err:String:= _ - "Guess: only one of homogeneous and maxPower may be an integer" - error err + lquo(aq, a) == + size a > #(laq := copy listOfMonoms aq) => "failed" + for a0 in listOfMonoms a repeat + a0.gen ^= laq.first.gen or a0.exp > laq.first.exp => + return "failed" + if a0.exp = laq.first.exp then laq := rest laq + else setfirst_!(laq, [laq.first.gen, + (laq.first.exp - a0.exp)::NNI]) + makeMulti laq - if maxD case NNI and zero? maxD then - err:String:= concat [_ - "Guess: homogeneous requires that maxShift/maxDerivative ",_ - "is at least one or maxSubst is at least two" ] - error err - else - if homo then - if not maxP case PI then - err:String:= concat [_ - "Guess: homogeneous==true requires that maxPower is ", _ - "an integer" ] - error err + rquo(qa, a) == + (u := lquo(reverse qa, reverse a)) case "failed" => "failed" + reverse_!(u::$) - if maxD case NNI and zero? maxD then - err:String:= concat [_ - "Guess: homogeneous requires that maxShift/maxDerivative",_ - " is at least one or maxSubst is at least two" ] - error err -\end{chunk} + if S has OrderedSet then + a < b == + la := listOfMonoms a + lb := listOfMonoms b + na: Integer := #la + nb: Integer := #lb + while na > 0 and nb > 0 repeat + la.first.gen > lb.first.gen => return false + la.first.gen < lb.first.gen => return true + if la.first.exp = lb.first.exp then + la:=rest la + lb:=rest lb + na:=na - 1 + nb:=nb - 1 + else if la.first.exp > lb.first.exp then + la:=concat([la.first.gen, + (la.first.exp - lb.first.exp)::NNI], rest lb) + lb:=rest lb + nb:=nb - 1 + else + lb:=concat([lb.first.gen, + (lb.first.exp-la.first.exp)::NNI], rest la) + la:=rest la + na:=na-1 + empty? la and not empty? lb -\begin{chunk}{COQ GOPT0} -(* domain GOPT0 *) -(* *) \end{chunk} -\begin{chunk}{GOPT0.dotabb} -"GOPT0" [color="#88FF44",href="bookvol10.3.pdf#nameddest=GOPT0"] -"STRING" [color="#88FF44",href="bookvol10.3.pdf#nameddest=STRING"] -"GOPT0" -> "STRING" +\begin{chunk}{FMONOID.dotabb} +"FMONOID" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FMONOID"] +"FLAGG" [color="#4488FF",href="bookvol10.2.pdf#nameddest=FLAGG"] +"FLAGG-" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FLAGG"] +"FMONOID" -> "FLAGG-" +"FMONOID" -> "FLAGG" \end{chunk} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Chapter H} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain HASHTBL HashTable} +\section{domain FNLA FreeNilpotentLie} -\begin{chunk}{HashTable.input} +\begin{chunk}{FreeNilpotentLie.input} )set break resume -)sys rm -f HashTable.output -)spool HashTable.output +)sys rm -f FreeNilpotentLie.output +)spool FreeNilpotentLie.output )set message test on )set message auto off )clear all --S 1 of 1 -)show HashTable +)show FreeNilpotentLie --R ---R HashTable(Key: SetCategory,Entry: SetCategory,hashfn: String) is a domain constructor ---R Abbreviation for HashTable is HASHTBL ---R This constructor is not exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for HASHTBL +--R FreeNilpotentLie(n: NonNegativeInteger,class: NonNegativeInteger,R: CommutativeRing) is a domain constructor +--R Abbreviation for FreeNilpotentLie is FNLA +--R This constructor is exposed in this frame. +--R Issue )edit bookvol10.3.pamphlet to see algebra source code for FNLA --R --R------------------------------- Operations -------------------------------- ---R copy : % -> % dictionary : () -> % ---R elt : (%,Key,Entry) -> Entry ?.? : (%,Key) -> Entry ---R empty : () -> % empty? : % -> Boolean ---R entries : % -> List(Entry) eq? : (%,%) -> Boolean ---R index? : (Key,%) -> Boolean indices : % -> List(Key) ---R key? : (Key,%) -> Boolean keys : % -> List(Key) ---R map : ((Entry -> Entry),%) -> % qelt : (%,Key) -> Entry ---R sample : () -> % setelt : (%,Key,Entry) -> Entry ---R table : () -> % ---R #? : % -> NonNegativeInteger if $ has finiteAggregate ---R ?=? : (%,%) -> Boolean if Record(key: Key,entry: Entry) has SETCAT or Entry has SETCAT ---R any? : ((Entry -> Boolean),%) -> Boolean if $ has finiteAggregate ---R any? : ((Record(key: Key,entry: Entry) -> Boolean),%) -> Boolean if $ has finiteAggregate ---R bag : List(Record(key: Key,entry: Entry)) -> % ---R coerce : % -> OutputForm if Record(key: Key,entry: Entry) has SETCAT or Entry has SETCAT ---R construct : List(Record(key: Key,entry: Entry)) -> % ---R convert : % -> InputForm if Record(key: Key,entry: Entry) has KONVERT(INFORM) ---R count : ((Entry -> Boolean),%) -> NonNegativeInteger if $ has finiteAggregate ---R count : (Entry,%) -> NonNegativeInteger if $ has finiteAggregate and Entry has SETCAT ---R count : (Record(key: Key,entry: Entry),%) -> NonNegativeInteger if $ has finiteAggregate and Record(key: Key,entry: Entry) has SETCAT ---R count : ((Record(key: Key,entry: Entry) -> Boolean),%) -> NonNegativeInteger if $ has finiteAggregate ---R dictionary : List(Record(key: Key,entry: Entry)) -> % ---R entry? : (Entry,%) -> Boolean if $ has finiteAggregate and Entry has SETCAT ---R eval : (%,List(Equation(Entry))) -> % if Entry has EVALAB(Entry) and Entry has SETCAT ---R eval : (%,Equation(Entry)) -> % if Entry has EVALAB(Entry) and Entry has SETCAT ---R eval : (%,Entry,Entry) -> % if Entry has EVALAB(Entry) and Entry has SETCAT ---R eval : (%,List(Entry),List(Entry)) -> % if Entry has EVALAB(Entry) and Entry has SETCAT ---R eval : (%,List(Record(key: Key,entry: Entry)),List(Record(key: Key,entry: Entry))) -> % if Record(key: Key,entry: Entry) has EVALAB(Record(key: Key,entry: Entry)) and Record(key: Key,entry: Entry) has SETCAT ---R eval : (%,Record(key: Key,entry: Entry),Record(key: Key,entry: Entry)) -> % if Record(key: Key,entry: Entry) has EVALAB(Record(key: Key,entry: Entry)) and Record(key: Key,entry: Entry) has SETCAT ---R eval : (%,Equation(Record(key: Key,entry: Entry))) -> % if Record(key: Key,entry: Entry) has EVALAB(Record(key: Key,entry: Entry)) and Record(key: Key,entry: Entry) has SETCAT ---R eval : (%,List(Equation(Record(key: Key,entry: Entry)))) -> % if Record(key: Key,entry: Entry) has EVALAB(Record(key: Key,entry: Entry)) and Record(key: Key,entry: Entry) has SETCAT ---R every? : ((Entry -> Boolean),%) -> Boolean if $ has finiteAggregate ---R every? : ((Record(key: Key,entry: Entry) -> Boolean),%) -> Boolean if $ has finiteAggregate ---R extract! : % -> Record(key: Key,entry: Entry) ---R fill! : (%,Entry) -> % if $ has shallowlyMutable ---R find : ((Record(key: Key,entry: Entry) -> Boolean),%) -> Union(Record(key: Key,entry: Entry),"failed") ---R first : % -> Entry if Key has ORDSET ---R hash : % -> SingleInteger if Record(key: Key,entry: Entry) has SETCAT or Entry has SETCAT ---R insert! : (Record(key: Key,entry: Entry),%) -> % ---R inspect : % -> Record(key: Key,entry: Entry) ---R latex : % -> String if Record(key: Key,entry: Entry) has SETCAT or Entry has SETCAT ---R less? : (%,NonNegativeInteger) -> Boolean ---R map : (((Entry,Entry) -> Entry),%,%) -> % ---R map : ((Record(key: Key,entry: Entry) -> Record(key: Key,entry: Entry)),%) -> % ---R map! : ((Entry -> Entry),%) -> % if $ has shallowlyMutable ---R map! : ((Record(key: Key,entry: Entry) -> Record(key: Key,entry: Entry)),%) -> % if $ has shallowlyMutable ---R maxIndex : % -> Key if Key has ORDSET ---R member? : (Entry,%) -> Boolean if $ has finiteAggregate and Entry has SETCAT ---R member? : (Record(key: Key,entry: Entry),%) -> Boolean if $ has finiteAggregate and Record(key: Key,entry: Entry) has SETCAT ---R members : % -> List(Entry) if $ has finiteAggregate ---R members : % -> List(Record(key: Key,entry: Entry)) if $ has finiteAggregate ---R minIndex : % -> Key if Key has ORDSET ---R more? : (%,NonNegativeInteger) -> Boolean ---R parts : % -> List(Entry) if $ has finiteAggregate ---R parts : % -> List(Record(key: Key,entry: Entry)) if $ has finiteAggregate ---R qsetelt! : (%,Key,Entry) -> Entry if $ has shallowlyMutable ---R reduce : (((Record(key: Key,entry: Entry),Record(key: Key,entry: Entry)) -> Record(key: Key,entry: Entry)),%) -> Record(key: Key,entry: Entry) if $ has finiteAggregate ---R reduce : (((Record(key: Key,entry: Entry),Record(key: Key,entry: Entry)) -> Record(key: Key,entry: Entry)),%,Record(key: Key,entry: Entry)) -> Record(key: Key,entry: Entry) if $ has finiteAggregate ---R reduce : (((Record(key: Key,entry: Entry),Record(key: Key,entry: Entry)) -> Record(key: Key,entry: Entry)),%,Record(key: Key,entry: Entry),Record(key: Key,entry: Entry)) -> Record(key: Key,entry: Entry) if $ has finiteAggregate and Record(key: Key,entry: Entry) has SETCAT ---R remove : ((Record(key: Key,entry: Entry) -> Boolean),%) -> % if $ has finiteAggregate ---R remove : (Record(key: Key,entry: Entry),%) -> % if $ has finiteAggregate and Record(key: Key,entry: Entry) has SETCAT ---R remove! : (Key,%) -> Union(Entry,"failed") ---R remove! : ((Record(key: Key,entry: Entry) -> Boolean),%) -> % if $ has finiteAggregate ---R remove! : (Record(key: Key,entry: Entry),%) -> % if $ has finiteAggregate ---R removeDuplicates : % -> % if $ has finiteAggregate and Record(key: Key,entry: Entry) has SETCAT ---R search : (Key,%) -> Union(Entry,"failed") ---R select : ((Record(key: Key,entry: Entry) -> Boolean),%) -> % if $ has finiteAggregate ---R select! : ((Record(key: Key,entry: Entry) -> Boolean),%) -> % if $ has finiteAggregate ---R size? : (%,NonNegativeInteger) -> Boolean ---R swap! : (%,Key,Key) -> Void if $ has shallowlyMutable ---R table : List(Record(key: Key,entry: Entry)) -> % ---R ?~=? : (%,%) -> Boolean if Record(key: Key,entry: Entry) has SETCAT or Entry has SETCAT +--R ?*? : (R,%) -> % ?*? : (%,R) -> % +--R ?*? : (%,%) -> % ?*? : (Integer,%) -> % +--R ?*? : (NonNegativeInteger,%) -> % ?*? : (PositiveInteger,%) -> % +--R ?**? : (%,PositiveInteger) -> % ?+? : (%,%) -> % +--R ?-? : (%,%) -> % -? : % -> % +--R ?=? : (%,%) -> Boolean 0 : () -> % +--R antiCommutator : (%,%) -> % associator : (%,%,%) -> % +--R coerce : % -> OutputForm commutator : (%,%) -> % +--R deepExpand : % -> OutputForm dimension : () -> NonNegativeInteger +--R generator : NonNegativeInteger -> % hash : % -> SingleInteger +--R latex : % -> String sample : () -> % +--R shallowExpand : % -> OutputForm zero? : % -> Boolean +--R ?~=? : (%,%) -> Boolean +--R leftPower : (%,PositiveInteger) -> % +--R plenaryPower : (%,PositiveInteger) -> % +--R rightPower : (%,PositiveInteger) -> % +--R subtractIfCan : (%,%) -> Union(%,"failed") --R --E 1 )spool )lisp (bye) \end{chunk} -\begin{chunk}{HashTable.help} +\begin{chunk}{FreeNilpotentLie.help} ==================================================================== -HashTable examples +FreeNilpotentLie examples ==================================================================== -This domain provides access to the underlying Lisp hash tables. -By varying the hashfn parameter, tables suited for different -purposes can be obtained. +Generate the Free Lie Algebra over a ring R with identity; +A P. Hall basis is generated by a package call to HallBasis. See Also: -o )show HashTable +o )show FreeNilpotentLie \end{chunk} -\pagehead{HashTable}{HASHTBL} -\pagepic{ps/v103hashtable.ps}{HASHTBL}{1.00} +\pagehead{FreeNilpotentLie}{FNLA} +\pagepic{ps/v103freenilpotentlie.ps}{FNLA}{1.00} {\bf See}\\ -\pageto{InnerTable}{INTABL} -\pageto{Table}{TABLE} -\pageto{EqTable}{EQTBL} -\pageto{StringTable}{STRTBL} -\pageto{GeneralSparseTable}{GSTBL} -\pageto{SparseTable}{STBL} +\pageto{OrdSetInts}{OSI} +\pageto{Commutator}{COMM} {\bf Exports:}\\ \begin{tabular}{lllll} -\cross{HASHTBL}{any?} & -\cross{HASHTBL}{bag} & -\cross{HASHTBL}{coerce} & -\cross{HASHTBL}{construct} & -\cross{HASHTBL}{convert} \\ -\cross{HASHTBL}{copy} & -\cross{HASHTBL}{count} & -\cross{HASHTBL}{dictionary} & -\cross{HASHTBL}{entry?} & -\cross{HASHTBL}{elt} \\ -\cross{HASHTBL}{empty} & -\cross{HASHTBL}{empty?} & -\cross{HASHTBL}{entries} & -\cross{HASHTBL}{eq?} & -\cross{HASHTBL}{eval} \\ -\cross{HASHTBL}{every?} & -\cross{HASHTBL}{extract!} & -\cross{HASHTBL}{fill!} & -\cross{HASHTBL}{find} & -\cross{HASHTBL}{first} \\ -\cross{HASHTBL}{hash} & -\cross{HASHTBL}{index?} & -\cross{HASHTBL}{indices} & -\cross{HASHTBL}{insert!} & -\cross{HASHTBL}{inspect} \\ -\cross{HASHTBL}{key?} & -\cross{HASHTBL}{keys} & -\cross{HASHTBL}{latex} & -\cross{HASHTBL}{less?} & -\cross{HASHTBL}{map} \\ -\cross{HASHTBL}{map!} & -\cross{HASHTBL}{maxIndex} & -\cross{HASHTBL}{member?} & -\cross{HASHTBL}{members} & -\cross{HASHTBL}{minIndex} \\ -\cross{HASHTBL}{more?} & -\cross{HASHTBL}{parts} & -\cross{HASHTBL}{qelt} & -\cross{HASHTBL}{qsetelt!} & -\cross{HASHTBL}{reduce} \\ -\cross{HASHTBL}{remove} & -\cross{HASHTBL}{remove!} & -\cross{HASHTBL}{removeDuplicates} & -\cross{HASHTBL}{sample} & -\cross{HASHTBL}{search} \\ -\cross{HASHTBL}{select} & -\cross{HASHTBL}{select!} & -\cross{HASHTBL}{setelt} & -\cross{HASHTBL}{size?} & -\cross{HASHTBL}{swap!} \\ -\cross{HASHTBL}{table} & -\cross{HASHTBL}{\#{}?} & -\cross{HASHTBL}{?=?} & -\cross{HASHTBL}{?\~{}=?} & -\cross{HASHTBL}{?.?} +\cross{FNLA}{0} & +\cross{FNLA}{antiCommutator} & +\cross{FNLA}{associator} & +\cross{FNLA}{coerce} & +\cross{FNLA}{commutator} \\ +\cross{FNLA}{deepExpand} & +\cross{FNLA}{dimension} & +\cross{FNLA}{generator} & +\cross{FNLA}{hash} & +\cross{FNLA}{latex} \\ +\cross{FNLA}{leftPower} & +\cross{FNLA}{plenaryPower} & +\cross{FNLA}{rightPower} & +\cross{FNLA}{sample} & +\cross{FNLA}{shallowExpand} \\ +\cross{FNLA}{subtractIfCan} & +\cross{FNLA}{zero?} & +\cross{FNLA}{?\~{}=?} & +\cross{FNLA}{?*?} & +\cross{FNLA}{?**?} \\ +\cross{FNLA}{?+?} & +\cross{FNLA}{?-?} & +\cross{FNLA}{-?} & +\cross{FNLA}{?=?} & \end{tabular} -\begin{chunk}{domain HASHTBL HashTable} -)abbrev domain HASHTBL HashTable -++ Author: Stephen M. Watt -++ Date Created: 1985 -++ Date Last Updated: June 21, 1991 +\begin{chunk}{domain FNLA FreeNilpotentLie} +)abbrev domain FNLA FreeNilpotentLie +++ Author: Larry Lambe +++ Date Created: July 1988 +++ Date Last Updated: March 13 1991 ++ Description: -++ This domain provides access to the underlying Lisp hash tables. -++ By varying the hashfn parameter, tables suited for different -++ purposes can be obtained. +++ Generate the Free Lie Algebra over a ring R with identity; +++ A P. Hall basis is generated by a package call to HallBasis. -HashTable(Key, Entry, hashfn): Exports == Implementation where - Key, Entry: SetCategory - hashfn: String -- Union("EQ", "UEQUAL", "CVEC", "ID") +FreeNilpotentLie(n:NNI,class:NNI,R: CommutativeRing): Export == Implement where + B ==> Boolean + Com ==> Commutator + HB ==> HallBasis + I ==> Integer + NNI ==> NonNegativeInteger + O ==> OutputForm + OSI ==> OrdSetInts + FM ==> FreeModule(R,OSI) + VI ==> Vector Integer + VLI ==> Vector List Integer + lC ==> leadingCoefficient + lS ==> leadingSupport - Exports ==> TableAggregate(Key, Entry) with - finiteAggregate + Export ==> NonAssociativeAlgebra(R) with + dimension : () -> NNI + ++ dimension() is the rank of this Lie algebra + deepExpand : % -> O + ++ deepExpand(x) is not documented + shallowExpand : % -> O + ++ shallowExpand(x) is not documented + generator : NNI -> % + ++ generator(i) is the ith Hall Basis element - Implementation ==> add - Pair ==> Record(key: Key, entry: Entry) - Ex ==> OutputForm - failMsg := GENSYM()$Lisp + Implement ==> FM add + Rep := FM + f,g : % - t1 = t2 == EQ(t1, t2)$Lisp - keys t == HKEYS(t)$Lisp - # t == HASH_-TABLE_-COUNT(t)$Lisp - setelt(t, k, e) == HPUT(t,k,e)$Lisp - remove_!(k:Key, t:%) == - r := HGET(t,k,failMsg)$Lisp - not EQ(r,failMsg)$Lisp => - HREM(t, k)$Lisp - r pretend Entry - "failed" + coms:VLI + coms := generate(n,class)$HB - empty() == - MAKE_-HASHTABLE(INTERN(hashfn)$Lisp, - INTERN("STRONG")$Lisp)$Lisp + dimension == #coms - search(k:Key, t:%) == - r := HGET(t, k, failMsg)$Lisp - not EQ(r, failMsg)$Lisp => r pretend Entry - "failed" + -- have(left,right) is a lookup function for basic commutators + -- already generated; if the nth basic commutator is + -- [left,wt,right], then have(left,right) = n + have : (I,I) -> % + have(i,j) == + wt:I := coms(i).2 + coms(j).2 + wt > class => 0 + lo:I := 1 + hi:I := dimension + while hi-lo > 1 repeat + mid:I := (hi+lo) quo 2 + if coms(mid).2 < wt then lo := mid else hi := mid + while coms(hi).1 < i repeat hi := hi + 1 + while coms(hi).3 < j repeat hi := hi + 1 + monomial(1,hi::OSI)$FM + + generator(i) == + i > dimension => 0$Rep + monomial(1,i::OSI)$FM + + putIn : I -> % + putIn(i) == + monomial(1$R,i::OSI)$FM + + brkt : (I,%) -> % + brkt(k,f) == + f = 0 => 0 + dg:I := value lS f + reductum(f) = 0 => + k = dg => 0 + k > dg => -lC(f)*brkt(dg, putIn(k)) + inHallBasis?(n,k,dg,coms(dg).1) => lC(f)*have(k, dg) + lC(f)*( brkt(coms(dg).1, _ + brkt(k,putIn coms(dg).3)) - brkt(coms(dg).3, _ + brkt(k,putIn coms(dg).1) )) + brkt(k,monomial(lC f,lS f)$FM)+brkt(k,reductum f) + + f*g == + reductum(f) = 0 => + lC(f)*brkt(value(lS f),g) + monomial(lC f,lS f)$FM*g + reductum(f)*g + + -- an auxilliary function used for output of Free Lie algebra + -- elements (see expand) + Fac : I -> Com + Fac(m) == + coms(m).1 = 0 => mkcomm(m)$Com + mkcomm(Fac coms(m).1, Fac coms(m).3) + + shallowE : (R,OSI) -> O + shallowE(r,s) == + k := value s + r = 1 => + k <= n => s::O + mkcomm(mkcomm(coms(k).1)$Com,mkcomm(coms(k).3)$Com)$Com::O + k <= n => r::O * s::O + r::O * mkcomm(mkcomm(coms(k).1)$Com,mkcomm(coms(k).3)$Com)$Com::O + + shallowExpand(f) == + f = 0 => 0::O + reductum(f) = 0 => shallowE(lC f,lS f) + shallowE(lC f,lS f) + shallowExpand(reductum f) + + deepExpand(f) == + f = 0 => 0::O + reductum(f) = 0 => + lC(f)=1 => Fac(value(lS f))::O + lC(f)::O * Fac(value(lS f))::O + lC(f)=1 => Fac(value(lS f))::O + deepExpand(reductum f) + lC(f)::O * Fac(value(lS f))::O + deepExpand(reductum f) \end{chunk} -\begin{chunk}{COQ HASHTBL} -(* domain HASHTBL *) +\begin{chunk}{COQ FNLA} +(* domain FNLA *) (* + FM add + Rep := FM + f,g : % + + coms:VLI + coms := generate(n,class)$HB + + dimension == #coms + + -- have(left,right) is a lookup function for basic commutators + -- already generated; if the nth basic commutator is + -- [left,wt,right], then have(left,right) = n + have : (I,I) -> % + have(i,j) == + wt:I := coms(i).2 + coms(j).2 + wt > class => 0 + lo:I := 1 + hi:I := dimension + while hi-lo > 1 repeat + mid:I := (hi+lo) quo 2 + if coms(mid).2 < wt then lo := mid else hi := mid + while coms(hi).1 < i repeat hi := hi + 1 + while coms(hi).3 < j repeat hi := hi + 1 + monomial(1,hi::OSI)$FM + + generator(i) == + i > dimension => 0$Rep + monomial(1,i::OSI)$FM + + putIn : I -> % + putIn(i) == + monomial(1$R,i::OSI)$FM + + brkt : (I,%) -> % + brkt(k,f) == + f = 0 => 0 + dg:I := value lS f + reductum(f) = 0 => + k = dg => 0 + k > dg => -lC(f)*brkt(dg, putIn(k)) + inHallBasis?(n,k,dg,coms(dg).1) => lC(f)*have(k, dg) + lC(f)*( brkt(coms(dg).1, _ + brkt(k,putIn coms(dg).3)) - brkt(coms(dg).3, _ + brkt(k,putIn coms(dg).1) )) + brkt(k,monomial(lC f,lS f)$FM)+brkt(k,reductum f) + + f*g == + reductum(f) = 0 => + lC(f)*brkt(value(lS f),g) + monomial(lC f,lS f)$FM*g + reductum(f)*g + + -- an auxilliary function used for output of Free Lie algebra + -- elements (see expand) + Fac : I -> Com + Fac(m) == + coms(m).1 = 0 => mkcomm(m)$Com + mkcomm(Fac coms(m).1, Fac coms(m).3) + + shallowE : (R,OSI) -> O + shallowE(r,s) == + k := value s + r = 1 => + k <= n => s::O + mkcomm(mkcomm(coms(k).1)$Com,mkcomm(coms(k).3)$Com)$Com::O + k <= n => r::O * s::O + r::O * mkcomm(mkcomm(coms(k).1)$Com,mkcomm(coms(k).3)$Com)$Com::O + + shallowExpand(f) == + f = 0 => 0::O + reductum(f) = 0 => shallowE(lC f,lS f) + shallowE(lC f,lS f) + shallowExpand(reductum f) + + deepExpand(f) == + f = 0 => 0::O + reductum(f) = 0 => + lC(f)=1 => Fac(value(lS f))::O + lC(f)::O * Fac(value(lS f))::O + lC(f)=1 => Fac(value(lS f))::O + deepExpand(reductum f) + lC(f)::O * Fac(value(lS f))::O + deepExpand(reductum f) + *) \end{chunk} -\begin{chunk}{HASHTBL.dotabb} -"HASHTBL" [color="#88FF44",href="bookvol10.3.pdf#nameddest=HASHTBL"] -"TBAGG" [color="#4488FF",href="bookvol10.2.pdf#nameddest=TBAGG"] -"HASHTBL" -> "TBAGG" +\begin{chunk}{FNLA.dotabb} +"FNLA" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FNLA"] +"IVECTOR" [color="#88FF44",href="bookvol10.3.pdf#nameddest=IVECTOR"] +"FNLA" -> "IVECTOR" \end{chunk} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{domain HEAP Heap} +\section{domain FPARFRAC FullPartialFractionExpansion} -\begin{chunk}{Heap.input} +\begin{chunk}{FullPartialFractionExpansion.input} )set break resume -)sys rm -f Heap.output -)spool Heap.output +)sys rm -f FullPartialFractionExpansion.output +)spool FullPartialFractionExpansion.output )set message test on )set message auto off )clear all ---S 1 of 42 -a:Heap INT:= heap [1,2,3,4,5] +--S 1 of 17 +Fx := FRAC UP(x, FRAC INT) --R --R ---R (1) [5,4,2,1,3] ---R Type: Heap(Integer) +--R (1) Fraction(UnivariatePolynomial(x,Fraction(Integer))) +--R Type: Domain --E 1 ---S 2 of 42 -bag([1,2,3,4,5])$Heap(INT) +--S 2 of 17 +f : Fx := 36 / (x**5-2*x**4-2*x**3+4*x**2+x-2) --R --R ---R (2) [5,4,3,1,2] ---R Type: Heap(Integer) +--R 36 +--R (2) ---------------------------- +--R 5 4 3 2 +--R x - 2x - 2x + 4x + x - 2 +--R Type: Fraction(UnivariatePolynomial(x,Fraction(Integer))) --E 2 ---S 3 of 42 -c:=copy a +--S 3 of 17 +g := fullPartialFraction f --R --R ---R (3) [5,4,2,1,3] ---R Type: Heap(Integer) +--R 4 4 --+ - 3%A - 6 +--R (3) ----- - ----- + > --------- +--R x - 2 x + 1 --+ 2 +--R 2 (x - %A) +--R %A - 1= 0 +--RType: FullPartialFractionExpansion(Fraction(Integer),UnivariatePolynomial(x,Fraction(Integer))) --E 3 ---S 4 of 42 -empty? a +--S 4 of 17 +g :: Fx --R --R ---R (4) false ---R Type: Boolean +--R 36 +--R (4) ---------------------------- +--R 5 4 3 2 +--R x - 2x - 2x + 4x + x - 2 +--R Type: Fraction(UnivariatePolynomial(x,Fraction(Integer))) --E 4 ---S 5 of 42 -b:=empty()$(Heap INT) +--S 5 of 17 +g5 := D(g, 5) --R --R ---R (5) [] ---R Type: Heap(Integer) +--R 480 480 --+ 2160%A + 4320 +--R (5) - -------- + -------- + > ------------- +--R 6 6 --+ 7 +--R (x - 2) (x + 1) 2 (x - %A) +--R %A - 1= 0 +--RType: FullPartialFractionExpansion(Fraction(Integer),UnivariatePolynomial(x,Fraction(Integer))) --E 5 ---S 6 of 42 -empty? b +--S 6 of 17 +f5 := D(f, 5) --R --R ---R (6) true ---R Type: Boolean +--R (6) +--R 10 9 8 7 6 +--R - 544320x + 4354560x - 14696640x + 28615680x - 40085280x +--R + +--R 5 4 3 2 +--R 46656000x - 39411360x + 18247680x - 5870880x + 3317760x + 246240 +--R / +--R 20 19 18 17 16 15 14 13 +--R x - 12x + 53x - 76x - 159x + 676x - 391x - 1596x +--R + +--R 12 11 10 9 8 7 6 5 +--R 2527x + 1148x - 4977x + 1372x + 4907x - 3444x - 2381x + 2924x +--R + +--R 4 3 2 +--R 276x - 1184x + 208x + 192x - 64 +--R Type: Fraction(UnivariatePolynomial(x,Fraction(Integer))) --E 6 ---S 7 of 42 -eq?(a,c) +--S 7 of 17 +g5::Fx - f5 --R --R ---R (7) false ---R Type: Boolean +--R (7) 0 +--R Type: Fraction(UnivariatePolynomial(x,Fraction(Integer))) --E 7 ---S 8 of 42 -extract! a ---R ---R ---R (8) 5 ---R Type: PositiveInteger ---E 8 - ---S 8 of 42 -h:=heap [17,-4,9,-11,2,7,-7] +--S 8 of 17 +f : Fx := (x**5 * (x-1)) / ((x**2 + x + 1)**2 * (x-2)**3) --R --R ---R (9) [17,2,9,- 11,- 4,7,- 7] ---R Type: Heap(Integer) +--R 6 5 +--R x - x +--R (8) ----------------------------------- +--R 7 6 5 3 2 +--R x - 4x + 3x + 9x - 6x - 4x - 8 +--R Type: Fraction(UnivariatePolynomial(x,Fraction(Integer))) --E 8 ---S 9 of 42 -[extract!(h) while not empty?(h)] +--S 9 of 17 +g := fullPartialFraction f --R --R ---R (10) [17,9,7,2,- 4,- 7,- 11] ---R Type: List(Integer) +--R (9) +--R 1952 464 32 179 135 +--R ---- --- -- - ---- %A + ---- +--R 2401 343 49 --+ 2401 2401 +--R ------ + -------- + -------- + > ---------------- +--R x - 2 2 3 --+ x - %A +--R (x - 2) (x - 2) 2 +--R %A + %A + 1= 0 +--R + +--R 37 20 +--R ---- %A + ---- +--R --+ 1029 1029 +--R > -------------- +--R --+ 2 +--R 2 (x - %A) +--R %A + %A + 1= 0 +--RType: FullPartialFractionExpansion(Fraction(Integer),UnivariatePolynomial(x,Fraction(Integer))) --E 9 ---S 10 of 42 -heapsort(x) == (empty? x => []; cons(extract!(x),heapsort x)) +--S 10 of 17 +g :: Fx - f --R ---R Type: Void +--R +--R (10) 0 +--R Type: Fraction(UnivariatePolynomial(x,Fraction(Integer))) --E 10 ---S 11 of 42 -h1 := heapsort heap [17,-4,9,-11,2,7,-7] +--S 11 of 17 +f : Fx := (2*x**7-7*x**5+26*x**3+8*x) / (x**8-5*x**6+6*x**4+4*x**2-8) --R ---R Compiling function heapsort with type Heap(Integer) -> List(Integer) ---R --R ---R (12) [17,9,7,2,- 4,- 7,- 11] ---R Type: List(Integer) +--R 7 5 3 +--R 2x - 7x + 26x + 8x +--R (11) ------------------------ +--R 8 6 4 2 +--R x - 5x + 6x + 4x - 8 +--R Type: Fraction(UnivariatePolynomial(x,Fraction(Integer))) --E 11 ---S 12 of 42 -(a=c)@Boolean +--S 12 of 17 +g := fullPartialFraction f --R --R ---R (13) false ---R Type: Boolean +--R 1 1 +--R - - +--R --+ 2 --+ 1 --+ 2 +--R (12) > ------ + > --------- + > ------ +--R --+ x - %A --+ 3 --+ x - %A +--R 2 2 (x - %A) 2 +--R %A - 2= 0 %A - 2= 0 %A + 1= 0 +--RType: FullPartialFractionExpansion(Fraction(Integer),UnivariatePolynomial(x,Fraction(Integer))) --E 12 ---S 13 of 42 -(a~=c) +--S 13 of 17 +g :: Fx - f --R --R ---R (14) true ---R Type: Boolean +--R (13) 0 +--R Type: Fraction(UnivariatePolynomial(x,Fraction(Integer))) --E 13 ---S 14 of 42 -a +--S 14 of 17 +f:Fx := x**3 / (x**21 + 2*x**20 + 4*x**19 + 7*x**18 + 10*x**17 + 17*x**16 + 22*x**15 + 30*x**14 + 36*x**13 + 40*x**12 + 47*x**11 + 46*x**10 + 49*x**9 + 43*x**8 + 38*x**7 + 32*x**6 + 23*x**5 + 19*x**4 + 10*x**3 + 7*x**2 + 2*x + 1) --R --R ---R (15) [4,3,2,1] ---R Type: Heap(Integer) +--R (14) +--R 3 +--R x +--R / +--R 21 20 19 18 17 16 15 14 13 12 +--R x + 2x + 4x + 7x + 10x + 17x + 22x + 30x + 36x + 40x +--R + +--R 11 10 9 8 7 6 5 4 3 2 +--R 47x + 46x + 49x + 43x + 38x + 32x + 23x + 19x + 10x + 7x + 2x +--R + +--R 1 +--R Type: Fraction(UnivariatePolynomial(x,Fraction(Integer))) --E 14 ---S 15 of 42 -inspect a +--S 15 of 17 +g := fullPartialFraction f --R --R ---R (16) 4 ---R Type: PositiveInteger +--R (15) +--R 1 1 19 +--R - %A - %A - -- +--R --+ 2 --+ 9 27 +--R > ------ + > --------- +--R --+ x - %A --+ x - %A +--R 2 2 +--R %A + 1= 0 %A + %A + 1= 0 +--R + +--R 1 1 +--R -- %A - -- +--R --+ 27 27 +--R > ---------- +--R --+ 2 +--R 2 (x - %A) +--R %A + %A + 1= 0 +--R + +--R SIGMA +--R 5 2 +--R %A + %A + 1= 0 +--R , +--R 96556567040 4 420961732891 3 59101056149 2 +--R - ------------ %A + ------------ %A - ------------ %A +--R 912390759099 912390759099 912390759099 +--R + +--R 373545875923 529673492498 +--R - ------------ %A + ------------ +--R 912390759099 912390759099 +--R / +--R x - %A +--R + +--R SIGMA +--R 5 2 +--R %A + %A + 1= 0 +--R , +--R 5580868 4 2024443 3 4321919 2 84614 5070620 +--R - -------- %A - -------- %A + -------- %A - ------- %A - -------- +--R 94070601 94070601 94070601 1542141 94070601 +--R -------------------------------------------------------------------- +--R 2 +--R (x - %A) +--R + +--R SIGMA +--R 5 2 +--R %A + %A + 1= 0 +--R , +--R 1610957 4 2763014 3 2016775 2 266953 4529359 +--R -------- %A + -------- %A - -------- %A + -------- %A + -------- +--R 94070601 94070601 94070601 94070601 94070601 +--R ------------------------------------------------------------------- +--R 3 +--R (x - %A) +--RType: FullPartialFractionExpansion(Fraction(Integer),UnivariatePolynomial(x,Fraction(Integer))) --E 15 ---S 16 of 42 -insert!(9,a) +--S 16 of 17 +g :: Fx - f --R --R ---R (17) [9,4,2,1,3] ---R Type: Heap(Integer) +--R (16) 0 +--R Type: Fraction(UnivariatePolynomial(x,Fraction(Integer))) --E 16 ---S 17 of 42 -map(x+->x+10,a) ---R ---R ---R (18) [19,14,12,11,13] ---R Type: Heap(Integer) ---E 17 - ---S 18 of 42 -a ---R ---R ---R (19) [9,4,2,1,3] ---R Type: Heap(Integer) ---E 18 - ---S 19 of 42 -map!(x+->x+10,a) ---R ---R ---R (20) [19,14,12,11,13] ---R Type: Heap(Integer) ---E 19 - ---S 20 of 42 -a ---R ---R ---R (21) [19,14,12,11,13] ---R Type: Heap(Integer) ---E 20 - ---S 21 of 42 -max a ---R ---R ---R (22) 19 ---R Type: PositiveInteger ---E 21 - ---S 22 of 42 -merge(a,c) ---R ---R ---R (23) [19,14,12,11,13,5,4,2,1,3] ---R Type: Heap(Integer) ---E 22 - ---S 23 of 42 -a ---R ---R ---R (24) [19,14,12,11,13] ---R Type: Heap(Integer) ---E 23 - ---S 24 of 42 -merge!(a,c) ---R ---R ---R (25) [19,14,12,11,13,5,4,2,1,3] ---R Type: Heap(Integer) ---E 24 - ---S 25 of 42 -a ---R ---R ---R (26) [19,14,12,11,13,5,4,2,1,3] ---R Type: Heap(Integer) ---E 25 - ---S 26 of 42 -c ---R ---R ---R (27) [5,4,2,1,3] ---R Type: Heap(Integer) ---E 26 - ---S 27 of 42 -sample()$Heap(INT) ---R ---R ---R (28) [] ---R Type: Heap(Integer) ---E 27 - ---S 28 of 42 -#a ---R ---R ---R (29) 10 ---R Type: PositiveInteger ---E 28 - ---S 29 of 42 -any?(x+->(x=14),a) ---R ---R ---R (30) true ---R Type: Boolean ---E 29 - ---S 30 of 42 -every?(x+->(x=11),a) ---R ---R ---R (31) false ---R Type: Boolean ---E 30 - ---S 31 of 42 -parts a ---R ---R ---R (32) [19,14,12,11,13,5,4,2,1,3] ---R Type: List(Integer) ---E 31 - ---S 32 of 42 -size?(a,9) ---R ---R ---R (33) false ---R Type: Boolean ---E 32 - ---S 33 of 42 -more?(a,9) ---R ---R ---R (34) true ---R Type: Boolean ---E 33 - ---S 34 of 42 -less?(a,9) ---R ---R ---R (35) false ---R Type: Boolean ---E 34 - ---S 35 of 42 -members a ---R ---R ---R (36) [19,14,12,11,13,5,4,2,1,3] ---R Type: List(Integer) ---E 35 - ---S 36 of 42 -member?(14,a) ---R ---R ---R (37) true ---R Type: Boolean ---E 36 - ---S 37 of 42 -latex a ---R ---R ---R (38) "\mbox{\bf Unimplemented}" ---R Type: String ---E 37 - ---S 38 of 42 -hash a ---R ---R ---I (39) 36647017 ---R Type: SingleInteger ---E 38 - ---S 39 of 42 -count(14,a) ---R ---R ---R (40) 1 ---R Type: PositiveInteger ---E 39 - ---S 40 of 42 -count(x+->(x>13),a) ---R ---R ---R (41) 2 ---R Type: PositiveInteger ---E 40 - ---S 41 of 42 -coerce a ---R ---R ---R (42) [19,14,12,11,13,5,4,2,1,3] ---R Type: OutputForm ---E 41 - ---S 42 of 42 -)show Heap +--S 17 of 17 +)show FullPartialFractionExpansion --R ---R Heap(S: OrderedSet) is a domain constructor ---R Abbreviation for Heap is HEAP +--R FullPartialFractionExpansion(F: Join(Field,CharacteristicZero),UP: UnivariatePolynomialCategory(F)) is a domain constructor +--R Abbreviation for FullPartialFractionExpansion is FPARFRAC --R This constructor is exposed in this frame. ---R Issue )edit bookvol10.3.pamphlet to see algebra source code for HEAP +--R Issue )edit bookvol10.3.pamphlet to see algebra source code for FPARFRAC --R --R------------------------------- Operations -------------------------------- ---R bag : List(S) -> % copy : % -> % ---R empty : () -> % empty? : % -> Boolean ---R eq? : (%,%) -> Boolean extract! : % -> S ---R heap : List(S) -> % insert! : (S,%) -> % ---R inspect : % -> S latex : % -> String if S has SETCAT ---R map : ((S -> S),%) -> % max : % -> S ---R merge : (%,%) -> % merge! : (%,%) -> % ---R sample : () -> % ---R #? : % -> NonNegativeInteger if $ has finiteAggregate ---R ?=? : (%,%) -> Boolean if S has SETCAT ---R any? : ((S -> Boolean),%) -> Boolean if $ has finiteAggregate ---R coerce : % -> OutputForm if S has SETCAT ---R count : (S,%) -> NonNegativeInteger if $ has finiteAggregate and S has SETCAT ---R count : ((S -> Boolean),%) -> NonNegativeInteger if $ has finiteAggregate ---R eval : (%,List(S),List(S)) -> % if S has EVALAB(S) and S has SETCAT ---R eval : (%,S,S) -> % if S has EVALAB(S) and S has SETCAT ---R eval : (%,Equation(S)) -> % if S has EVALAB(S) and S has SETCAT ---R eval : (%,List(Equation(S))) -> % if S has EVALAB(S) and S has SETCAT ---R every? : ((S -> Boolean),%) -> Boolean if $ has finiteAggregate ---R hash : % -> SingleInteger if S has SETCAT ---R less? : (%,NonNegativeInteger) -> Boolean ---R map! : ((S -> S),%) -> % if $ has shallowlyMutable ---R member? : (S,%) -> Boolean if $ has finiteAggregate and S has SETCAT ---R members : % -> List(S) if $ has finiteAggregate ---R more? : (%,NonNegativeInteger) -> Boolean ---R parts : % -> List(S) if $ has finiteAggregate ---R size? : (%,NonNegativeInteger) -> Boolean ---R ?~=? : (%,%) -> Boolean if S has SETCAT +--R ?+? : (UP,%) -> % ?=? : (%,%) -> Boolean +--R D : (%,NonNegativeInteger) -> % D : % -> % +--R coerce : % -> OutputForm convert : % -> Fraction(UP) +--R differentiate : % -> % hash : % -> SingleInteger +--R latex : % -> String polyPart : % -> UP +--R ?~=? : (%,%) -> Boolean +--R construct : List(Record(exponent: NonNegativeInteger,center: UP,num: UP)) -> % +--R differentiate : (%,NonNegativeInteger) -> % +--R fracPart : % -> List(Record(exponent: NonNegativeInteger,center: UP,num: UP)) +--R fullPartialFraction : Fraction(UP) -> % --R ---E 42 +--E 17 )spool )lisp (bye) \end{chunk} -\begin{chunk}{Heap.help} +\begin{chunk}{FullPartialFractionExpansion.help} ==================================================================== -Heap examples +FullPartialFractionExpansion expansion ==================================================================== -The domain Heap(S) implements a priority queue of objects of type S -such that the operation extract! removes and returns the maximum -element. The implementation represents heaps as flexible arrays The -representation and algorithms give complexity of O(log(n)) for -insertion and extractions, and O(n) for construction. - -Create a heap of five elements: - - a:Heap INT:= heap [1,2,3,4,5] - [5,4,2,1,3] - -Use bag to convert a Bag into a Heap: - - bag([1,2,3,4,5])$Heap(INT) - [5,4,3,1,2] - -The operation copy can be used to copy a Heap: +The domain FullPartialFractionExpansion implements factor-free +conversion of quotients to full partial fractions. - c:=copy a - [5,4,2,1,3] +Our examples will all involve quotients of univariate polynomials +with rational number coefficients. -Use empty? to check if the heap is empty: + Fx := FRAC UP(x, FRAC INT) + Fraction UnivariatePolynomial(x,Fraction Integer) + Type: Domain - empty? a - false +Here is a simple-looking rational function. -Use empty to create a new, empty heap: - - b:=empty()$(Heap INT) - [] + f : Fx := 36 / (x**5-2*x**4-2*x**3+4*x**2+x-2) + 36 + ---------------------------- + 5 4 3 2 + x - 2x - 2x + 4x + x - 2 + Type: Fraction UnivariatePolynomial(x,Fraction Integer) -and we can see that the newly created heap is empty: +We use fullPartialFraction to convert it to an object of type +FullPartialFractionExpansion. - empty? b - true + g := fullPartialFraction f + 4 4 --+ - 3%A - 6 + ----- - ----- + > --------- + x - 2 x + 1 --+ 2 + 2 (x - %A) + %A - 1= 0 +Type: FullPartialFractionExpansion(Fraction Integer, + UnivariatePolynomial(x,Fraction Integer)) -The eq? function compares the reference of one heap to another: +Use a coercion to change it back into a quotient. - eq?(a,c) - false + g :: Fx + 36 + ---------------------------- + 5 4 3 2 + x - 2x - 2x + 4x + x - 2 + Type: Fraction UnivariatePolynomial(x,Fraction Integer) -The extract! function removes largest element of the heap: +Full partial fractions differentiate faster than rational functions. - extract! a - 5 + g5 := D(g, 5) + 480 480 --+ 2160%A + 4320 + - -------- + -------- + > ------------- + 6 6 --+ 7 + (x - 2) (x + 1) 2 (x - %A) + %A - 1= 0 +Type: FullPartialFractionExpansion(Fraction Integer, + UnivariatePolynomial(x,Fraction Integer)) -Now extract! elements repeatedly until none are left, collecting -the elements in a list. + f5 := D(f, 5) + 10 9 8 7 6 + - 544320x + 4354560x - 14696640x + 28615680x - 40085280x + + + 5 4 3 2 + 46656000x - 39411360x + 18247680x - 5870880x + 3317760x + 246240 + / + 20 19 18 17 16 15 14 13 + x - 12x + 53x - 76x - 159x + 676x - 391x - 1596x + + + 12 11 10 9 8 7 6 5 + 2527x + 1148x - 4977x + 1372x + 4907x - 3444x - 2381x + 2924x + + + 4 3 2 + 276x - 1184x + 208x + 192x - 64 + Type: Fraction UnivariatePolynomial(x,Fraction Integer) - [extract!(h) while not empty?(h)] - [9,7,3,2,- 4,- 7] - Type: List Integer +We can check that the two forms represent the same function. -Another way to produce the same result is by defining a heapsort function. + g5::Fx - f5 + 0 + Type: Fraction UnivariatePolynomial(x,Fraction Integer) - heapsort(x) == (empty? x => []; cons(extract!(x),heapsort x)) - Type: Void +Here are some examples that are more complicated. -Create another sample heap. + f : Fx := (x**5 * (x-1)) / ((x**2 + x + 1)**2 * (x-2)**3) + 6 5 + x - x + ----------------------------------- + 7 6 5 3 2 + x - 4x + 3x + 9x - 6x - 4x - 8 + Type: Fraction UnivariatePolynomial(x,Fraction Integer) - h1 := heap [17,-4,9,-11,2,7,-7] - [17,2,9,- 11,- 4,7,- 7] - Type: Heap Integer + g := fullPartialFraction f + 1952 464 32 179 135 + ---- --- -- - ---- %A + ---- + 2401 343 49 --+ 2401 2401 + ------ + -------- + -------- + > ---------------- + x - 2 2 3 --+ x - %A + (x - 2) (x - 2) 2 + %A + %A + 1= 0 + + + 37 20 + ---- %A + ---- + --+ 1029 1029 + > -------------- + --+ 2 + 2 (x - %A) + %A + %A + 1= 0 +Type: FullPartialFractionExpansion(Fraction Integer, + UnivariatePolynomial(x,Fraction Integer)) -Apply heapsort to present elements in order. + g :: Fx - f + 0 + Type: Fraction UnivariatePolynomial(x,Fraction Integer) - heapsort h1 - [17,9,7,2,- 4,- 7,- 11] - Type: List Integer + f : Fx := (2*x**7-7*x**5+26*x**3+8*x) / (x**8-5*x**6+6*x**4+4*x**2-8) + 7 5 3 + 2x - 7x + 26x + 8x + ------------------------ + 8 6 4 2 + x - 5x + 6x + 4x - 8 + Type: Fraction UnivariatePolynomial(x,Fraction Integer) -Heaps can be compared with = + g := fullPartialFraction f + 1 1 + - - + --+ 2 --+ 1 --+ 2 + > ------ + > --------- + > ------ + --+ x - %A --+ 3 --+ x - %A + 2 2 (x - %A) 2 + %A - 2= 0 %A - 2= 0 %A + 1= 0 +Type: FullPartialFractionExpansion(Fraction Integer, + UnivariatePolynomial(x,Fraction Integer)) - (a=c)@Boolean - false + g :: Fx - f + 0 + Type: Fraction UnivariatePolynomial(x,Fraction Integer) -and ~= + f:Fx := x**3 / (x**21 + 2*x**20 + 4*x**19 + 7*x**18 + 10*x**17 + 17*x**16 + 22*x**15 + 30*x**14 + 36*x**13 + 40*x**12 + 47*x**11 + 46*x**10 + 49*x**9 + 43*x**8 + 38*x**7 + 32*x**6 + 23*x**5 + 19*x**4 + 10*x**3 + 7*x**2 + 2*x + 1) + 3 + x + / + 21 20 19 18 17 16 15 14 13 12 + x + 2x + 4x + 7x + 10x + 17x + 22x + 30x + 36x + 40x + + + 11 10 9 8 7 6 5 4 3 2 + 47x + 46x + 49x + 43x + 38x + 32x + 23x + 19x + 10x + 7x + 2x + + + 1 + Type: Fraction UnivariatePolynomial(x,Fraction Integer) - (a~=c) - true + g := fullPartialFraction f + 1 1 19 + - %A - %A - -- + --+ 2 --+ 9 27 + > ------ + > --------- + --+ x - %A --+ x - %A + 2 2 + %A + 1= 0 %A + %A + 1= 0 + + + 1 1 + -- %A - -- + --+ 27 27 + > ---------- + --+ 2 + 2 (x - %A) + %A + %A + 1= 0 + + + SIGMA + 5 2 + %A + %A + 1= 0 + , + 96556567040 4 420961732891 3 59101056149 2 + - ------------ %A + ------------ %A - ------------ %A + 912390759099 912390759099 912390759099 + + + 373545875923 529673492498 + - ------------ %A + ------------ + 912390759099 912390759099 + / + x - %A + + + SIGMA + 5 2 + %A + %A + 1= 0 + , + 5580868 4 2024443 3 4321919 2 84614 5070620 + - -------- %A - -------- %A + -------- %A - ------- %A - -------- + 94070601 94070601 94070601 1542141 94070601 + -------------------------------------------------------------------- + 2 + (x - %A) + + + SIGMA + 5 2 + %A + %A + 1= 0 + , + 1610957 4 2763014 3 2016775 2 266953 4529359 + -------- %A + -------- %A - -------- %A + -------- %A + -------- + 94070601 94070601 94070601 94070601 94070601 + ------------------------------------------------------------------- + 3 + (x - %A) +Type: FullPartialFractionExpansion(Fraction Integer,UnivariatePolynomial(x,Fraction Integer)) -The inspect function shows the largest element in the heap: +This verification takes much longer than the conversion to partial fractions. - inspect a - 4 + g :: Fx - f + 0 + Type: Fraction UnivariatePolynomial(x,Fraction Integer) -The insert! function adds an element to the heap: +Use PartialFraction for standard partial fraction decompositions. - insert!(9,a) - [9,4,2,1,3] +For more information, see the paper: Bronstein, M and Salvy, B. +"Full Partial Fraction Decomposition of Rational Functions," +Proceedings of ISSAC'93, Kiev, ACM Press. -The map function applies a function to every element of the heap -and returns a new heap: +See Also: +o )help PartialFraction +o )show FullPartialFractionExpansion - map(x+->x+10,a) - [19,14,12,11,13] +\end{chunk} +\pagehead{FullPartialFractionExpansion}{FPARFRAC} +\pagepic{ps/v103fullpartialfractionexpansion.ps}{FPARFRAC}{1.00} -The original heap is unchanged: +{\bf Exports:}\\ +\begin{tabular}{lllll} +\cross{FPARFRAC}{coerce} & +\cross{FPARFRAC}{construct} & +\cross{FPARFRAC}{convert} & +\cross{FPARFRAC}{D} & +\cross{FPARFRAC}{differentiate} \\ +\cross{FPARFRAC}{hash} & +\cross{FPARFRAC}{latex} & +\cross{FPARFRAC}{polyPart} & +\cross{FPARFRAC}{fracPart} & +\cross{FPARFRAC}{fullPartialFraction} \\ +\cross{FPARFRAC}{?\~{}=?} & +\cross{FPARFRAC}{?+?} & +\cross{FPARFRAC}{?=?} && +\end{tabular} - a - [9,4,2,1,3] +\begin{chunk}{domain FPARFRAC FullPartialFractionExpansion} +)abbrev domain FPARFRAC FullPartialFractionExpansion +++ Author: Manuel Bronstein +++ Date Created: 9 December 1992 +++ Date Last Updated: 6 October 1993 +++ References: M.Bronstein & B.Salvy, +++ Full Partial Fraction Decomposition of Rational Functions, +++ in Proceedings of ISSAC'93, Kiev, ACM Press. +++ Description: +++ Full partial fraction expansion of rational functions -The map! function applies a function to every element of the heap -and returns the original heap with modifications: +FullPartialFractionExpansion(F, UP): Exports == Implementation where + F : Join(Field, CharacteristicZero) + UP : UnivariatePolynomialCategory F - map!(x+->x+10,a) - [19,14,12,11,13] + N ==> NonNegativeInteger + Q ==> Fraction Integer + O ==> OutputForm + RF ==> Fraction UP + SUP ==> SparseUnivariatePolynomial RF + REC ==> Record(exponent: N, center: UP, num: UP) + ODV ==> OrderlyDifferentialVariable Symbol + ODP ==> OrderlyDifferentialPolynomial UP + ODF ==> Fraction ODP + FPF ==> Record(polyPart: UP, fracPart: List REC) -The original heap has been modified: + Exports ==> Join(SetCategory, ConvertibleTo RF) with + "+": (UP, $) -> $ + ++ p + x returns the sum of p and x + fullPartialFraction: RF -> $ + ++ fullPartialFraction(f) returns \spad{[p, [[j, Dj, Hj]...]]} such that + ++ \spad{f = p(x) + sum_{[j,Dj,Hj] in l} sum_{Dj(a)=0} Hj(a)/(x - a)\^j}. + polyPart: $ -> UP + ++ polyPart(f) returns the polynomial part of f. + fracPart: $ -> List REC + ++ fracPart(f) returns the list of summands of the fractional part of f. + construct: List REC -> $ + ++ construct(l) is the inverse of fracPart. + differentiate: $ -> $ + ++ differentiate(f) returns the derivative of f. + D: $ -> $ + ++ D(f) returns the derivative of f. + differentiate: ($, N) -> $ + ++ differentiate(f, n) returns the n-th derivative of f. + D: ($, NonNegativeInteger) -> $ + ++ D(f, n) returns the n-th derivative of f. - a - [19,14,12,11,13] + Implementation ==> add -The max function returns the largest element in the heap: + Rep := FPF - max a - 19 + fullParFrac: (UP, UP, UP, N) -> List REC + outputexp : (O, N) -> O + output : (N, UP, UP) -> O + REC2RF : (UP, UP, N) -> RF + UP2SUP : UP -> SUP + diffrec : REC -> REC + FP2O : List REC -> O -The merge function takes two heaps and creates a new heap with -all of the elements: +-- create a differential variable + u := new()$Symbol - merge(a,c) - [19,14,12,11,13,5,4,2,1,3] + u0 := makeVariable(u, 0)$ODV -Notice that the original heap is unchanged: + alpha := u::O - a - [19,14,12,11,13] + x := monomial(1, 1)$UP -The merge! function takes two heaps and modifies the first heap -argument to contain all of the elements: + xx := x::O - merge!(a,c) - [19,14,12,11,13,5,4,2,1,3] + zr := (0$N)::O -Notice that the first argument was modified: + construct l == [0, l] - a - [19,14,12,11,13,5,4,2,1,3] + D r == differentiate r -but the second argument was not: + D(r, n) == differentiate(r,n) - c - [5,4,2,1,3] + polyPart f == f.polyPart -A new, empty heap can be created with sample: + fracPart f == f.fracPart - sample()$Heap(INT) - [] + p:UP + f:$ == [p + polyPart f, fracPart f] -The # function gives the size of the heap: + differentiate f == + differentiate(polyPart f) + construct [diffrec rec for rec in fracPart f] - #a - 10 + differentiate(r, n) == + for i in 1..n repeat r := differentiate r + r -The any? function tests each element against a predicate function -and returns true if any pass: + diffrec rec == + e := rec.exponent + [e + 1, rec.center, - e * rec.num] - any?(x+->(x=14),a) - true + convert(f:$):RF == + ans := polyPart(f)::RF + for rec in fracPart f repeat + ans := ans + REC2RF(rec.center, rec.num, rec.exponent) + ans -The every? function tests each element against a predicate function -and returns true if they all pass: + UP2SUP p == map((z1:F):RF +-> z1::UP::RF, p)_ + $UnivariatePolynomialCategoryFunctions2(F, UP, RF, SUP) - every?(x+->(x=11),a) - false + -- returns Trace_k^k(a) (h(a) / (x - a)^n) where d(a) = 0 + REC2RF(d, h, n) == + ((m := degree d) = 1) => + a := - (leadingCoefficient reductum d) / (leadingCoefficient d) + h(a)::UP / (x - a::UP)**n + dd := UP2SUP d + hh := UP2SUP h + aa := monomial(1, 1)$SUP + p := (x::RF::SUP - aa)**n rem dd + rec := extendedEuclidean(p, dd, hh)::Record(coef1:SUP, coef2:SUP) + t := rec.coef1 -- we want Trace_k^k(a)(t) now + ans := coefficient(t, 0) + for i in 1..degree(d)-1 repeat + t := (t * aa) rem dd + ans := ans + coefficient(t, i) + ans -The parts function returns a list of the elements in the heap: + fullPartialFraction f == + qr := divide(numer f, d := denom f) + qr.quotient + construct concat + [fullParFrac(qr.remainder, d, rec.factor, rec.exponent::N) + for rec in factors squareFree denom f] - parts a - [19,14,12,11,13,5,4,2,1,3] + fullParFrac(a, d, q, n) == + ans:List REC := empty() + em := e := d quo (q ** n) + rec := extendedEuclidean(e, q, 1)::Record(coef1:UP,coef2:UP) + bm := b := rec.coef1 -- b = inverse of e modulo q + lvar:List(ODV) := [u0] + um := 1::ODP + un := (u1 := u0::ODP)**n + lval:List(UP) := [q1 := q := differentiate(q0 := q)] + h:ODF := a::ODP / (e * un) + rec := extendedEuclidean(q1, q0, 1)::Record(coef1:UP,coef2:UP) + c := rec.coef1 -- c = inverse of q' modulo q + cm := 1::UP + cn := (c ** n) rem q0 + for m in 1..n repeat + p := retract(em * un * um * h)@ODP + pp := retract(eval(p, lvar, lval))@UP + h := inv(m::Q) * differentiate h + q := differentiate q + lvar := concat(makeVariable(u, m), lvar) + lval := concat(inv((m+1)::F) * q, lval) + qq := q0 quo gcd(pp, q0) -- new center + if (degree(qq) > 0) then + ans := concat([(n + 1 - m)::N, qq, (pp * bm * cn * cm) rem qq], ans) + cm := (c * cm) rem q0 -- cm = c**m modulo q now + um := u1 * um -- um = u**m now + em := e * em -- em = e**{m+1} now + bm := (b * bm) rem q0 -- bm = b**{m+1} modulo q now + ans -The size? predicate compares the size of the heap to a value: + coerce(f:$):O == + ans := FP2O(l := fracPart f) + zero?(p := polyPart f) => + empty? l => (0$N)::O + ans + p::O + ans - size?(a,9) - false + FP2O l == + empty? l => empty() + rec := first l + ans := output(rec.exponent, rec.center, rec.num) + for rec in rest l repeat + ans := ans + output(rec.exponent, rec.center, rec.num) + ans -The more? predicate asks if the heap size is larger than a value: + output(n, d, h) == + (degree d) = 1 => + a := - leadingCoefficient(reductum d) / leadingCoefficient(d) + h(a)::O / outputexp((x - a::UP)::O, n) + sum(outputForm(makeSUP h, alpha) / outputexp(xx - alpha, n), + outputForm(makeSUP d, alpha) = zr) - more?(a,9) - true + outputexp(f, n) == + (n = 1) => f + f ** (n::O) -The less? predicate asks if the heap size is smaller than a value: +\end{chunk} - less?(a,9) - false +\begin{chunk}{COQ FPARFRAC} +(* domain FPARFRAC *) +(* -The members function returns a list of the elements of the heap: + Rep := FPF - members a - [19,14,12,11,13,5,4,2,1,3] + fullParFrac: (UP, UP, UP, N) -> List REC + outputexp : (O, N) -> O + output : (N, UP, UP) -> O + REC2RF : (UP, UP, N) -> RF + UP2SUP : UP -> SUP + diffrec : REC -> REC + FP2O : List REC -> O -The member? predicate asks if an element is in the heap: +-- create a differential variable + u := new()$Symbol - member?(14,a) - true + u0 := makeVariable(u, 0)$ODV -The count function has two forms, one of which counts the number -of copies of an element in the heap: + alpha := u::O - count(14,a) - 1 + x := monomial(1, 1)$UP -The second form of the count function accepts a predicate to test -against each member of the heap and counts the number of true results: + xx := x::O - count(x+->(x>13),a) - 2 + zr := (0$N)::O + + construct l == [0, l] + + D r == differentiate r + + D(r, n) == differentiate(r,n) + + polyPart f == f.polyPart + + fracPart f == f.fracPart + + p:UP + f:$ == [p + polyPart f, fracPart f] + + differentiate f == + differentiate(polyPart f) + construct [diffrec rec for rec in fracPart f] + + differentiate(r, n) == + for i in 1..n repeat r := differentiate r + r + + diffrec rec == + e := rec.exponent + [e + 1, rec.center, - e * rec.num] + + convert(f:$):RF == + ans := polyPart(f)::RF + for rec in fracPart f repeat + ans := ans + REC2RF(rec.center, rec.num, rec.exponent) + ans + + UP2SUP p == map((z1:F):RF +-> z1::UP::RF, p)_ + $UnivariatePolynomialCategoryFunctions2(F, UP, RF, SUP) + + -- returns Trace_k^k(a) (h(a) / (x - a)^n) where d(a) = 0 + REC2RF(d, h, n) == + ((m := degree d) = 1) => + a := - (leadingCoefficient reductum d) / (leadingCoefficient d) + h(a)::UP / (x - a::UP)**n + dd := UP2SUP d + hh := UP2SUP h + aa := monomial(1, 1)$SUP + p := (x::RF::SUP - aa)**n rem dd + rec := extendedEuclidean(p, dd, hh)::Record(coef1:SUP, coef2:SUP) + t := rec.coef1 -- we want Trace_k^k(a)(t) now + ans := coefficient(t, 0) + for i in 1..degree(d)-1 repeat + t := (t * aa) rem dd + ans := ans + coefficient(t, i) + ans + + fullPartialFraction f == + qr := divide(numer f, d := denom f) + qr.quotient + construct concat + [fullParFrac(qr.remainder, d, rec.factor, rec.exponent::N) + for rec in factors squareFree denom f] + + fullParFrac(a, d, q, n) == + ans:List REC := empty() + em := e := d quo (q ** n) + rec := extendedEuclidean(e, q, 1)::Record(coef1:UP,coef2:UP) + bm := b := rec.coef1 -- b = inverse of e modulo q + lvar:List(ODV) := [u0] + um := 1::ODP + un := (u1 := u0::ODP)**n + lval:List(UP) := [q1 := q := differentiate(q0 := q)] + h:ODF := a::ODP / (e * un) + rec := extendedEuclidean(q1, q0, 1)::Record(coef1:UP,coef2:UP) + c := rec.coef1 -- c = inverse of q' modulo q + cm := 1::UP + cn := (c ** n) rem q0 + for m in 1..n repeat + p := retract(em * un * um * h)@ODP + pp := retract(eval(p, lvar, lval))@UP + h := inv(m::Q) * differentiate h + q := differentiate q + lvar := concat(makeVariable(u, m), lvar) + lval := concat(inv((m+1)::F) * q, lval) + qq := q0 quo gcd(pp, q0) -- new center + if (degree(qq) > 0) then + ans := concat([(n + 1 - m)::N, qq, (pp * bm * cn * cm) rem qq], ans) + cm := (c * cm) rem q0 -- cm = c**m modulo q now + um := u1 * um -- um = u**m now + em := e * em -- em = e**{m+1} now + bm := (b * bm) rem q0 -- bm = b**{m+1} modulo q now + ans + + coerce(f:$):O == + ans := FP2O(l := fracPart f) + zero?(p := polyPart f) => + empty? l => (0$N)::O + ans + p::O + ans + + FP2O l == + empty? l => empty() + rec := first l + ans := output(rec.exponent, rec.center, rec.num) + for rec in rest l repeat + ans := ans + output(rec.exponent, rec.center, rec.num) + ans + + output(n, d, h) == + (degree d) = 1 => + a := - leadingCoefficient(reductum d) / leadingCoefficient(d) + h(a)::O / outputexp((x - a::UP)::O, n) + sum(outputForm(makeSUP h, alpha) / outputexp(xx - alpha, n), + outputForm(makeSUP d, alpha) = zr) + + outputexp(f, n) == + (n = 1) => f + f ** (n::O) + +*) + +\end{chunk} + +\begin{chunk}{FPARFRAC.dotabb} +"FPARFRAC" [color="#88FF44",href="bookvol10.3.pdf#nameddest=FPARFRAC"] +"ALIST" [color="#88FF44",href="bookvol10.3.pdf#nameddest=ALIST"] +"FPARFRAC" -> "ALIST" + +\end{chunk} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{domain FUNCTION FunctionCalled} + +\begin{chunk}{FunctionCalled.input} +)set break resume +)sys rm -f FunctionCalled.output +)spool FunctionCalled.output +)set message test on +)set message auto off +)clear all + +--S 1 of 1 +)show FunctionCalled +--R +--R FunctionCalled(f: Symbol) is a domain constructor +--R Abbreviation for FunctionCalled is FUNCTION +--R This constructor is not exposed in this frame. +--R Issue )edit bookvol10.3.pamphlet to see algebra source code for FUNCTION +--R +--R------------------------------- Operations -------------------------------- +--R ?=? : (%,%) -> Boolean coerce : % -> OutputForm +--R hash : % -> SingleInteger latex : % -> String +--R name : % -> Symbol ?~=? : (%,%) -> Boolean +--R +--E 1 + +)spool +)lisp (bye) +\end{chunk} +\begin{chunk}{FunctionCalled.help} +==================================================================== +FunctionCalled examples +==================================================================== + +This domain implements named functions See Also: -o )show Stack -o )show ArrayStack -o )show Queue -o )show Dequeue -o )show Heap -o )show BagAggregate +o )show FunctionCalled \end{chunk} -\pagehead{Heap}{HEAP} -\pagepic{ps/v103heap.ps}{HEAP}{1.00} -{\bf See}\\ -\pageto{Stack}{STACK} -\pageto{ArrayStack}{ASTACK} -\pageto{Queue}{QUEUE} -\pageto{Dequeue}{DEQUEUE} + +\pagehead{FunctionCalled}{FUNCTION} +\pagepic{ps/v103functioncalled.ps}{FUNCTION}{1.00} {\bf Exports:}\\ -\begin{tabular}{lllll} -\cross{HEAP}{any?} & -\cross{HEAP}{bag} & -\cross{HEAP}{coerce} & -\cross{HEAP}{copy} & -\cross{HEAP}{count} \\ -\cross{HEAP}{empty} & -\cross{HEAP}{empty?} & -\cross{HEAP}{eq?} & -\cross{HEAP}{eval} & -\cross{HEAP}{every?} \\ -\cross{HEAP}{extract!} & -\cross{HEAP}{hash} & -\cross{HEAP}{heap} & -\cross{HEAP}{insert!} & -\cross{HEAP}{inspect} \\ -\cross{HEAP}{latex} & -\cross{HEAP}{less?} & -\cross{HEAP}{map} & -\cross{HEAP}{map!} & -\cross{HEAP}{max} \\ -\cross{HEAP}{member?} & -\cross{HEAP}{members} & -\cross{HEAP}{merge} & -\cross{HEAP}{merge!} & -\cross{HEAP}{more?} \\ -\cross{HEAP}{parts} & -\cross{HEAP}{sample} & -\cross{HEAP}{size?} & -\cross{HEAP}{\#{}?} & -\cross{HEAP}{?=?} \\ -\cross{HEAP}{?\~{}=?} &&&& +\begin{tabular}{llllll} +\cross{FUNCTION}{coerce} & +\cross{FUNCTION}{hash} & +\cross{FUNCTION}{latex} & +\cross{FUNCTION}{name} & +\cross{FUNCTION}{?=?} & +\cross{FUNCTION}{?\~{}=?} \end{tabular} -\begin{chunk}{domain HEAP Heap} -)abbrev domain HEAP Heap -++ Author: Michael Monagan and Stephen Watt -++ Date Created:June 86 and July 87 -++ Date Last Updated:Feb 92 +\begin{chunk}{domain FUNCTION FunctionCalled} +)abbrev domain FUNCTION FunctionCalled +++ Author: Mark Botch ++ Description: -++ Heap implemented in a flexible array to allow for insertions -++ Complexity: O(log n) insertion, extraction and O(n) construction ---% Dequeue and Heap data types - -Heap(S:OrderedSet): Exports == Implementation where - Exports == PriorityQueueAggregate S with - heap : List S -> % - ++ heap(ls) creates a heap of elements consisting of the - ++ elements of ls. - ++ - ++E i:Heap INT := heap [1,6,3,7,5,2,4] +++ This domain implements named functions - -- Inherited Signatures repeated for examples documentation +FunctionCalled(f:Symbol): SetCategory with + name: % -> Symbol + ++ name(x) returns the symbol + == add - bag : List S -> % - ++ - ++X bag([1,2,3,4,5])$Heap(INT) - copy : % -> % - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X copy a - empty? : % -> Boolean - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X empty? a - empty : () -> % - ++ - ++X b:=empty()$(Heap INT) - eq? : (%,%) -> Boolean - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X b:=copy a - ++X eq?(a,b) - extract_! : % -> S - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X extract! a - ++X a - insert_! : (S,%) -> % - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X insert!(8,a) - ++X a - inspect : % -> S - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X inspect a - map : ((S -> S),%) -> % - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X map(x+->x+10,a) - ++X a - max : % -> S - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X max a - merge : (%,%) -> % - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X b:Heap INT:= heap [6,7,8,9,10] - ++X merge(a,b) - merge! : (%,%) -> % - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X b:Heap INT:= heap [6,7,8,9,10] - ++X merge!(a,b) - ++X a - ++X b - sample : () -> % - ++ - ++X sample()$Heap(INT) - less? : (%,NonNegativeInteger) -> Boolean - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X less?(a,9) - more? : (%,NonNegativeInteger) -> Boolean - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X more?(a,9) - size? : (%,NonNegativeInteger) -> Boolean - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X size?(a,5) - if $ has shallowlyMutable then - map! : ((S -> S),%) -> % - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X map!(x+->x+10,a) - ++X a - if S has SetCategory then - latex : % -> String - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X latex a - hash : % -> SingleInteger - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X hash a - coerce : % -> OutputForm - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X coerce a - "=": (%,%) -> Boolean - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X b:Heap INT:= heap [1,2,3,4,5] - ++X (a=b)@Boolean - "~=" : (%,%) -> Boolean - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X b:=copy a - ++X (a~=b) - if % has finiteAggregate then - every? : ((S -> Boolean),%) -> Boolean - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X every?(x+->(x=4),a) - any? : ((S -> Boolean),%) -> Boolean - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X any?(x+->(x=4),a) - count : ((S -> Boolean),%) -> NonNegativeInteger - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X count(x+->(x>2),a) - _# : % -> NonNegativeInteger - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X #a - parts : % -> List S - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X parts a - members : % -> List S - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X members a - if % has finiteAggregate and S has SetCategory then - member? : (S,%) -> Boolean - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X member?(3,a) - count : (S,%) -> NonNegativeInteger - ++ - ++X a:Heap INT:= heap [1,2,3,4,5] - ++X count(4,a) + name r == f - Implementation == IndexedFlexibleArray(S,0) add - Rep := IndexedFlexibleArray( S,0) - empty() == empty()$Rep - heap l == - n := #l - h := empty() - n = 0 => h - for x in l repeat insert_!(x,h) - h - siftUp: (%,Integer,Integer) -> Void - siftUp(r,i,n) == - -- assertion 0 <= i < n - t := r.i - while (j := 2*i+1) < n repeat - if (k := j+1) < n and r.j < r.k then j := k - if t < r.j then (r.i := r.j; r.j := t; i := j) else leave - - extract_! r == - -- extract the maximum from the heap O(log n) - n := #r :: Integer - n = 0 => error "empty heap" - t := r(0) - r(0) := r(n-1) - delete_!(r,n-1) - n = 1 => t - siftUp(r,0,n-1) - t - - insert_!(x,r) == - -- Williams' insertion algorithm O(log n) - j := (#r) :: Integer - r:=concat_!(r,concat(x,empty()$Rep)) - while j > 0 repeat - i := (j-1) quo 2 - if r(i) >= x then leave - r(j) := r(i) - j := i - r(j):=x - r - - max r == if #r = 0 then error "empty heap" else r.0 - inspect r == max r - - makeHeap(r:%):% == - -- Floyd's heap construction algorithm O(n) - n := #r - for k in n quo 2 -1 .. 0 by -1 repeat siftUp(r,k,n) - r - bag l == makeHeap construct(l)$Rep - merge(a,b) == makeHeap concat(a,b) - merge_!(a,b) == makeHeap concat_!(a,b) + coerce(r:%):OutputForm == f::OutputForm + + x = y == true + + latex(x:%):String == latex f \end{chunk} -\begin{chunk}{COQ HEAP} -(* domain HEAP *) +\begin{chunk}{COQ FUNCTION} +(* domain FUNCTION *) (* + + name r == f + + coerce(r:%):OutputForm == f::OutputForm + + x = y == true + + latex(x:%):String == latex f + *) \end{chunk}