open-axiom-source 1.4.1+svn~2626-2ubuntu2 / usr / lib / open-axiom / src / algebra / fspace.spad

--Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
--All rights reserved.
--Copyright (C) 2007-2009, Gabriel Dos Reis.
--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.

-- SPAD files for the functional world should be compiled in the
-- following order:
--
--   op  kl  FSPACE  expr funcpkgs

)abbrev category ES ExpressionSpace
++ Category for domains on which operators can be applied
++ Author: Manuel Bronstein
++ Date Created: 22 March 1988
++ Date Last Updated: 27 May 1994
++ Description:
++ An expression space is a set which is closed under certain operators;
++ Keywords: operator, kernel, expression, space.
ExpressionSpace(): Category == Defn where
  N   ==> NonNegativeInteger
  K   ==> Kernel %
  OP  ==> BasicOperator
  SY  ==> Symbol

  Defn ==> Join(SetCategory, RetractableTo K,
                InnerEvalable(K, %), Evalable %) with
    elt          : (OP, %) -> %
      ++ elt(op,x) or op(x) applies the unary operator op to x.
    elt          : (OP, %, %) -> %
      ++ elt(op,x,y) or op(x, y) applies the binary operator op to x and y.
    elt          : (OP, %, %, %) -> %
      ++ elt(op,x,y,z) or op(x, y, z) applies the ternary operator op to x, y and z.
    elt          : (OP, %, %, %, %) -> %
      ++ elt(op,x,y,z,t) or op(x, y, z, t) applies the 4-ary operator op to x, y, z and t.
    elt          : (OP, List %) -> %
      ++ elt(op,[x1,...,xn]) or op([x1,...,xn]) applies the n-ary operator op to x1,...,xn.
    subst        : (%, Equation %) -> %
      ++ subst(f, k = g) replaces the kernel k by g formally in f.
    subst        : (%, List Equation %) -> %
      ++ subst(f, [k1 = g1,...,kn = gn]) replaces the kernels k1,...,kn
      ++ by g1,...,gn formally in f.
    subst        : (%, List K, List %) -> %
      ++ subst(f, [k1...,kn], [g1,...,gn]) replaces the kernels k1,...,kn
      ++ by g1,...,gn formally in f.
    box          : % -> %
      ++ box(f) returns f with a 'box' around it that prevents f from
      ++ being evaluated when operators are applied to it. For example,
      ++ \spad{log(1)} returns 0, but \spad{log(box 1)}
      ++ returns the formal kernel log(1).
    box          : List % -> %
      ++ box([f1,...,fn]) returns \spad{(f1,...,fn)} with a 'box'
      ++ around them that
      ++ prevents the fi from being evaluated when operators are applied to
      ++ them, and makes them applicable to a unary operator. For example,
      ++ \spad{atan(box [x, 2])} returns the formal kernel \spad{atan(x, 2)}.
    paren        : % -> %
      ++ paren(f) returns (f). This prevents f from
      ++ being evaluated when operators are applied to it. For example,
      ++ \spad{log(1)} returns 0, but \spad{log(paren 1)} returns the
      ++ formal kernel log((1)).
    paren        : List % -> %
      ++ paren([f1,...,fn]) returns \spad{(f1,...,fn)}. This
      ++ prevents the fi from being evaluated when operators are applied to
      ++ them, and makes them applicable to a unary operator. For example,
      ++ \spad{atan(paren [x, 2])} returns the formal
      ++ kernel \spad{atan((x, 2))}.
    distribute   : % -> %
      ++ distribute(f) expands all the kernels in f that are
      ++ formally enclosed by a \spadfunFrom{box}{ExpressionSpace}
      ++ or \spadfunFrom{paren}{ExpressionSpace} expression.
    distribute   : (%, %) -> %
      ++ distribute(f, g) expands all the kernels in f that contain g in their
      ++ arguments and that are formally
      ++ enclosed by a \spadfunFrom{box}{ExpressionSpace}
      ++ or a \spadfunFrom{paren}{ExpressionSpace} expression.
    height       : %  -> N
      ++ height(f) returns the highest nesting level appearing in f.
      ++ Constants have height 0. Symbols have height 1. For any
      ++ operator op and expressions f1,...,fn, \spad{op(f1,...,fn)} has
      ++ height equal to \spad{1 + max(height(f1),...,height(fn))}.
    mainKernel   : %  -> Union(K, "failed")
      ++ mainKernel(f) returns a kernel of f with maximum nesting level, or
      ++ if f has no kernels (i.e. f is a constant).
    kernels      : %  -> List K
      ++ kernels(f) returns the list of all the top-level kernels
      ++ appearing in f, but not the ones appearing in the arguments
      ++ of the top-level kernels.
    tower        : %  -> List K
      ++ tower(f) returns all the kernels appearing in f, no matter
      ++ what their levels are.
    operators    : %  -> List OP
      ++ operators(f) returns all the basic operators appearing in f,
      ++ no matter what their levels are.
    operator     : OP -> OP
      ++ operator(op) returns a copy of op with the domain-dependent
      ++ properties appropriate for %.
    belong?      : OP -> Boolean
      ++ belong?(op) tests if % accepts op as applicable to its
      ++ elements.
    is?          : (%, OP)     -> Boolean
      ++ is?(x, op) tests if x is a kernel and is its operator is op.
    is?          : (%, SY) -> Boolean
      ++ is?(x, s) tests if x is a kernel and is the name of its
      ++ operator is s.
    kernel       : (OP, %) -> %
      ++ kernel(op, x) constructs op(x) without evaluating it.
    kernel       : (OP, List %) -> %
      ++ kernel(op, [f1,...,fn]) constructs \spad{op(f1,...,fn)} without
      ++ evaluating it.
    map          : (% -> %, K) -> %
      ++ map(f, k) returns \spad{op(f(x1),...,f(xn))} where
      ++ \spad{k = op(x1,...,xn)}.
    freeOf?      : (%, %)  -> Boolean
      ++ freeOf?(x, y) tests if x does not contain any occurrence of y,
      ++ where y is a single kernel.
    freeOf?      : (%, SY) -> Boolean
      ++ freeOf?(x, s) tests if x does not contain any operator
      ++ whose name is s.
    eval         : (%, List SY, List(% -> %)) -> %
      ++ eval(x, [s1,...,sm], [f1,...,fm]) replaces
      ++ every \spad{si(a)} in x by \spad{fi(a)} for any \spad{a}.
    eval         : (%, List SY, List(List % -> %)) -> %
      ++ eval(x, [s1,...,sm], [f1,...,fm]) replaces
      ++ every \spad{si(a1,...,an)} in x by
      ++ \spad{fi(a1,...,an)} for any \spad{a1},...,\spad{an}.
    eval         : (%, SY, List % -> %) -> %
      ++ eval(x, s, f) replaces every \spad{s(a1,..,am)} in x
      ++ by \spad{f(a1,..,am)} for any \spad{a1},...,\spad{am}.
    eval         : (%, SY, % -> %) -> %
      ++ eval(x, s, f) replaces every \spad{s(a)} in x by \spad{f(a)}
      ++ for any \spad{a}.
    eval         : (%, List OP, List(% -> %)) -> %
      ++ eval(x, [s1,...,sm], [f1,...,fm]) replaces
      ++ every \spad{si(a)} in x by \spad{fi(a)} for any \spad{a}.
    eval         : (%, List OP, List(List % -> %)) -> %
      ++ eval(x, [s1,...,sm], [f1,...,fm]) replaces
      ++ every \spad{si(a1,...,an)} in x by
      ++ \spad{fi(a1,...,an)} for any \spad{a1},...,\spad{an}.
    eval         : (%, OP, List % -> %) -> %
      ++ eval(x, s, f) replaces every \spad{s(a1,..,am)} in x
      ++ by \spad{f(a1,..,am)} for any \spad{a1},...,\spad{am}.
    eval         : (%, OP, % -> %) -> %
      ++ eval(x, s, f) replaces every \spad{s(a)} in x by \spad{f(a)}
      ++ for any \spad{a}.
    if % has Ring then
      minPoly: K -> SparseUnivariatePolynomial %
        ++ minPoly(k) returns p such that \spad{p(k) = 0}.
      definingPolynomial: % -> %
        ++ definingPolynomial(x) returns an expression p such that
        ++ \spad{p(x) = 0}.
    if % has RetractableTo Integer then
      even?: % -> Boolean
        ++ even? x is true if x is an even integer.
      odd? : % -> Boolean
        ++ odd? x is true if x is an odd integer.

   add

-- the 7 functions not provided are:
--        kernels   minPoly   definingPolynomial
--        coerce:K -> %  eval:(%, List K, List %) -> %
--        subst:(%, List K, List %) -> %
--        eval:(%, List Symbol, List(List % -> %)) -> %

    macro PAREN  == '%paren
    macro BOX == '%box
    macro DUMMYVAR == '%dummyVar
    allKernels: %      -> List K
    allk      : List % -> List K
    unwrap    : (List K, %) -> %
    okkernel  : (OP, List %) -> %
    mkKerLists: List Equation % -> Record(lstk: List K, lstv:List %)

    oppren := operator(PAREN)$CommonOperators()
    opbox  := operator(BOX)$CommonOperators()

    box(x:%)     == box [x]
    paren(x:%)   == paren [x]
    belong? op   == op = oppren or op = opbox
    tower f      == sort! allKernels f
    allk l       == reduce("setUnion", [allKernels f for f in l], nil$List(K))
    operators f  == [operator k for k in allKernels f]
    height f     == reduce("max", [height k for k in kernels f], 0)
    freeOf?(x:%, s:SY) == 
      not member?(s, [name operator k for k in allKernels x])
    distribute x == unwrap([k for k in allKernels x | is?(k, oppren)], x)
    box(l:List %)                  == opbox l
    paren(l:List %)                == oppren l
    freeOf?(x:%, k:%)              == not member?(retract k, allKernels x)
    kernel(op:OP, arg:%)           == kernel(op, [arg])
    elt(op:OP, x:%)                == op [x]
    elt(op:OP, x:%, y:%)           == op [x, y]
    elt(op:OP, x:%, y:%, z:%)      == op [x, y, z]
    elt(op:OP, x:%, y:%, z:%, t:%) == op [x, y, z, t]
    eval(x:%, s:SY, f:List % -> %) == eval(x, [s], [f])
    eval(x:%, s:OP, f:List % -> %) == eval(x, [name s], [f])
    eval(x:%, s:SY, f:% -> %)      == eval(x, [s], [f first #1])
    eval(x:%, s:OP, f:% -> %)      == eval(x, [s], [f first #1])
    subst(x:%, e:Equation %)       == subst(x, [e])

    eval(x:%, ls:List OP, lf:List(% -> %)) ==
      eval(x, ls, [f first #1 for f in lf]$List(List % -> %))

    eval(x:%, ls:List SY, lf:List(% -> %)) ==
      eval(x, ls, [f first #1 for f in lf]$List(List % -> %))

    eval(x:%, ls:List OP, lf:List(List % -> %)) ==
      eval(x, [name s for s in ls]$List(SY), lf)

    map(fn, k) ==
      (l := [fn x for x in argument k]$List(%)) = argument k => k::%
      (operator k) l

    operator op ==
      is?(op, PAREN) => oppren
      is?(op, BOX) => opbox
      error "Unknown operator"

    mainKernel x ==
      empty?(l := kernels x) => "failed"
      n := height(k := first l)
      for kk in rest l repeat
        if height(kk) > n then
          n := height kk
          k := kk
      k

-- takes all the kernels except for the dummy variables, which are second
-- arguments of rootOf's, integrals, sums and products which appear only in
-- their first arguments
    allKernels f ==
      s := removeDuplicates(l := kernels f)
      for k in l repeat
          t :=
              (u := property(operator k, DUMMYVAR)) case None =>
                  arg := argument k
                  s0  := remove!(retract(second arg)@K, allKernels first arg)
                  arg := rest rest arg
                  n   := (u::None) pretend N
                  if n > 1 then arg := rest arg
                  setUnion(s0, allk arg)
              allk argument k
          s := setUnion(s, t)
      s

    kernel(op:OP, args:List %) ==
      not belong? op => error "Unknown operator"
      okkernel(op, args)

    okkernel(op, l) ==
      kernel(op, l, 1 + reduce("max", [height f for f in l], 0))$K :: %

    elt(op:OP, args:List %) ==
      not belong? op => error "Unknown operator"
      (#args)::Arity ~= arity op and (arity op ~= arbitrary()) =>
        error "Wrong number of arguments"
      (v := evaluate(op,args)$BasicOperatorFunctions1(%)) case % => v::%
      okkernel(op, args)

    retract f ==
      (k := mainKernel f) case "failed" => error "not a kernel"
      k::K::% ~= f => error "not a kernel"
      k::K

    retractIfCan f ==
      (k := mainKernel f) case "failed" => "failed"
      k::K::% ~= f => "failed"
      k

    is?(f:%, s:SY) ==
      (k := retractIfCan f) case "failed" => false
      is?(k::K, s)

    is?(f:%, op:OP) ==
      (k := retractIfCan f) case "failed" => false
      is?(k::K, op)

    unwrap(l, x) ==
      for k in reverse! l repeat
        x := eval(x, k, first argument k)
      x

    distribute(x, y) ==
      ky := retract y
      unwrap([k for k in allKernels x |
              is?(k, '%paren) and member?(ky, allKernels(k::%))], x)

    -- in case of conflicting substitutions e.g. [x = a, x = b],
    -- the first one prevails.
    -- this is not part of the semantics of the function, but just
    -- a feature of this implementation.
    eval(f:%, leq:List Equation %) ==
      rec := mkKerLists leq
      eval(f, rec.lstk, rec.lstv)

    subst(f:%, leq:List Equation %) ==
      rec := mkKerLists leq
      subst(f, rec.lstk, rec.lstv)

    mkKerLists leq ==
      lk := empty()$List(K)
      lv := empty()$List(%)
      for eq in leq repeat
        (k := retractIfCan(lhs eq)@Union(K, "failed")) case "failed" =>
                          error "left hand side must be a single kernel"
        if not member?(k::K, lk) then
          lk := concat(k::K, lk)
          lv := concat(rhs eq, lv)
      [lk, lv]

    if % has RetractableTo Integer then
       intpred?: (%, Integer -> Boolean) -> Boolean

       even? x == intpred?(x, even?)
       odd? x  == intpred?(x, odd?)

       intpred?(x, pred?) ==
           (u := retractIfCan(x)@Union(Integer, "failed")) case Integer
                  and pred?(u::Integer)

)abbrev package ES1 ExpressionSpaceFunctions1
++ Lifting of maps from expression spaces to kernels over them
++ Author: Manuel Bronstein
++ Date Created: 23 March 1988
++ Date Last Updated: 19 April 1991
++ Description:
++   This package allows a map from any expression space into any object
++   to be lifted to a kernel over the expression set, using a given
++   property of the operator of the kernel.
-- should not be exposed
ExpressionSpaceFunctions1(F:ExpressionSpace, S:Type): with
    map: (F -> S, String, Kernel F) -> S
      ++ map(f, p, k) uses the property p of the operator
      ++ of k, in order to lift f and apply it to k.

  == add
    --  prop  contains an evaluation function List S -> S
    map(F2S, prop, k) ==
      args := [F2S x for x in argument k]$List(S)
      (p := property(operator k, prop)) case None =>
                                  ((p::None) pretend (List S -> S)) args
      error "Operator does not have required property"

)abbrev package ES2 ExpressionSpaceFunctions2
++ Lifting of maps from expression spaces to kernels over them
++ Author: Manuel Bronstein
++ Date Created: 23 March 1988
++ Date Last Updated: 19 April 1991
++ Description:
++ This package allows a mapping E -> F to be lifted to a kernel over E;
++ This lifting can fail if the operator of the kernel cannot be applied
++ in F; Do not use this package with E = F, since this may
++ drop some properties of the operators.
ExpressionSpaceFunctions2(E:ExpressionSpace, F:ExpressionSpace): with
    map: (E -> F, Kernel E) -> F
      ++ map(f, k) returns \spad{g = op(f(a1),...,f(an))} where
      ++ \spad{k = op(a1,...,an)}.
  == add
    map(f, k) ==
      (operator(operator k)$F) [f x for x in argument k]$List(F)

)abbrev category FS FunctionSpace
++ Category for formal functions
++ Author: Manuel Bronstein
++ Date Created: 22 March 1988
++ Date Last Updated: 14 February 1994
++ Description:
++   A space of formal functions with arguments in an arbitrary
++   ordered set.
++ Keywords: operator, kernel, function.
FunctionSpace(R: SetCategory): Category == Definition where
  OP ==> BasicOperator
  O  ==> OutputForm
  SY ==> Symbol
  N  ==> NonNegativeInteger
  Z  ==> Integer
  K  ==> Kernel %
  Q  ==> Fraction R
  PR ==> Polynomial R
  MP ==> SparseMultivariatePolynomial(R, K)
  QF==> PolynomialCategoryQuotientFunctions(IndexedExponents K,K,R,MP,%)

  Definition ==> Join(ExpressionSpace, RetractableTo SY, Patternable R,
                     FullyPatternMatchable R, FullyRetractableTo R) with
       ground?   : % -> Boolean
         ++ ground?(f) tests if f is an element of R.
       ground    : % -> R
         ++ ground(f) returns f as an element of R.
         ++ An error occurs if f is not an element of R.
       variables : %  -> List SY
         ++ variables(f) returns the list of all the variables of f.
       applyQuote: (SY, %) -> %
         ++ applyQuote(foo, x) returns \spad{'foo(x)}.
       applyQuote: (SY, %, %) -> %
         ++ applyQuote(foo, x, y) returns \spad{'foo(x,y)}.
       applyQuote: (SY, %, %, %) -> %
         ++ applyQuote(foo, x, y, z) returns \spad{'foo(x,y,z)}.
       applyQuote: (SY, %, %, %, %) -> %
         ++ applyQuote(foo, x, y, z, t) returns \spad{'foo(x,y,z,t)}.
       applyQuote: (SY, List %) -> %
         ++ applyQuote(foo, [x1,...,xn]) returns \spad{'foo(x1,...,xn)}.
       if R has ConvertibleTo InputForm then
         ConvertibleTo InputForm
         eval     : (%, SY) -> %
           ++ eval(f, foo) unquotes all the foo's in f.
         eval     : (%, List SY) -> %
           ++ eval(f, [foo1,...,foon]) unquotes all the \spad{fooi}'s in f.
         eval     : % -> %
           ++ eval(f) unquotes all the quoted operators in f.
         eval     : (%, OP, %, SY) -> %
           ++ eval(x, s, f, y) replaces every \spad{s(a)} in x by \spad{f(y)}
           ++ with \spad{y} replaced by \spad{a} for any \spad{a}.
         eval     : (%, List OP, List %, SY) -> %
           ++ eval(x, [s1,...,sm], [f1,...,fm], y) replaces every
           ++ \spad{si(a)} in x by \spad{fi(y)}
           ++ with \spad{y} replaced by \spad{a} for any \spad{a}.
       if R has SemiGroup then
         Monoid
         -- the following line is necessary because of a compiler bug
         **   : (%, N) -> %
           ++ x**n returns x * x * x * ... * x (n times).
         isTimes: % -> Union(List %, "failed")
           ++ isTimes(p) returns \spad{[a1,...,an]}
           ++ if \spad{p = a1*...*an} and \spad{n > 1}.
         isExpt : % -> Union(Record(var:K,exponent:Z),"failed")
           ++ isExpt(p) returns \spad{[x, n]} if \spad{p = x**n}
           ++ and \spad{n <> 0}.
       if R has Group then Group
       if R has AbelianSemiGroup then
         AbelianMonoid
         isPlus: % -> Union(List %, "failed")
           ++ isPlus(p) returns \spad{[m1,...,mn]}
           ++ if \spad{p = m1 +...+ mn} and \spad{n > 1}.
         isMult: % -> Union(Record(coef:Z, var:K),"failed")
           ++ isMult(p) returns \spad{[n, x]} if \spad{p = n * x}
           ++ and \spad{n <> 0}.
       if R has AbelianGroup then AbelianGroup
       if R has Ring then
         Ring
         RetractableTo PR
         PartialDifferentialRing SY
         FullyLinearlyExplicitRingOver R
         coerce    : MP -> %
           ++ coerce(p) returns p as an element of %.
         numer     : %  -> MP
           ++ numer(f) returns the
           ++ numerator of f viewed as a polynomial in the kernels over R
           ++ if R is an integral domain. If not, then numer(f) = f viewed
           ++ as a polynomial in the kernels over R.
           -- DO NOT change this meaning of numer!  MB 1/90
         numerator : % -> %
           ++ numerator(f) returns the numerator of \spad{f} converted to %.
         isExpt:(%,OP) -> Union(Record(var:K,exponent:Z),"failed")
           ++ isExpt(p,op) returns \spad{[x, n]} if \spad{p = x**n}
           ++ and \spad{n <> 0} and \spad{x = op(a)}.
         isExpt:(%,SY) -> Union(Record(var:K,exponent:Z),"failed")
           ++ isExpt(p,f) returns \spad{[x, n]} if \spad{p = x**n}
           ++ and \spad{n <> 0} and \spad{x = f(a)}.
         isPower   : % -> Union(Record(val:%,exponent:Z),"failed")
           ++ isPower(p) returns \spad{[x, n]} if \spad{p = x**n}
           ++ and \spad{n <> 0}.
         eval: (%, List SY, List N, List(% -> %)) -> %
           ++ eval(x, [s1,...,sm], [n1,...,nm], [f1,...,fm]) replaces
           ++ every \spad{si(a)**ni} in x by \spad{fi(a)} for any \spad{a}.
         eval: (%, List SY, List N, List(List % -> %)) -> %
           ++ eval(x, [s1,...,sm], [n1,...,nm], [f1,...,fm]) replaces
           ++ every \spad{si(a1,...,an)**ni} in x by \spad{fi(a1,...,an)}
           ++ for any a1,...,am.
         eval: (%, SY, N, List % -> %) -> %
           ++ eval(x, s, n, f) replaces every \spad{s(a1,...,am)**n} in x
           ++ by \spad{f(a1,...,am)} for any a1,...,am.
         eval: (%, SY, N, % -> %) -> %
           ++ eval(x, s, n, f) replaces every \spad{s(a)**n} in x
           ++ by \spad{f(a)} for any \spad{a}.
       if R has CharacteristicZero then CharacteristicZero
       if R has CharacteristicNonZero then CharacteristicNonZero
       if R has CommutativeRing then
         Algebra R
       if R has IntegralDomain then
         Field
         RetractableTo Fraction PR
         convert   : Factored % -> %
           ++ convert(f1\^e1 ... fm\^em) returns \spad{(f1)\^e1 ... (fm)\^em}
           ++ as an element of %, using formal kernels
           ++ created using a \spadfunFrom{paren}{ExpressionSpace}.
         denom     : %  -> MP
           ++ denom(f) returns the denominator of f viewed as a
           ++ polynomial in the kernels over R.
         denominator : % -> %
           ++ denominator(f) returns the denominator of \spad{f} converted to %.
         /       : (MP, MP) -> %
           ++ p1/p2 returns the quotient of p1 and p2 as an element of %.
         coerce    : Q  -> %
           ++ coerce(q) returns q as an element of %.
         coerce    : Polynomial Q -> %
           ++ coerce(p) returns p as an element of %.
         coerce    : Fraction Polynomial Q -> %
           ++ coerce(f) returns f as an element of %.
         univariate: (%, K) -> Fraction SparseUnivariatePolynomial %
           ++ univariate(f, k) returns f viewed as a univariate fraction in k.
         if R has RetractableTo Z then RetractableTo Fraction Z
   add
    macro ODD  == 'odd
    macro EVEN == 'even

    macro SPECIALDIFF  == '%specialDiff
    macro SPECIALDISP  == '%specialDisp
    macro SPECIALEQUAL == '%specialEqual
    macro SPECIALINPUT == '%specialInput

    import BasicOperatorFunctions1(%)

    -- these are needed in Ring only, but need to be declared here
    -- because of compiler bug: if they are declared inside the Ring
    -- case, then they are not visible inside the IntegralDomain case.
    smpIsMult : MP -> Union(Record(coef:Z, var:K),"failed")
    smpret    : MP -> Union(PR, "failed")
    smpeval   : (MP, List K, List %) -> %
    smpsubst  : (MP, List K, List %) -> %
    smpderiv  : (MP, SY) -> %
    smpunq    : (MP, List SY, Boolean) -> %
    kerderiv  : (K, SY)  -> %
    kderiv    : K -> List %
    opderiv   : (OP, N) -> List(List % -> %)
    smp2O     : MP -> O
    bestKernel: List K -> K
    worse?    : (K, K) -> Boolean
    diffArg   : (List %, OP, N) -> List %
    substArg  : (OP, List %, Z, %) -> %
    dispdiff  : List % -> Record(name:O, sub:O, arg:List O, level:N)
    ddiff     : List % -> O
    diffEval  : List % -> %
    dfeval    : (List %, K) -> %
    smprep    : (List SY, List N, List(List % -> %), MP) -> %
    diffdiff  : (List %, SY) -> %
    diffdiff0 : (List %, SY, %, K, List %) -> %
    subs      : (% -> %, K) -> %
    symsub    : (SY, Z) -> SY
    kunq      : (K, List SY, Boolean) -> %
    pushunq   : (List SY, List %) -> List %
    notfound  : (K -> %, List K, K) -> %

    equaldiff : (K,K)->Boolean
    debugA: (List % ,List %,Boolean) -> Boolean
    opdiff := operator('%diff)$CommonOperators()
    opquote := operator('applyQuote)$CommonOperators

    ground? x                == retractIfCan(x)@Union(R,"failed") case R
    ground  x                == retract x
    coerce(x:SY):%             == kernel(x)@K :: %
    retract(x:%):SY            == symbolIfCan(retract(x)@K)::SY
    applyQuote(s:SY, x:%)      == applyQuote(s, [x])
    applyQuote(s, x, y)        == applyQuote(s, [x, y])
    applyQuote(s, x, y, z)     == applyQuote(s, [x, y, z])
    applyQuote(s, x, y, z, t)  == applyQuote(s, [x, y, z, t])
    applyQuote(s:SY, l:List %) == opquote concat(s::%, l)
    belong? op                 == op = opdiff or op = opquote
    subs(fn, k) == kernel(operator k,[fn x for x in argument k]$List(%))

    operator op ==
      is?(op, '%diff) => opdiff
      is?(op, '%quote) => opquote
      error "Unknown operator"

    if R has ConvertibleTo InputForm then
      INP==>InputForm
      import MakeUnaryCompiledFunction(%, %, %)
      indiff: List % -> INP
      pint  : List INP-> INP
      differentiand: List % -> %

      differentiand l    == eval(first l, retract(second l)@K, third l)
      pint l  == convert concat(convert("D"::SY)@INP, l)
      indiff l ==
         r2:= convert([convert("::"::SY)@INP,convert(third l)@INP,convert("Symbol"::SY)@INP]@List INP)@INP
         pint [convert(differentiand l)@INP, r2] 
      eval(f:%, s:SY)            == eval(f, [s])
      eval(f:%, s:OP, g:%, x:SY) == eval(f, [s], [g], x)

      eval(f:%, ls:List OP, lg:List %, x:SY) ==
        eval(f, ls, [compiledFunction(g, x) for g in lg])

      setProperty(opdiff,SPECIALINPUT,indiff@(List % -> InputForm) pretend None)

    variables x ==
      l := empty()$List(SY)
      for k in tower x repeat
        if ((s := symbolIfCan k) case SY) then l := concat(s::SY, l)
      reverse! l

    retractIfCan(x:%):Union(SY, "failed") ==
      (k := retractIfCan(x)@Union(K,"failed")) case "failed" => "failed"
      symbolIfCan(k::K)

    if R has Ring then
      import UserDefinedPartialOrdering(SY)

-- cannot use new()$Symbol because of possible re-instantiation
      gendiff := "%%0"::SY

      characteristic == characteristic$R
      coerce(k:K):%       == k::MP::%
      symsub(sy, i)       == concat(string sy, string i)::SY
      numerator x         == numer(x)::%
      eval(x:%, s:SY, n:N, f:% -> %)     == eval(x,[s],[n],[f first #1])
      eval(x:%, s:SY, n:N, f:List % -> %) == eval(x, [s], [n], [f])
      eval(x:%, l:List SY, f:List(List % -> %)) == eval(x, l, new(#l, 1), f)

      elt(op:OP, args:List %) ==
        unary? op and ((od? := has?(op, ODD)) or has?(op, EVEN)) and
          before?(leadingCoefficient(numer first args),0) =>
            x := op(- first args)
            od? => -x
            x
        elt(op, args)$ExpressionSpace_&(%)

      eval(x:%, s:List SY, n:List N, l:List(% -> %)) ==
        eval(x, s, n, [f first #1 for f in l]$List(List % -> %))

      -- op(arg)**m ==> func(arg)**(m quo n) * op(arg)**(m rem n)
      smprep(lop, lexp, lfunc, p) ==
        (v := mainVariable p) case "failed" => p::%
        k := v::K
        g := (op := operator k)
           (arg := [eval(a,lop,lexp,lfunc) for a in argument k]$List(%))
        q := map(eval(#1::%, lop, lexp, lfunc),
                 univariate(p, k))$SparseUnivariatePolynomialFunctions2(MP, %)
        (n := position(name op, lop)) < minIndex lop => q g
        a:%  := 0
        f    := eval((lfunc.n) arg, lop, lexp, lfunc)
        e    := lexp.n
        while q ~= 0 repeat
          m  := degree q
          qr := divide(m, e)
          t1 := f ** (qr.quotient)::N
          t2 := g ** (qr.remainder)::N
          a  := a + leadingCoefficient(q) * t1 * t2
          q  := reductum q
        a

      dispdiff l ==
        s := second(l)::O
        t := third(l)::O
        a := argument(k := retract(first l)@K)
        is?(k, opdiff) =>
          rec := dispdiff a
          i   := position(s, rec.arg)
          rec.arg.i := t
          [rec.name,
             hconcat(rec.sub, hconcat(","::SY::O, (i+1-minIndex a)::O)),
                        rec.arg, (zero?(rec.level) => 0; rec.level + 1)]
        i   := position(second l, a)
        m   := [x::O for x in a]$List(O)
        m.i := t
        [name(operator k)::O, hconcat(","::SY::O, (i+1-minIndex a)::O),
                                             m, (empty? rest a => 1; 0)]

      ddiff l ==
        rec := dispdiff l
        opname :=
          zero?(rec.level) => sub(rec.name, rec.sub)
          differentiate(rec.name, rec.level)
        prefix(opname, rec.arg)

      substArg(op, l, i, g) ==
        z := copy l
        z.i := g
        kernel(op, z)


      diffdiff(l, x) ==
        f := kernel(opdiff, l)
        diffdiff0(l, x, f, retract(f)@K, empty())

      diffdiff0(l, x, expr, kd, done) ==
        op  := operator(k := retract(first l)@K)
        gg  := second l
        u   := third l
        arg := argument k
        ans:% := 0
        if (not member?(u,done)) and not zero?(ans := differentiate(u,x)) then
          ans := ans * kernel(opdiff,
               [subst(expr, [kd], [kernel(opdiff, [first l, gg, gg])]),
                             gg, u])
        done := concat(gg, done)
        is?(k, opdiff) => ans + diffdiff0(arg, x, expr, k, done)
        for i in minIndex arg .. maxIndex arg for b in arg repeat
          if (not member?(b,done)) and not zero?(bp:=differentiate(b,x)) then
            g   := symsub(gendiff, i)::%
            ans := ans + bp * kernel(opdiff, [subst(expr, [kd],
             [kernel(opdiff, [substArg(op, arg, i, g), gg, u])]), g, b])
        ans

      dfeval(l, g) ==
        eval(differentiate(first l, symbolIfCan(g)::SY), g, third l)

      diffEval l ==
        k:K
        g := retract(second l)@K
        ((u := retractIfCan(first l)@Union(K, "failed")) case "failed")
          or (u case K and symbolIfCan(k := u::K) case SY) => dfeval(l, g)
        op := operator k
        (ud := derivative op) case "failed" => 
             -- possible trouble 
             -- make sure it is a dummy var  
             dumm:%:=symsub(gendiff,1)::%
             ss:=subst(l.1,l.2=dumm)
             -- output(nl::OutputForm)$OutputPackage
             -- output("fixed"::OutputForm)$OutputPackage
             nl:=[ss,dumm,l.3]
             kernel(opdiff, nl)
        (n := position(second l,argument k)) < minIndex l => 
              dfeval(l,g)
        d := ud::List(List % -> %)
        eval((d.n)(argument k), g, third l)

      diffArg(l, op, i) ==
        n := i - 1 + minIndex l
        z := copy l
        z.n := g := symsub(gendiff, n)::%
        [kernel(op, z), g, l.n]

      opderiv(op, n) ==
        one? n =>
          g := symsub(gendiff, n)::%
          [kernel(opdiff,[kernel(op, g), g, first #1])]
        [kernel(opdiff, diffArg(#1, op, i)) for i in 1..n]

      kderiv k ==
        zero?(n := #(args := argument k)) => empty()
        op := operator k
        grad :=
          (u := derivative op) case "failed" => opderiv(op, n)
          u::List(List % -> %)
        if #grad ~= n then grad := opderiv(op, n)
        [g args for g in grad]

    -- SPECIALDIFF contains a map (List %, Symbol) -> %
    -- it is used when the usual chain rule does not apply,
    -- for instance with implicit algebraics.
      kerderiv(k, x) ==
        (v := symbolIfCan(k)) case SY =>
          v::SY = x => 1
          0
        (fn := property(operator k, SPECIALDIFF)) case None =>
           ((fn@None) pretend ((List %, SY) -> %)) (argument k, x)
        +/[g * differentiate(y,x) for g in kderiv k for y in argument k]

      smpderiv(p, x) ==
        map(retract differentiate(#1::PR, x), p)::% +
         +/[differentiate(p,k)::% * kerderiv(k, x) for k in variables p]

      coerce(p:PR):% ==
        map(#1::%, #1::%, p)$PolynomialCategoryLifting(
                                      IndexedExponents SY, SY, R, PR, %)

      worse?(k1, k2) ==
        (u := less?(name operator k1,name operator k2)) case "failed" =>
          k1 < k2
        u::Boolean

      bestKernel l ==
        empty? rest l => first l
        a := bestKernel rest l
        worse?(first l, a) => a
        first l

      smp2O p ==
        (r:=retractIfCan(p)@Union(R,"failed")) case R =>r::R::OutputForm
        a :=
          userOrdered?() => bestKernel variables p
          mainVariable(p)::K
        outputForm(map(#1::%, univariate(p,
         a))$SparseUnivariatePolynomialFunctions2(MP, %), a::OutputForm)

      smpsubst(p, lk, lv) ==
        map(match(lk, lv, #1,
            notfound(subs(subst(#1, lk, lv), #1), lk, #1))$ListToMap(K,%),
             #1::%,p)$PolynomialCategoryLifting(IndexedExponents K,K,R,MP,%)

      smpeval(p, lk, lv) ==
        map(match(lk, lv, #1,
            notfound(map(eval(#1, lk, lv), #1), lk, #1))$ListToMap(K,%),
             #1::%,p)$PolynomialCategoryLifting(IndexedExponents K,K,R,MP,%)

-- this is called on k when k is not a member of lk
      notfound(fn, lk, k) ==
        empty? setIntersection(tower(f := k::%), lk) => f
        fn k

      if R has ConvertibleTo InputForm then
        pushunq(l, arg) ==
           empty? l => [eval a for a in arg]
           [eval(a, l) for a in arg]

        kunq(k, l, givenlist?) ==
          givenlist? and empty? l => k::%
          is?(k, opquote) and
            (member?(s:=retract(first argument k)@SY, l) or empty? l) =>
              interpret(convert(concat(convert(s)@InputForm,
                [convert a for a in pushunq(l, rest argument k)
                   ]@List(InputForm)))@InputForm)$InputFormFunctions1(%)
          (operator k) pushunq(l, argument k)

        smpunq(p, l, givenlist?) ==
          givenlist? and empty? l => p::%
          map(kunq(#1, l, givenlist?), #1::%,
            p)$PolynomialCategoryLifting(IndexedExponents K,K,R,MP,%)

      smpret p ==
        "or"/[symbolIfCan(k) case "failed" for k in variables p] =>
          "failed"
        map(symbolIfCan(#1)::SY::PR, #1::PR,
          p)$PolynomialCategoryLifting(IndexedExponents K, K, R, MP, PR)

      isExpt(x:%, op:OP) ==
        (u := isExpt x) case "failed" => "failed"
        v := (u::Record(var:K, exponent:Z)).var
        is?(v,op) and #argument(v) = 1 => u
        "failed"

      isExpt(x:%, sy:SY) ==
        (u := isExpt x) case "failed" => "failed"
        v := (u::Record(var:K, exponent:Z)).var
        is?(v, sy) and #argument(v) = 1 => u
        "failed"

      if R has RetractableTo Z then
          smpIsMult p ==
            (u := mainVariable p) case K and one? degree(q:=univariate(p,u::K))
              and zero?(leadingCoefficient reductum q)
                and ((r:=retractIfCan(leadingCoefficient q)@Union(R,"failed"))
                   case R)
                     and (n := retractIfCan(r::R)@Union(Z, "failed")) case Z =>
                       [n::Z, u::K]
            "failed"

      evaluate(opdiff, diffEval)

      debugA(a1,a2,t) == 
         -- uncomment for debugging
         -- output(hconcat [a1::OutputForm,a2::OutputForm,t::OutputForm])$OutputPackage
         t

      equaldiff(k1,k2) ==
        a1:=argument k1
        a2:=argument k2
        -- check the operator
        res:=operator k1 = operator k2 
        not res => debugA(a1,a2,res) 
        -- check the evaluation point
        res:= (a1.3 = a2.3)
        not res => debugA(a1,a2,res)
        -- check all the arguments
        res:= (a1.1 = a2.1) and (a1.2 = a2.2)
        res => debugA(a1,a2,res)
        -- check the substituted arguments
        (subst(a1.1,[retract(a1.2)@K],[a2.2]) = a2.1) => debugA(a1,a2,true)
        debugA(a1,a2,false)
      setProperty(opdiff,SPECIALEQUAL,
                          equaldiff@((K,K) -> Boolean) pretend None)
      setProperty(opdiff, SPECIALDIFF,
                          diffdiff@((List %, SY) -> %) pretend None)
      setProperty(opdiff, SPECIALDISP,
                              ddiff@(List % -> OutputForm) pretend None)

      if not(R has IntegralDomain) then
        mainKernel x         == mainVariable numer x
        kernels x            == variables numer x
        retract(x:%):R       == retract numer x
        retract(x:%):PR      == smpret(numer x)::PR
        retractIfCan(x:%):Union(R,  "failed") == retract numer x
        retractIfCan(x:%):Union(PR, "failed") == smpret numer x
        eval(x:%, lk:List K, lv:List %)  == smpeval(numer x, lk, lv)
        subst(x:%, lk:List K, lv:List %) == smpsubst(numer x, lk, lv)
        differentiate(x:%, s:SY)         == smpderiv(numer x, s)
        coerce(x:%):OutputForm           == smp2O numer x

        if R has ConvertibleTo InputForm then
          eval(f:%, l:List SY) == smpunq(numer f, l, true)
          eval f               == smpunq(numer f, empty(), false)

        eval(x:%, s:List SY, n:List N, f:List(List % -> %)) ==
          smprep(s, n, f, numer x)

        isPlus x ==
          (u := isPlus numer x) case "failed" => "failed"
          [p::% for p in u::List(MP)]

        isTimes x ==
          (u := isTimes numer x) case "failed" => "failed"
          [p::% for p in u::List(MP)]

        isExpt x ==
          (u := isExpt numer x) case "failed" => "failed"
          r := u::Record(var:K, exponent:NonNegativeInteger)
          [r.var, r.exponent::Z]

        isPower x ==
          (u := isExpt numer x) case "failed" => "failed"
          r := u::Record(var:K, exponent:NonNegativeInteger)
          [r.var::%, r.exponent::Z]

        if R has ConvertibleTo Pattern Z then
          convert(x:%):Pattern(Z) == convert numer x

        if R has ConvertibleTo Pattern Float then
          convert(x:%):Pattern(Float) == convert numer x

        if R has RetractableTo Z then
          isMult x == smpIsMult numer x

    if R has CommutativeRing then
      r:R * x:% == r::MP::% * x

    if R has IntegralDomain then
      par   : % -> %

      mainKernel x                    == mainVariable(x)$QF
      kernels x                       == variables(x)$QF
      univariate(x:%, k:K)            == univariate(x, k)$QF
      isPlus x                        == isPlus(x)$QF
      isTimes x                       == isTimes(x)$QF
      isExpt x                        == isExpt(x)$QF
      isPower x                       == isPower(x)$QF
      denominator x                   == denom(x)::%
      coerce(q:Q):%                   == (numer q)::MP / (denom q)::MP
      coerce(q:Fraction PR):%         == (numer q)::% / (denom q)::%
      coerce(q:Fraction Polynomial Q) == (numer q)::% / (denom q)::%
      retract(x:%):PR                == retract(retract(x)@Fraction(PR))
      retract(x:%):Fraction(PR) == smpret(numer x)::PR / smpret(denom x)::PR
      retract(x:%):R == (retract(numer x)@R exquo retract(denom x)@R)::R

      coerce(x:%):OutputForm ==
        one?(denom x) => smp2O numer x
        smp2O(numer x) / smp2O(denom x)

      retractIfCan(x:%):Union(R, "failed") ==
        (n := retractIfCan(numer x)@Union(R, "failed")) case "failed" or
          (d := retractIfCan(denom x)@Union(R, "failed")) case "failed"
            or (r := n::R exquo d::R) case "failed" => "failed"
        r::R

      eval(f:%, l:List SY) ==
        smpunq(numer f, l, true) / smpunq(denom f, l, true)

      if R has ConvertibleTo InputForm then
        eval f ==
          smpunq(numer f, empty(), false) / smpunq(denom f, empty(), false)

        eval(x:%, s:List SY, n:List N, f:List(List % -> %)) ==
          smprep(s, n, f, numer x) / smprep(s, n, f, denom x)

      differentiate(f:%, x:SY) ==
        (smpderiv(numer f, x) * denom(f)::% -
          numer(f)::% * smpderiv(denom f, x))
            / (denom(f)::% ** 2)

      eval(x:%, lk:List K, lv:List %) ==
        smpeval(numer x, lk, lv) / smpeval(denom x, lk, lv)

      subst(x:%, lk:List K, lv:List %) ==
        smpsubst(numer x, lk, lv) / smpsubst(denom x, lk, lv)

      par x ==
        (r := retractIfCan(x)@Union(R, "failed")) case R => x
        paren x

      convert(x:Factored %):% ==
        par(unit x) * */[par(f.factor) ** f.exponent for f in factors x]

      retractIfCan(x:%):Union(PR, "failed") ==
        (u := retractIfCan(x)@Union(Fraction PR,"failed")) case "failed"
          => "failed"
        retractIfCan(u::Fraction(PR))

      retractIfCan(x:%):Union(Fraction PR, "failed") ==
        (n := smpret numer x) case "failed" => "failed"
        (d := smpret denom x) case "failed" => "failed"
        n::PR / d::PR

      coerce(p:Polynomial Q):% ==
        map(#1::%, #1::%,
           p)$PolynomialCategoryLifting(IndexedExponents SY, SY,
                                                     Q, Polynomial Q, %)

      if R has RetractableTo Z then
        coerce(x:Fraction Z):% == numer(x)::MP / denom(x)::MP

        isMult x ==
           (u := smpIsMult numer x) case "failed"
              or (v := retractIfCan(denom x)@Union(R, "failed")) case "failed"
                 or (w := retractIfCan(v::R)@Union(Z, "failed")) case "failed"
                     => "failed"
           r := u::Record(coef:Z, var:K)
           (q := r.coef exquo w::Z) case "failed" => "failed"
           [q::Z, r.var]

      if R has ConvertibleTo Pattern Z then
        convert(x:%):Pattern(Z) == convert(numer x) / convert(denom x)

      if R has ConvertibleTo Pattern Float then
        convert(x:%):Pattern(Float) ==
          convert(numer x) / convert(denom x)

)abbrev package FS2 FunctionSpaceFunctions2
++ Lifting of maps to function spaces
++ Author: Manuel Bronstein
++ Date Created: 22 March 1988
++ Date Last Updated: 3 May 1994
++ Description:
++   This package allows a mapping R -> S to be lifted to a mapping
++   from a function space over R to a function space over S;
FunctionSpaceFunctions2(R, A, S, B): Exports == Implementation where
  R, S: Ring
  A   : FunctionSpace R
  B   : FunctionSpace S

  K  ==> Kernel A
  P  ==> SparseMultivariatePolynomial(R, K)

  Exports ==> with
    map: (R -> S, A) -> B
      ++ map(f, a) applies f to all the constants in R appearing in \spad{a}.

  Implementation ==> add
    smpmap: (R -> S, P) -> B

    smpmap(fn, p) ==
      map(map(map(fn, #1), #1)$ExpressionSpaceFunctions2(A,B),fn(#1)::B,
        p)$PolynomialCategoryLifting(IndexedExponents K, K, R, P, B)

    if R has IntegralDomain then
      if S has IntegralDomain then
        map(f, x) == smpmap(f, numer x) / smpmap(f, denom x)
      else
        map(f, x) == smpmap(f, numer x) * (recip(smpmap(f, denom x))::B)
    else
      map(f, x) == smpmap(f, numer x)