aboutsummaryrefslogtreecommitdiff
path: root/src/algebra/efstruc.spad.pamphlet
diff options
context:
space:
mode:
Diffstat (limited to 'src/algebra/efstruc.spad.pamphlet')
-rw-r--r--src/algebra/efstruc.spad.pamphlet961
1 files changed, 961 insertions, 0 deletions
diff --git a/src/algebra/efstruc.spad.pamphlet b/src/algebra/efstruc.spad.pamphlet
new file mode 100644
index 00000000..6ac57be1
--- /dev/null
+++ b/src/algebra/efstruc.spad.pamphlet
@@ -0,0 +1,961 @@
+\documentclass{article}
+\usepackage{axiom}
+\begin{document}
+\title{\$SPAD/src/algebra efstruc.spad}
+\author{Manuel Bronstein}
+\maketitle
+\begin{abstract}
+\end{abstract}
+\eject
+\tableofcontents
+\eject
+\section{package SYMFUNC SymmetricFunctions}
+<<package SYMFUNC SymmetricFunctions>>=
+)abbrev package SYMFUNC SymmetricFunctions
+++ The elementary symmetric functions
+++ Author: Manuel Bronstein
+++ Date Created: 13 Feb 1989
+++ Date Last Updated: 28 Jun 1990
+++ Description: Computes all the symmetric functions in n variables.
+SymmetricFunctions(R:Ring): Exports == Implementation where
+ UP ==> SparseUnivariatePolynomial R
+
+ Exports ==> with
+ symFunc: List R -> Vector R
+ ++ symFunc([r1,...,rn]) returns the vector of the
+ ++ elementary symmetric functions in the \spad{ri's}:
+ ++ \spad{[r1 + ... + rn, r1 r2 + ... + r(n-1) rn, ..., r1 r2 ... rn]}.
+ symFunc: (R, PositiveInteger) -> Vector R
+ ++ symFunc(r, n) returns the vector of the elementary
+ ++ symmetric functions in \spad{[r,r,...,r]} \spad{n} times.
+
+ Implementation ==> add
+ signFix: (UP, NonNegativeInteger) -> Vector R
+
+ symFunc(x, n) == signFix((monomial(1, 1)$UP - x::UP) ** n, 1 + n)
+
+ symFunc l ==
+ signFix(*/[monomial(1, 1)$UP - a::UP for a in l], 1 + #l)
+
+ signFix(p, n) ==
+ m := minIndex(v := vectorise(p, n)) + 1
+ for i in 0..((#v quo 2) - 1)::NonNegativeInteger repeat
+ qsetelt_!(v, 2*i + m, - qelt(v, 2*i + m))
+ reverse_! v
+
+@
+\section{package TANEXP TangentExpansions}
+<<package TANEXP TangentExpansions>>=
+)abbrev package TANEXP TangentExpansions
+++ Expansions of tangents of sums and quotients
+++ Author: Manuel Bronstein
+++ Date Created: 13 Feb 1989
+++ Date Last Updated: 20 Apr 1990
+++ Description: Expands tangents of sums and scalar products.
+TangentExpansions(R:Field): Exports == Implementation where
+ PI ==> PositiveInteger
+ Z ==> Integer
+ UP ==> SparseUnivariatePolynomial R
+ QF ==> Fraction UP
+
+ Exports ==> with
+ tanSum: List R -> R
+ ++ tanSum([a1,...,an]) returns \spad{f(a1,...,an)} such that
+ ++ if \spad{ai = tan(ui)} then \spad{f(a1,...,an) = tan(u1 + ... + un)}.
+ tanAn : (R, PI) -> UP
+ ++ tanAn(a, n) returns \spad{P(x)} such that
+ ++ if \spad{a = tan(u)} then \spad{P(tan(u/n)) = 0}.
+ tanNa : (R, Z) -> R
+ ++ tanNa(a, n) returns \spad{f(a)} such that
+ ++ if \spad{a = tan(u)} then \spad{f(a) = tan(n * u)}.
+
+ Implementation ==> add
+ import SymmetricFunctions(R)
+ import SymmetricFunctions(UP)
+
+ m1toN : Integer -> Integer
+ tanPIa: PI -> QF
+
+ m1toN n == (odd? n => -1; 1)
+ tanAn(a, n) == a * denom(q := tanPIa n) - numer q
+
+ tanNa(a, n) ==
+ zero? n => 0
+ negative? n => - tanNa(a, -n)
+ (numer(t := tanPIa(n::PI)) a) / ((denom t) a)
+
+ tanSum l ==
+ m := minIndex(v := symFunc l)
+ +/[m1toN(i+1) * v(2*i - 1 + m) for i in 1..(#v quo 2)]
+ / +/[m1toN(i) * v(2*i + m) for i in 0..((#v - 1) quo 2)]
+
+-- tanPIa(n) returns P(a)/Q(a) such that
+-- if a = tan(u) then P(a)/Q(a) = tan(n * u);
+ tanPIa n ==
+ m := minIndex(v := symFunc(monomial(1, 1)$UP, n))
+ +/[m1toN(i+1) * v(2*i - 1 + m) for i in 1..(#v quo 2)]
+ / +/[m1toN(i) * v(2*i + m) for i in 0..((#v - 1) quo 2)]
+
+@
+\section{package EFSTRUC ElementaryFunctionStructurePackage}
+<<package EFSTRUC ElementaryFunctionStructurePackage>>=
+)abbrev package EFSTRUC ElementaryFunctionStructurePackage
+++ Risch structure theorem
+++ Author: Manuel Bronstein
+++ Date Created: 1987
+++ Date Last Updated: 16 August 1995
+++ Description:
+++ ElementaryFunctionStructurePackage provides functions to test the
+++ algebraic independence of various elementary functions, using the
+++ Risch structure theorem (real and complex versions).
+++ It also provides transformations on elementary functions
+++ which are not considered simplifications.
+++ Keywords: elementary, function, structure.
+ElementaryFunctionStructurePackage(R,F): Exports == Implementation where
+ R : Join(IntegralDomain, OrderedSet, RetractableTo Integer,
+ LinearlyExplicitRingOver Integer)
+ F : Join(AlgebraicallyClosedField, TranscendentalFunctionCategory,
+ FunctionSpace R)
+
+ B ==> Boolean
+ N ==> NonNegativeInteger
+ Z ==> Integer
+ Q ==> Fraction Z
+ SY ==> Symbol
+ K ==> Kernel F
+ UP ==> SparseUnivariatePolynomial F
+ SMP ==> SparseMultivariatePolynomial(R, K)
+ REC ==> Record(func:F, kers: List K, vals:List F)
+ U ==> Union(vec:Vector Q, func:F, fail: Boolean)
+ POWER ==> "%power"::SY
+ NTHR ==> "nthRoot"::SY
+
+ Exports ==> with
+ normalize: F -> F
+ ++ normalize(f) rewrites \spad{f} using the least possible number of
+ ++ real algebraically independent kernels.
+ normalize: (F, SY) -> F
+ ++ normalize(f, x) rewrites \spad{f} using the least possible number of
+ ++ real algebraically independent kernels involving \spad{x}.
+ rischNormalize: (F, SY) -> REC
+ ++ rischNormalize(f, x) returns \spad{[g, [k1,...,kn], [h1,...,hn]]}
+ ++ such that \spad{g = normalize(f, x)} and each \spad{ki} was
+ ++ rewritten as \spad{hi} during the normalization.
+ realElementary: F -> F
+ ++ realElementary(f) rewrites \spad{f} in terms of the 4 fundamental real
+ ++ transcendental elementary functions: \spad{log, exp, tan, atan}.
+ realElementary: (F, SY) -> F
+ ++ realElementary(f,x) rewrites the kernels of \spad{f} involving \spad{x}
+ ++ in terms of the 4 fundamental real
+ ++ transcendental elementary functions: \spad{log, exp, tan, atan}.
+ validExponential: (List K, F, SY) -> Union(F, "failed")
+ ++ validExponential([k1,...,kn],f,x) returns \spad{g} if \spad{exp(f)=g}
+ ++ and \spad{g} involves only \spad{k1...kn}, and "failed" otherwise.
+ rootNormalize: (F, K) -> F
+ ++ rootNormalize(f, k) returns \spad{f} rewriting either \spad{k} which
+ ++ must be an nth-root in terms of radicals already in \spad{f}, or some
+ ++ radicals in \spad{f} in terms of \spad{k}.
+ tanQ: (Q, F) -> F
+ ++ tanQ(q,a) is a local function with a conditional implementation.
+
+ Implementation ==> add
+ import TangentExpansions F
+ import IntegrationTools(R, F)
+ import IntegerLinearDependence F
+ import AlgebraicManipulations(R, F)
+ import InnerCommonDenominator(Z, Q, Vector Z, Vector Q)
+
+ k2Elem : (K, List SY) -> F
+ realElem : (F, List SY) -> F
+ smpElem : (SMP, List SY) -> F
+ deprel : (List K, K, SY) -> U
+ rootDep : (List K, K) -> U
+ qdeprel : (List F, F) -> U
+ factdeprel : (List K, K) -> U
+ toR : (List K, F) -> List K
+ toY : List K -> List F
+ toZ : List K -> List F
+ toU : List K -> List F
+ toV : List K -> List F
+ ktoY : K -> F
+ ktoZ : K -> F
+ ktoU : K -> F
+ ktoV : K -> F
+ gdCoef? : (Q, Vector Q) -> Boolean
+ goodCoef : (Vector Q, List K, SY) ->
+ Union(Record(index:Z, ker:K), "failed")
+ tanRN : (Q, K) -> F
+ localnorm : F -> F
+ rooteval : (F, List K, K, Q) -> REC
+ logeval : (F, List K, K, Vector Q) -> REC
+ expeval : (F, List K, K, Vector Q) -> REC
+ taneval : (F, List K, K, Vector Q) -> REC
+ ataneval : (F, List K, K, Vector Q) -> REC
+ depeval : (F, List K, K, Vector Q) -> REC
+ expnosimp : (F, List K, K, Vector Q, List F, F) -> REC
+ tannosimp : (F, List K, K, Vector Q, List F, F) -> REC
+ rtNormalize : F -> F
+ rootNormalize0 : F -> REC
+ rootKernelNormalize: (F, List K, K) -> Union(REC, "failed")
+ tanSum : (F, List F) -> F
+
+ comb? := F has CombinatorialOpsCategory
+ mpiover2:F := pi()$F / (-2::F)
+
+ realElem(f, l) == smpElem(numer f, l) / smpElem(denom f, l)
+ realElementary(f, x) == realElem(f, [x])
+ realElementary f == realElem(f, variables f)
+ toY ker == [func for k in ker | (func := ktoY k) ^= 0]
+ toZ ker == [func for k in ker | (func := ktoZ k) ^= 0]
+ toU ker == [func for k in ker | (func := ktoU k) ^= 0]
+ toV ker == [func for k in ker | (func := ktoV k) ^= 0]
+ rtNormalize f == rootNormalize0(f).func
+ toR(ker, x) == select(is?(#1, NTHR) and first argument(#1) = x, ker)
+
+ if R has GcdDomain then
+ tanQ(c, x) ==
+ tanNa(rootSimp zeroOf tanAn(x, denom(c)::PositiveInteger), numer c)
+ else
+ tanQ(c, x) ==
+ tanNa(zeroOf tanAn(x, denom(c)::PositiveInteger), numer c)
+
+ -- tanSum(c, [a1,...,an]) returns f(c, a1,...,an) such that
+ -- if ai = tan(ui) then f(c, a1,...,an) = tan(c + u1 + ... + un).
+ -- MUST BE CAREFUL FOR WHEN c IS AN ODD MULTIPLE of pi/2
+ tanSum(c, l) ==
+ k := c / mpiover2 -- k = - 2 c / pi, check for odd integer
+ -- tan((2n+1) pi/2 x) = - 1 / tan x
+ (r := retractIfCan(k)@Union(Z, "failed")) case Z and odd?(r::Z) =>
+ - inv tanSum l
+ tanSum concat(tan c, l)
+
+ rootNormalize0 f ==
+ ker := select_!(is?(#1, NTHR) and empty? variables first argument #1,
+ tower f)$List(K)
+ empty? ker => [f, empty(), empty()]
+ (n := (#ker)::Z - 1) < 1 => [f, empty(), empty()]
+ for i in 1..n for kk in rest ker repeat
+ (u := rootKernelNormalize(f, first(ker, i), kk)) case REC =>
+ rec := u::REC
+ rn := rootNormalize0(rec.func)
+ return [rn.func, concat(rec.kers, rn.kers), concat(rec.vals, rn.vals)]
+ [f, empty(), empty()]
+
+ deprel(ker, k, x) ==
+ is?(k, "log"::SY) or is?(k, "exp"::SY) =>
+ qdeprel([differentiate(g, x) for g in toY ker],
+ differentiate(ktoY k, x))
+ is?(k, "atan"::SY) or is?(k, "tan"::SY) =>
+ qdeprel([differentiate(g, x) for g in toU ker],
+ differentiate(ktoU k, x))
+ is?(k, NTHR) => rootDep(ker, k)
+ comb? and is?(k, "factorial"::SY) =>
+ factdeprel([x for x in ker | is?(x,"factorial"::SY) and x^=k],k)
+ [true]
+
+ ktoY k ==
+ is?(k, "log"::SY) => k::F
+ is?(k, "exp"::SY) => first argument k
+ 0
+
+ ktoZ k ==
+ is?(k, "log"::SY) => first argument k
+ is?(k, "exp"::SY) => k::F
+ 0
+
+ ktoU k ==
+ is?(k, "atan"::SY) => k::F
+ is?(k, "tan"::SY) => first argument k
+ 0
+
+ ktoV k ==
+ is?(k, "tan"::SY) => k::F
+ is?(k, "atan"::SY) => first argument k
+ 0
+
+ smpElem(p, l) ==
+ map(k2Elem(#1, l), #1::F, p)$PolynomialCategoryLifting(
+ IndexedExponents K, K, R, SMP, F)
+
+ k2Elem(k, l) ==
+ ez, iez, tz2: F
+ kf := k::F
+ not(empty? l) and empty? [v for v in variables kf | member?(v, l)] => kf
+ empty?(args :List F := [realElem(a, l) for a in argument k]) => kf
+ z := first args
+ is?(k, POWER) => (zero? z => 0; exp(last(args) * log z))
+ is?(k, "cot"::SY) => inv tan z
+ is?(k, "acot"::SY) => atan inv z
+ is?(k, "asin"::SY) => atan(z / sqrt(1 - z**2))
+ is?(k, "acos"::SY) => atan(sqrt(1 - z**2) / z)
+ is?(k, "asec"::SY) => atan sqrt(1 - z**2)
+ is?(k, "acsc"::SY) => atan inv sqrt(1 - z**2)
+ is?(k, "asinh"::SY) => log(sqrt(1 + z**2) + z)
+ is?(k, "acosh"::SY) => log(sqrt(z**2 - 1) + z)
+ is?(k, "atanh"::SY) => log((z + 1) / (1 - z)) / (2::F)
+ is?(k, "acoth"::SY) => log((z + 1) / (z - 1)) / (2::F)
+ is?(k, "asech"::SY) => log((inv z) + sqrt(inv(z**2) - 1))
+ is?(k, "acsch"::SY) => log((inv z) + sqrt(1 + inv(z**2)))
+ is?(k, "%paren"::SY) or is?(k, "%box"::SY) =>
+ empty? rest args => z
+ kf
+ if has?(op := operator k, "htrig") then iez := inv(ez := exp z)
+ is?(k, "sinh"::SY) => (ez - iez) / (2::F)
+ is?(k, "cosh"::SY) => (ez + iez) / (2::F)
+ is?(k, "tanh"::SY) => (ez - iez) / (ez + iez)
+ is?(k, "coth"::SY) => (ez + iez) / (ez - iez)
+ is?(k, "sech"::SY) => 2 * inv(ez + iez)
+ is?(k, "csch"::SY) => 2 * inv(ez - iez)
+ if has?(op, "trig") then tz2 := tan(z / (2::F))
+ is?(k, "sin"::SY) => 2 * tz2 / (1 + tz2**2)
+ is?(k, "cos"::SY) => (1 - tz2**2) / (1 + tz2**2)
+ is?(k, "sec"::SY) => (1 + tz2**2) / (1 - tz2**2)
+ is?(k, "csc"::SY) => (1 + tz2**2) / (2 * tz2)
+ op args
+
+--The next 5 functions are used by normalize, once a relation is found
+ depeval(f, lk, k, v) ==
+ is?(k, "log"::SY) => logeval(f, lk, k, v)
+ is?(k, "exp"::SY) => expeval(f, lk, k, v)
+ is?(k, "tan"::SY) => taneval(f, lk, k, v)
+ is?(k, "atan"::SY) => ataneval(f, lk, k, v)
+ is?(k, NTHR) => rooteval(f, lk, k, v(minIndex v))
+ [f, empty(), empty()]
+
+ rooteval(f, lk, k, n) ==
+ nv := nthRoot(x := first argument k, m := retract(n)@Z)
+ l := [r for r in concat(k, toR(lk, x)) |
+ retract(second argument r)@Z ^= m]
+ lv := [nv ** (n / (retract(second argument r)@Z::Q)) for r in l]
+ [eval(f, l, lv), l, lv]
+
+ ataneval(f, lk, k, v) ==
+ w := first argument k
+ s := tanSum [tanQ(qelt(v,i), x)
+ for i in minIndex v .. maxIndex v for x in toV lk]
+ g := +/[qelt(v, i) * x for i in minIndex v .. maxIndex v for x in toU lk]
+ h:F :=
+ zero?(d := 1 + s * w) => mpiover2
+ atan((w - s) / d)
+ g := g + h
+ [eval(f, [k], [g]), [k], [g]]
+
+ gdCoef?(c, v) ==
+ for i in minIndex v .. maxIndex v repeat
+ retractIfCan(qelt(v, i) / c)@Union(Z, "failed") case "failed" =>
+ return false
+ true
+
+ goodCoef(v, l, s) ==
+ for i in minIndex v .. maxIndex v for k in l repeat
+ is?(k, s) and
+ ((r:=recip(qelt(v,i))) case Q) and
+ (retractIfCan(r::Q)@Union(Z, "failed") case Z)
+ and gdCoef?(qelt(v, i), v) => return([i, k])
+ "failed"
+
+ taneval(f, lk, k, v) ==
+ u := first argument k
+ fns := toU lk
+ c := u - +/[qelt(v, i) * x for i in minIndex v .. maxIndex v for x in fns]
+ (rec := goodCoef(v, lk, "tan"::SY)) case "failed" =>
+ tannosimp(f, lk, k, v, fns, c)
+ v0 := retract(inv qelt(v, rec.index))@Z
+ lv := [qelt(v, i) for i in minIndex v .. maxIndex v |
+ i ^= rec.index]$List(Q)
+ l := [kk for kk in lk | kk ^= rec.ker]
+ g := tanSum(-v0 * c, concat(tanNa(k::F, v0),
+ [tanNa(x, - retract(a * v0)@Z) for a in lv for x in toV l]))
+ [eval(f, [rec.ker], [g]), [rec.ker], [g]]
+
+ tannosimp(f, lk, k, v, fns, c) ==
+ every?(is?(#1, "tan"::SY), lk) =>
+ dd := (d := (cd := splitDenominator v).den)::F
+ newt := [tan(u / dd) for u in fns]$List(F)
+ newtan := [tanNa(t, d) for t in newt]$List(F)
+ h := tanSum(c, [tanNa(t, qelt(cd.num, i))
+ for i in minIndex v .. maxIndex v for t in newt])
+ lk := concat(k, lk)
+ newtan := concat(h, newtan)
+ [eval(f, lk, newtan), lk, newtan]
+ h := tanSum(c, [tanQ(qelt(v, i), x)
+ for i in minIndex v .. maxIndex v for x in toV lk])
+ [eval(f, [k], [h]), [k], [h]]
+
+ expnosimp(f, lk, k, v, fns, g) ==
+ every?(is?(#1, "exp"::SY), lk) =>
+ dd := (d := (cd := splitDenominator v).den)::F
+ newe := [exp(y / dd) for y in fns]$List(F)
+ newexp := [e ** d for e in newe]$List(F)
+ h := */[e ** qelt(cd.num, i)
+ for i in minIndex v .. maxIndex v for e in newe] * g
+ lk := concat(k, lk)
+ newexp := concat(h, newexp)
+ [eval(f, lk, newexp), lk, newexp]
+ h := */[exp(y) ** qelt(v, i)
+ for i in minIndex v .. maxIndex v for y in fns] * g
+ [eval(f, [k], [h]), [k], [h]]
+
+ logeval(f, lk, k, v) ==
+ z := first argument k
+ c := z / (*/[x**qelt(v, i)
+ for x in toZ lk for i in minIndex v .. maxIndex v])
+-- CHANGED log ktoZ x TO ktoY x SINCE WE WANT log exp f TO BE REPLACED BY f.
+ g := +/[qelt(v, i) * x
+ for i in minIndex v .. maxIndex v for x in toY lk] + log c
+ [eval(f, [k], [g]), [k], [g]]
+
+ rischNormalize(f, v) ==
+ empty?(ker := varselect(tower f, v)) => [f, empty(), empty()]
+ first(ker) ^= kernel(v)@K => error "Cannot happen"
+ ker := rest ker
+ (n := (#ker)::Z - 1) < 1 => [f, empty(), empty()]
+ for i in 1..n for kk in rest ker repeat
+ klist := first(ker, i)
+ -- NO EVALUATION ON AN EMPTY VECTOR, WILL CAUSE INFINITE LOOP
+ (c := deprel(klist, kk, v)) case vec and not empty?(c.vec) =>
+ rec := depeval(f, klist, kk, c.vec)
+ rn := rischNormalize(rec.func, v)
+ return [rn.func,
+ concat(rec.kers, rn.kers), concat(rec.vals, rn.vals)]
+ c case func =>
+ rn := rischNormalize(eval(f, [kk], [c.func]), v)
+ return [rn.func, concat(kk, rn.kers), concat(c.func, rn.vals)]
+ [f, empty(), empty()]
+
+ rootNormalize(f, k) ==
+ (u := rootKernelNormalize(f, toR(tower f, first argument k), k))
+ case "failed" => f
+ (u::REC).func
+
+ rootKernelNormalize(f, l, k) ==
+ (c := rootDep(l, k)) case vec =>
+ rooteval(f, l, k, (c.vec)(minIndex(c.vec)))
+ "failed"
+
+ localnorm f ==
+ for x in variables f repeat
+ f := rischNormalize(f, x).func
+ f
+
+ validExponential(twr, eta, x) ==
+ (c := solveLinearlyOverQ(construct([differentiate(g, x)
+ for g in (fns := toY twr)]$List(F))@Vector(F),
+ differentiate(eta, x))) case "failed" => "failed"
+ v := c::Vector(Q)
+ g := eta - +/[qelt(v, i) * yy
+ for i in minIndex v .. maxIndex v for yy in fns]
+ */[exp(yy) ** qelt(v, i)
+ for i in minIndex v .. maxIndex v for yy in fns] * exp g
+
+ rootDep(ker, k) ==
+ empty?(ker := toR(ker, first argument k)) => [true]
+ [new(1,lcm(retract(second argument k)@Z,
+ "lcm"/[retract(second argument r)@Z for r in ker])::Q)$Vector(Q)]
+
+ qdeprel(l, v) ==
+ (u := solveLinearlyOverQ(construct(l)@Vector(F), v))
+ case Vector(Q) => [u::Vector(Q)]
+ [true]
+
+ expeval(f, lk, k, v) ==
+ y := first argument k
+ fns := toY lk
+ g := y - +/[qelt(v, i) * z for i in minIndex v .. maxIndex v for z in fns]
+ (rec := goodCoef(v, lk, "exp"::SY)) case "failed" =>
+ expnosimp(f, lk, k, v, fns, exp g)
+ v0 := retract(inv qelt(v, rec.index))@Z
+ lv := [qelt(v, i) for i in minIndex v .. maxIndex v |
+ i ^= rec.index]$List(Q)
+ l := [kk for kk in lk | kk ^= rec.ker]
+ h :F := */[exp(z) ** (- retract(a * v0)@Z) for a in lv for z in toY l]
+ h := h * exp(-v0 * g) * (k::F) ** v0
+ [eval(f, [rec.ker], [h]), [rec.ker], [h]]
+
+ if F has CombinatorialOpsCategory then
+ normalize f == rtNormalize localnorm factorials realElementary f
+
+ normalize(f, x) ==
+ rtNormalize(rischNormalize(factorials(realElementary(f,x),x),x).func)
+
+ factdeprel(l, k) ==
+ ((r := retractIfCan(n := first argument k)@Union(Z, "failed"))
+ case Z) and (r::Z > 0) => [factorial(r::Z)::F]
+ for x in l repeat
+ m := first argument x
+ ((r := retractIfCan(n - m)@Union(Z, "failed")) case Z) and
+ (r::Z > 0) => return([*/[(m + i::F) for i in 1..r] * x::F])
+ [true]
+
+ else
+ normalize f == rtNormalize localnorm realElementary f
+ normalize(f, x) == rtNormalize(rischNormalize(realElementary(f,x),x).func)
+
+@
+\section{package ITRIGMNP InnerTrigonometricManipulations}
+<<package ITRIGMNP InnerTrigonometricManipulations>>=
+)abbrev package ITRIGMNP InnerTrigonometricManipulations
+++ Trigs to/from exps and logs
+++ Author: Manuel Bronstein
+++ Date Created: 4 April 1988
+++ Date Last Updated: 9 October 1993
+++ Description:
+++ This package provides transformations from trigonometric functions
+++ to exponentials and logarithms, and back.
+++ F and FG should be the same type of function space.
+++ Keywords: trigonometric, function, manipulation.
+InnerTrigonometricManipulations(R,F,FG): Exports == Implementation where
+ R : Join(IntegralDomain, OrderedSet)
+ F : Join(FunctionSpace R, RadicalCategory,
+ TranscendentalFunctionCategory)
+ FG : Join(FunctionSpace Complex R, RadicalCategory,
+ TranscendentalFunctionCategory)
+
+ Z ==> Integer
+ SY ==> Symbol
+ OP ==> BasicOperator
+ GR ==> Complex R
+ GF ==> Complex F
+ KG ==> Kernel FG
+ PG ==> SparseMultivariatePolynomial(GR, KG)
+ UP ==> SparseUnivariatePolynomial PG
+ NTHR ==> "nthRoot"::SY
+
+ Exports ==> with
+ GF2FG : GF -> FG
+ ++ GF2FG(a + i b) returns \spad{a + i b} viewed as a function with
+ ++ the \spad{i} pushed down into the coefficient domain.
+ FG2F : FG -> F
+ ++ FG2F(a + i b) returns \spad{a + sqrt(-1) b}.
+ F2FG : F -> FG
+ ++ F2FG(a + sqrt(-1) b) returns \spad{a + i b}.
+ explogs2trigs: FG -> GF
+ ++ explogs2trigs(f) rewrites all the complex logs and
+ ++ exponentials appearing in \spad{f} in terms of trigonometric
+ ++ functions.
+ trigs2explogs: (FG, List KG, List SY) -> FG
+ ++ trigs2explogs(f, [k1,...,kn], [x1,...,xm]) rewrites
+ ++ all the trigonometric functions appearing in \spad{f} and involving
+ ++ one of the \spad{xi's} in terms of complex logarithms and
+ ++ exponentials. A kernel of the form \spad{tan(u)} is expressed
+ ++ using \spad{exp(u)**2} if it is one of the \spad{ki's}, in terms of
+ ++ \spad{exp(2*u)} otherwise.
+
+ Implementation ==> add
+ ker2explogs: (KG, List KG, List SY) -> FG
+ smp2explogs: (PG, List KG, List SY) -> FG
+ supexp : (UP, GF, GF, Z) -> GF
+ GR2GF : GR -> GF
+ GR2F : GR -> F
+ KG2F : KG -> F
+ PG2F : PG -> F
+ ker2trigs : (OP, List GF) -> GF
+ smp2trigs : PG -> GF
+ sup2trigs : (UP, GF) -> GF
+
+ nth := R has RetractableTo(Integer) and F has RadicalCategory
+
+ GR2F g == real(g)::F + sqrt(-(1::F)) * imag(g)::F
+ KG2F k == map(FG2F, k)$ExpressionSpaceFunctions2(FG, F)
+ FG2F f == (PG2F numer f) / (PG2F denom f)
+ F2FG f == map(#1::GR, f)$FunctionSpaceFunctions2(R,F,GR,FG)
+ GF2FG f == (F2FG real f) + complex(0, 1)$GR ::FG * F2FG imag f
+ GR2GF gr == complex(real(gr)::F, imag(gr)::F)
+
+-- This expects the argument to have only tan and atans left.
+-- Does a half-angle correction if k is not in the initial kernel list.
+ ker2explogs(k, l, lx) ==
+ empty?([v for v in variables(kf := k::FG) |
+ member?(v, lx)]$List(SY)) => kf
+ empty?(args := [trigs2explogs(a, l, lx)
+ for a in argument k]$List(FG)) => kf
+ im := complex(0, 1)$GR :: FG
+ z := first args
+ is?(k, "tan"::Symbol) =>
+ e := (member?(k, l) => exp(im * z) ** 2; exp(2 * im * z))
+ - im * (e - 1) /$FG (e + 1)
+ is?(k, "atan"::Symbol) =>
+ im * log((1 -$FG im *$FG z)/$FG (1 +$FG im *$FG z))$FG / (2::FG)
+ (operator k) args
+
+ trigs2explogs(f, l, lx) ==
+ smp2explogs(numer f, l, lx) / smp2explogs(denom f, l, lx)
+
+ -- return op(arg) as f + %i g
+ -- op is already an operator with semantics over R, not GR
+ ker2trigs(op, arg) ==
+ "and"/[zero? imag x for x in arg] =>
+ complex(op [real x for x in arg]$List(F), 0)
+ a := first arg
+ is?(op, "exp"::Symbol) => exp a
+ is?(op, "log"::Symbol) => log a
+ is?(op, "sin"::Symbol) => sin a
+ is?(op, "cos"::Symbol) => cos a
+ is?(op, "tan"::Symbol) => tan a
+ is?(op, "cot"::Symbol) => cot a
+ is?(op, "sec"::Symbol) => sec a
+ is?(op, "csc"::Symbol) => csc a
+ is?(op, "asin"::Symbol) => asin a
+ is?(op, "acos"::Symbol) => acos a
+ is?(op, "atan"::Symbol) => atan a
+ is?(op, "acot"::Symbol) => acot a
+ is?(op, "asec"::Symbol) => asec a
+ is?(op, "acsc"::Symbol) => acsc a
+ is?(op, "sinh"::Symbol) => sinh a
+ is?(op, "cosh"::Symbol) => cosh a
+ is?(op, "tanh"::Symbol) => tanh a
+ is?(op, "coth"::Symbol) => coth a
+ is?(op, "sech"::Symbol) => sech a
+ is?(op, "csch"::Symbol) => csch a
+ is?(op, "asinh"::Symbol) => asinh a
+ is?(op, "acosh"::Symbol) => acosh a
+ is?(op, "atanh"::Symbol) => atanh a
+ is?(op, "acoth"::Symbol) => acoth a
+ is?(op, "asech"::Symbol) => asech a
+ is?(op, "acsch"::Symbol) => acsch a
+ is?(op, "abs"::Symbol) => sqrt(norm a)::GF
+ nth and is?(op, NTHR) => nthRoot(a, retract(second arg)@Z)
+ error "ker2trigs: cannot convert kernel to gaussian function"
+
+ sup2trigs(p, f) ==
+ map(smp2trigs, p)$SparseUnivariatePolynomialFunctions2(PG, GF) f
+
+ smp2trigs p ==
+ map(explogs2trigs(#1::FG),GR2GF, p)$PolynomialCategoryLifting(
+ IndexedExponents KG, KG, GR, PG, GF)
+
+ explogs2trigs f ==
+ (m := mainKernel f) case "failed" =>
+ GR2GF(retract(numer f)@GR) / GR2GF(retract(denom f)@GR)
+ op := operator(operator(k := m::KG))$F
+ arg := [explogs2trigs x for x in argument k]
+ num := univariate(numer f, k)
+ den := univariate(denom f, k)
+ is?(op, "exp"::Symbol) =>
+ e := exp real first arg
+ y := imag first arg
+ g := complex(e * cos y, e * sin y)$GF
+ gi := complex(cos(y) / e, - sin(y) / e)$GF
+ supexp(num,g,gi,b := (degree num)::Z quo 2)/supexp(den,g,gi,b)
+ sup2trigs(num, g := ker2trigs(op, arg)) / sup2trigs(den, g)
+
+ supexp(p, f1, f2, bse) ==
+ ans:GF := 0
+ while p ^= 0 repeat
+ g := explogs2trigs(leadingCoefficient(p)::FG)
+ if ((d := degree(p)::Z - bse) >= 0) then
+ ans := ans + g * f1 ** d
+ else ans := ans + g * f2 ** (-d)
+ p := reductum p
+ ans
+
+ PG2F p ==
+ map(KG2F, GR2F, p)$PolynomialCategoryLifting(IndexedExponents KG,
+ KG, GR, PG, F)
+
+ smp2explogs(p, l, lx) ==
+ map(ker2explogs(#1, l, lx), #1::FG, p)$PolynomialCategoryLifting(
+ IndexedExponents KG, KG, GR, PG, FG)
+
+@
+\section{package TRIGMNIP TrigonometricManipulations}
+<<package TRIGMNIP TrigonometricManipulations>>=
+)abbrev package TRIGMNIP TrigonometricManipulations
+++ Trigs to/from exps and logs
+++ Author: Manuel Bronstein
+++ Date Created: 4 April 1988
+++ Date Last Updated: 14 February 1994
+++ Description:
+++ \spadtype{TrigonometricManipulations} provides transformations from
+++ trigonometric functions to complex exponentials and logarithms, and back.
+++ Keywords: trigonometric, function, manipulation.
+TrigonometricManipulations(R, F): Exports == Implementation where
+ R : Join(GcdDomain, OrderedSet, RetractableTo Integer,
+ LinearlyExplicitRingOver Integer)
+ F : Join(AlgebraicallyClosedField, TranscendentalFunctionCategory,
+ FunctionSpace R)
+
+ Z ==> Integer
+ SY ==> Symbol
+ K ==> Kernel F
+ FG ==> Expression Complex R
+
+ Exports ==> with
+ complexNormalize: F -> F
+ ++ complexNormalize(f) rewrites \spad{f} using the least possible number
+ ++ of complex independent kernels.
+ complexNormalize: (F, SY) -> F
+ ++ complexNormalize(f, x) rewrites \spad{f} using the least possible
+ ++ number of complex independent kernels involving \spad{x}.
+ complexElementary: F -> F
+ ++ complexElementary(f) rewrites \spad{f} in terms of the 2 fundamental
+ ++ complex transcendental elementary functions: \spad{log, exp}.
+ complexElementary: (F, SY) -> F
+ ++ complexElementary(f, x) rewrites the kernels of \spad{f} involving
+ ++ \spad{x} in terms of the 2 fundamental complex
+ ++ transcendental elementary functions: \spad{log, exp}.
+ trigs : F -> F
+ ++ trigs(f) rewrites all the complex logs and exponentials
+ ++ appearing in \spad{f} in terms of trigonometric functions.
+ real : F -> F
+ ++ real(f) returns the real part of \spad{f} where \spad{f} is a complex
+ ++ function.
+ imag : F -> F
+ ++ imag(f) returns the imaginary part of \spad{f} where \spad{f}
+ ++ is a complex function.
+ real? : F -> Boolean
+ ++ real?(f) returns \spad{true} if \spad{f = real f}.
+ complexForm: F -> Complex F
+ ++ complexForm(f) returns \spad{[real f, imag f]}.
+
+ Implementation ==> add
+ import ElementaryFunctionSign(R, F)
+ import InnerTrigonometricManipulations(R,F,FG)
+ import ElementaryFunctionStructurePackage(R, F)
+ import ElementaryFunctionStructurePackage(Complex R, FG)
+
+ s1 := sqrt(-1::F)
+ ipi := pi()$F * s1
+
+ K2KG : K -> Kernel FG
+ kcomplex : K -> Union(F, "failed")
+ locexplogs : F -> FG
+ localexplogs : (F, F, List SY) -> FG
+ complexKernels: F -> Record(ker: List K, val: List F)
+
+ K2KG k == retract(tan F2FG first argument k)@Kernel(FG)
+ real? f == empty?(complexKernels(f).ker)
+ real f == real complexForm f
+ imag f == imag complexForm f
+
+-- returns [[k1,...,kn], [v1,...,vn]] such that ki should be replaced by vi
+ complexKernels f ==
+ lk:List(K) := empty()
+ lv:List(F) := empty()
+ for k in tower f repeat
+ if (u := kcomplex k) case F then
+ lk := concat(k, lk)
+ lv := concat(u::F, lv)
+ [lk, lv]
+
+-- returns f if it is certain that k is not a real kernel and k = f,
+-- "failed" otherwise
+ kcomplex k ==
+ op := operator k
+ is?(k, "nthRoot"::SY) =>
+ arg := argument k
+ even?(retract(n := second arg)@Z) and ((u := sign(first arg)) case Z)
+ and (u::Z < 0) => op(s1, n / 2::F) * op(- first arg, n)
+ "failed"
+ is?(k, "log"::SY) and ((u := sign(a := first argument k)) case Z)
+ and (u::Z < 0) => op(- a) + ipi
+ "failed"
+
+ complexForm f ==
+ empty?((l := complexKernels f).ker) => complex(f, 0)
+ explogs2trigs locexplogs eval(f, l.ker, l.val)
+
+ locexplogs f ==
+ any?(has?(#1, "rtrig"),
+ operators(g := realElementary f))$List(BasicOperator) =>
+ localexplogs(f, g, variables g)
+ F2FG g
+
+ complexNormalize(f, x) ==
+ any?(has?(operator #1, "rtrig"),
+ [k for k in tower(g := realElementary(f, x))
+ | member?(x, variables(k::F))]$List(K))$List(K) =>
+ FG2F(rischNormalize(localexplogs(f, g, [x]), x).func)
+ rischNormalize(g, x).func
+
+ complexNormalize f ==
+ l := variables(g := realElementary f)
+ any?(has?(#1, "rtrig"), operators g)$List(BasicOperator) =>
+ h := localexplogs(f, g, l)
+ for x in l repeat h := rischNormalize(h, x).func
+ FG2F h
+ for x in l repeat g := rischNormalize(g, x).func
+ g
+
+ complexElementary(f, x) ==
+ any?(has?(operator #1, "rtrig"),
+ [k for k in tower(g := realElementary(f, x))
+ | member?(x, variables(k::F))]$List(K))$List(K) =>
+ FG2F localexplogs(f, g, [x])
+ g
+
+ complexElementary f ==
+ any?(has?(#1, "rtrig"),
+ operators(g := realElementary f))$List(BasicOperator) =>
+ FG2F localexplogs(f, g, variables g)
+ g
+
+ localexplogs(f, g, lx) ==
+ trigs2explogs(F2FG g, [K2KG k for k in tower f
+ | is?(k, "tan"::SY) or is?(k, "cot"::SY)], lx)
+
+ trigs f ==
+ real? f => f
+ g := explogs2trigs F2FG f
+ real g + s1 * imag g
+
+@
+\section{package CTRIGMNP ComplexTrigonometricManipulations}
+<<package CTRIGMNP ComplexTrigonometricManipulations>>=
+)abbrev package CTRIGMNP ComplexTrigonometricManipulations
+++ Real and Imaginary parts of complex functions
+++ Author: Manuel Bronstein
+++ Date Created: 11 June 1993
+++ Date Last Updated: 14 June 1993
+++ Description:
+++ \spadtype{ComplexTrigonometricManipulations} provides function that
+++ compute the real and imaginary parts of complex functions.
+++ Keywords: complex, function, manipulation.
+ComplexTrigonometricManipulations(R, F): Exports == Implementation where
+ R : Join(IntegralDomain, OrderedSet, RetractableTo Integer)
+ F : Join(AlgebraicallyClosedField, TranscendentalFunctionCategory,
+ FunctionSpace Complex R)
+
+
+ SY ==> Symbol
+ FR ==> Expression R
+ K ==> Kernel F
+
+
+ Exports ==> with
+ complexNormalize: F -> F
+ ++ complexNormalize(f) rewrites \spad{f} using the least possible number
+ ++ of complex independent kernels.
+ complexNormalize: (F, SY) -> F
+ ++ complexNormalize(f, x) rewrites \spad{f} using the least possible
+ ++ number of complex independent kernels involving \spad{x}.
+ complexElementary: F -> F
+ ++ complexElementary(f) rewrites \spad{f} in terms of the 2 fundamental
+ ++ complex transcendental elementary functions: \spad{log, exp}.
+ complexElementary: (F, SY) -> F
+ ++ complexElementary(f, x) rewrites the kernels of \spad{f} involving
+ ++ \spad{x} in terms of the 2 fundamental complex
+ ++ transcendental elementary functions: \spad{log, exp}.
+ real : F -> FR
+ ++ real(f) returns the real part of \spad{f} where \spad{f} is a complex
+ ++ function.
+ imag : F -> FR
+ ++ imag(f) returns the imaginary part of \spad{f} where \spad{f}
+ ++ is a complex function.
+ real? : F -> Boolean
+ ++ real?(f) returns \spad{true} if \spad{f = real f}.
+ trigs : F -> F
+ ++ trigs(f) rewrites all the complex logs and exponentials
+ ++ appearing in \spad{f} in terms of trigonometric functions.
+ complexForm: F -> Complex FR
+ ++ complexForm(f) returns \spad{[real f, imag f]}.
+
+ Implementation ==> add
+ import InnerTrigonometricManipulations(R, FR, F)
+ import ElementaryFunctionStructurePackage(Complex R, F)
+
+ rreal?: Complex R -> Boolean
+ kreal?: Kernel F -> Boolean
+ localexplogs : (F, F, List SY) -> F
+
+ real f == real complexForm f
+ imag f == imag complexForm f
+ rreal? r == zero? imag r
+ kreal? k == every?(real?, argument k)$List(F)
+ complexForm f == explogs2trigs f
+
+ trigs f ==
+ GF2FG explogs2trigs f
+
+ real? f ==
+ every?(rreal?, coefficients numer f)
+ and every?(rreal?, coefficients denom f) and every?(kreal?, kernels f)
+
+ localexplogs(f, g, lx) ==
+ trigs2explogs(g, [k for k in tower f
+ | is?(k, "tan"::SY) or is?(k, "cot"::SY)], lx)
+
+ complexElementary f ==
+ any?(has?(#1, "rtrig"),
+ operators(g := realElementary f))$List(BasicOperator) =>
+ localexplogs(f, g, variables g)
+ g
+
+ complexElementary(f, x) ==
+ any?(has?(operator #1, "rtrig"),
+ [k for k in tower(g := realElementary(f, x))
+ | member?(x, variables(k::F))]$List(K))$List(K) =>
+ localexplogs(f, g, [x])
+ g
+
+ complexNormalize(f, x) ==
+ any?(has?(operator #1, "rtrig"),
+ [k for k in tower(g := realElementary(f, x))
+ | member?(x, variables(k::F))]$List(K))$List(K) =>
+ (rischNormalize(localexplogs(f, g, [x]), x).func)
+ rischNormalize(g, x).func
+
+ complexNormalize f ==
+ l := variables(g := realElementary f)
+ any?(has?(#1, "rtrig"), operators g)$List(BasicOperator) =>
+ h := localexplogs(f, g, l)
+ for x in l repeat h := rischNormalize(h, x).func
+ h
+ for x in l repeat g := rischNormalize(g, x).func
+ g
+
+@
+\section{License}
+<<license>>=
+--Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
+--All rights reserved.
+--
+--Redistribution and use in source and binary forms, with or without
+--modification, are permitted provided that the following conditions are
+--met:
+--
+-- - Redistributions of source code must retain the above copyright
+-- notice, this list of conditions and the following disclaimer.
+--
+-- - Redistributions in binary form must reproduce the above copyright
+-- notice, this list of conditions and the following disclaimer in
+-- the documentation and/or other materials provided with the
+-- distribution.
+--
+-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the
+-- names of its contributors may be used to endorse or promote products
+-- derived from this software without specific prior written permission.
+--
+--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+--IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+--TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+--PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+--OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+--EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+--PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+--PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+--LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+--NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+--SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+@
+<<*>>=
+<<license>>
+
+-- SPAD files for the integration world should be compiled in the
+-- following order:
+--
+-- intaux rderf intrf curve curvepkg divisor pfo
+-- intalg intaf EFSTRUC rdeef intef irexpand integrat
+
+<<package SYMFUNC SymmetricFunctions>>
+<<package TANEXP TangentExpansions>>
+<<package EFSTRUC ElementaryFunctionStructurePackage>>
+<<package ITRIGMNP InnerTrigonometricManipulations>>
+<<package TRIGMNIP TrigonometricManipulations>>
+<<package CTRIGMNP ComplexTrigonometricManipulations>>
+@
+\eject
+\begin{thebibliography}{99}
+\bibitem{1} nothing
+\end{thebibliography}
+\end{document}