)abbrev category APRODC AbelianProductCategory
++ Author: Waldek Hebisch
++ Description:
++  This category represents products with coordinatewise additive
++  operations.
AbelianProductCategory(A : Type) : Category == with
    if A has AbelianMonoid then AbelianMonoid
    if A has CancellationAbelianMonoid then CancellationAbelianMonoid
    if A has AbelianGroup then AbelianGroup


)abbrev category IDPC IndexedDirectProductCategory
++ Author: James Davenport
++ Basic Functions:
++ Related Constructors:
++ Also See:
++ AMS Classifications:
++ Keywords:
++ References:
++ Description:
++ This category represents the direct product of some set with
++ respect to an ordered indexing set.
++ The ordered set \spad{S} is considered as the ``basis elements'' and
++ the elements from \spad{A} as ``coefficients''.

IndexedDirectProductCategory(A : SetCategory, S : SetCategory
                            ) : Category == Export where
  Term ==> Record(k : S, c : A)

  Export ==  AbelianProductCategory(A) with

      if A has Comparable and S has Comparable then Comparable
      if S has OrderedSet then
          if A has OrderedAbelianMonoid then OrderedAbelianMonoid
          if A has OrderedAbelianMonoidSup then OrderedAbelianMonoidSup

      map :           (A -> A, %) -> %
         ++ map(f, z) returns the new element created by applying the
         ++ function f to each component of the direct product element z.
      monomial :         (A, S) -> %
         ++ monomial(a, s) constructs a direct product element with the s
         ++ component set to \spad{a}
      monomial? : % -> Boolean
         ++ \spad{monomial?(x)} returns true if \spad{x} is a single
         ++ monomial, that is support of \spad{x} consists of a
         ++ single element.
      construct : List Term -> %
         ++ \spad{construct(l)} takes a list of terms and creates
         ++ the object with these components.  First components
         ++ of elements of \spad{l} should be different.
      listOfTerms : % -> List Term
         ++ \spad{listOfTerms(x)} returns a list \spad{lt} of terms with type
         ++ \spad{Record(k: S, c: R)} such that \spad{x} equals
         ++ \spad{construct(lt)}.  If \spad{S has Comparable} than
         ++ \spad{x} equals \spad{constructOrdered(lt)}.
      numberOfMonomials  : % -> NonNegativeInteger
         ++ \spad{numberOfMonomials(x)} returns the number
         ++ of monomials of \spad{x}.
      if S has Comparable then
          leadingMonomial    : % -> %
             ++ \spad{leadingMonomial(x)} returns the monomial supported by
             ++ the first element from \spad{S}.  Error: if x has no support.
          leadingCoefficient :   % -> A
             ++ leadingCoefficient(z) returns the coefficient of the leading
             ++ (with respect to the ordering on the indexing set)
             ++ monomial of z.
             ++ Error: if z has no support.
          leadingSupport :   % -> S
             ++ leadingSupport(z) returns the index of leading (with respect
             ++ to the ordering on the indexing set) monomial of z.
             ++ Error: if z has no support.
          reductum :      % -> %
             ++ \spad{reductum(z)} returns a new element created by removing
             ++ the leading coefficient/support pair from the element z.
             ++ Error: if z has no support.
          constructOrdered : List Term -> %
             ++ \spad{constructOrdered(l)} takes a list of terms and creates
             ++ the object with these components.
             ++ The list is assumed to be sorted (in reverse order) with
             ++ respect to the ordering of S.  If R is a monoid, then the
             ++ list is assumend to contain no zero elements.
             ++ Caution: No checking is performed, so this should only be
             ++ used in cases where those conditions are assured. If in
             ++ doubt use \spad{construct}.
          leadingTerm : % -> Term
             ++ \spad{leadingTerm(x)} returns the leading
             ++ (with respect to the ordering on the indexing set) term of z.
             ++ Error: if z has no support.

)abbrev domain IDPO IndexedDirectProductObject
++ Description:
++ Indexed direct products of objects over a set \spad{A}
++ of generators indexed by an ordered set \spad{S}.  It currently provides
++ the ground for, e.g., \spadtype{FreeModule} which lies at the basis
++ of polynomials of all sorts.
++ All items have finite support.
++ If A is a monoid, then only non-zero terms are stored.
++ If A has additive structure, it is propagated coordinatewise to the
++ product.  Similarly, comparisons are propagated using
++ lexicographic ordering.
-- An item is represented as a list of pairs of type
-- \spadtype{Record(k : S, c : A)} such that each basis element
-- appears at most once.  The list is sorted \emph{in reverse order}
-- according to the ordering of \spad{S}.  The \emph{leading term} of
-- an object is the pair \spad{[s, a]} with \spad{s} maximal and thus
-- the first entry in the list representing the object.
IndexedDirectProductObject(A : SetCategory, S : SetCategory
                          ) : IndexedDirectProductCategory(A, S)
 == add

    --representation
    Term ==>  Record(k : S, c : A)
    Rep :=  List Term

    coerce(x : %) : OutputForm ==
          bracket [rarrow(t.k :: OutputForm, t.c :: OutputForm) for t in x]

    listOfTerms(x : %) == (x::Rep)

    monomial?(x : %) == not(empty?(x)) and empty?(rest(x))

    numberOfMonomials(x : %) == #x

    if A has AbelianMonoid then

        monomial(r, s) == (r = 0 => 0; [[s, r]])
        map(f, x) == [[tm.k, a] for tm in x | not((a := f(tm.c)) = 0$A)]

    else

        monomial(r, s) == [[s, r]]
        map(f, x) == [[tm.k, f(tm.c)] for tm in x]

    if S has Comparable then
    --representations
    --declarations
       x, y : %
       f : A -> A
       s : S
       lx : List Term
    --define
       x = y ==
         while not(empty?(x)) and not(empty?(y)) repeat
           x.first.k ~= y.first.k => return false
           x.first.c ~= y.first.c => return false
           x := x.rest
           y := y.rest
         empty?(x) and empty?(y)

       -- sample(): % == [[sample()$S, sample()$A]$Term]$Rep

       SMALLER_DEF ==>
           smaller?(x : %, y : %) : Boolean ==
               repeat
                   empty?(y) =>
                       empty?(x) => return false
                       return cmp_x_0
                   empty?(x) => return cmp_0_y
                   if x.first.k = y.first.k then
                       if x.first.c = y.first.c then
                           x := rest(x)
                           y := rest(y)
                       else
                           return smaller?(x.first.c, y.first.c)
                   else
                       smaller?(x.first.k, y.first.k) => return cmp_0_y
                       return cmp_x_0

       if A has AbelianMonoid then

           reductum x     == (empty?(x) => 0; rest(x))
           leadingCoefficient x  == (empty?(x) => 0; x.first.c)
           if A has Comparable then
               SMALLER_DEF where
                   cmp_x_0 ==> smaller?(x.first.c, 0$A)
                   cmp_0_y ==> smaller?(0$A, y.first.c)

       else

           reductum x     == rest x
           leadingCoefficient x  ==
               empty?(x) =>
                   error "Can't take leadingCoefficient of empty product element"
               x.first.c
           if A has Comparable then
               SMALLER_DEF where
                   cmp_x_0 ==> false
                   cmp_0_y ==> true

       leadingSupport x  ==
          empty?(x) => error "Can't take leadingCoefficient of empty product element"
          x.first.k

       leadingMonomial x == monomial(first(x).c, first(x).k)

       -- ordering of terms
       compareterm : (Term, Term) -> Boolean

       compareterm(a : Term, b : Term) : Boolean ==
          smaller?(b.k, a.k)

       construct(lx) ==
          sort(compareterm, lx)

       constructOrdered(lx) ==
          lx

       leadingTerm x ==
          empty?(x) => error "Can't take leadingCoefficient of empty product element"
          x.first

       qsetrest! ==> RPLACD$Lisp

       hashUpdate!(s : HashState, x : %) : HashState ==
           xl := x::Rep
           for t in xl repeat
               s := hashUpdate!(s, t.k)$S
               s := hashUpdate!(s, t.c)$A
           s

       TermS ==>  Record(k : SingleInteger, c : A)
       RepS ==> List TermS

       PLUS_BODY ==>
                endcell := empty()
                res := empty()
                while not empty? x and not empty? y repeat
                        newcell := empty()
                        if x.first.k = y.first.k then
                                r := x.first.c + y.first.c
                                if not zero? r then
                                        newcell := cons([x.first.k, r], empty())
                                x := rest x
                                y := rest y
                        else if smaller?(y.first.k, x.first.k) then
                                newcell := cons(x.first, empty())
                                x := rest x
                        else
                                newcell := cons(y.first, empty())
                                y := rest y
                        if not empty? newcell then
                                if not empty? endcell then
                                        qsetrest!(endcell, newcell)
                                        endcell := newcell
                                else
                                        res     := newcell
                                        endcell := res
                if empty? x then end := y
                else end := x
                if empty? res then res := end
                else qsetrest!(endcell, end)
                res

       if A has AbelianMonoid then

           0  == []
           zero? x ==  empty?(x)

           add_gen(x : Rep, y : Rep) : Rep ==
               empty?(x) => y
               empty?(y) => x
               endcell : Rep
               res :  Rep
               newcell : Rep
               PLUS_BODY

           if S is NonNegativeInteger then
               add_si(x : RepS, y : RepS) : RepS ==
                   endcell : RepS
                   res :  RepS
                   newcell : RepS
                   PLUS_BODY

               x + y ==
                   empty?(x) => y
                   empty?(y) => x
                   degx := (x.first.k) pretend Integer
                   degy := (y.first.k) pretend Integer
                   msi := max()$SingleInteger
                   degx < msi and degy < msi =>
                       return add_si(x pretend RepS, y pretend RepS) pretend %
                   add_gen(x, y)

           else
               x + y == add_gen(x, y)

           (n : NonNegativeInteger) * x  ==
               n = 0 => 0
               n = 1 => x
               [[u.k, a] for u in x | (a := n*u.c) ~= 0$A]

       if A has AbelianGroup then
           -x == [[u.k, -u.c] for u in x]
           (n : Integer) * (x : %)  ==
                 n = 0 => 0
                 n = 1 => x
                 [[u.k, a] for u in x | (a := n*u.c) ~= 0$A]


           x - y ==
               empty?(x) => -y
               empty?(y) => x
               endcell : Rep := empty()
               res :  Rep := empty()
               while not empty? x and not empty? y repeat
                   newcell := empty()
                   if x.first.k = y.first.k then
                       r := x.first.c - y.first.c
                       if not zero? r then
                           newcell := cons([x.first.k, r], empty())
                       x := rest x
                       y := rest y
                   else if smaller?(y.first.k, x.first.k) then
                       newcell := cons(x.first, empty())
                       x := rest x
                   else
                       newcell := cons([y.first.k, -y.first.c], empty())
                       y := rest y
                   if not empty? newcell then
                       if not empty? endcell then
                           qsetrest!(endcell, newcell)
                           endcell := newcell
                       else
                           res := newcell
                           endcell := res
               if empty? x then end := - y
               else end := x
               if empty? res then res := end
               else qsetrest!(endcell, end)
               res

       if A has CancellationAbelianMonoid then
           subtractIfCan(x, y) ==
               empty?(y) => x
               endcell : Rep := empty()
               res :  Rep := empty()
               while not empty? x and not empty? y repeat
                   newcell := empty()
                   if x.first.k = y.first.k then
                       ru := subtractIfCan(x.first.c, y.first.c)
                       ru case "failed" => return "failed"
                       r := ru::A
                       if not zero? r then
                           newcell := cons([x.first.k, r], empty())
                       x := rest x
                       y := rest y
                   else if smaller?(y.first.k, x.first.k) then
                       newcell := cons(x.first, empty())
                       x := rest x
                   else
                       ru := subtractIfCan(0$A, y.first.c)
                       ru case "failed" => return "failed"
                       r := ru::A
                       newcell := cons([y.first.k, r], empty())
                       y := rest y
                   if not empty? newcell then
                       if not empty? endcell then
                           qsetrest!(endcell, newcell)
                           endcell := newcell
                       else
                           res := newcell
                           endcell := res
               empty? x =>
                   while not empty? y repeat
                       ru := subtractIfCan(0$A, y.first.c)
                       ru case "failed" => return "failed"
                       r := ru::A
                       newcell := cons([y.first.k, r], empty())
                       y := rest y
                       if not empty? endcell then
                           qsetrest!(endcell, newcell)
                           endcell := newcell
                       else
                           res     := newcell
                           endcell := res
                   res::%
               if empty? res then res := x
               else qsetrest!(endcell, x)
               res::%

       if A has OrderedAbelianMonoid then

           x < y == smaller?(x, y)

       if S has OrderedSet and A has OrderedAbelianMonoidSup then

           sup(x, y) ==
               empty? y => x
               empty? x => y
               x.first.k < y.first.k => cons(y.first, sup(x, y.rest))
               x.first.k > y.first.k => cons(x.first, sup(x.rest, y))
               u := sup(x.first.c, y.first.c)
               cons([x.first.k, u], sup(x.rest, y.rest))

    else

        construct(lx : List Term) == lx

        if A has AbelianMonoid then

            0 == empty()$Rep

            do_copy(xr : Rep) : Rep ==
                res := empty()$Rep
                for t in xr repeat
                    res := cons([t.k, t.c], res)
                reverse!(res)

            x : % + y : % ==
                xxr := x::Rep
                yr := y::Rep
                empty?(xxr) => y
                empty?(yr) => x
                #yr > #xxr => y + x
                xr := do_copy(xxr)::Rep
                for s in yr repeat
                    sk := s.k
                    sc := s.c
                    done : Boolean := false
                    first_time : Boolean := true
                    nxr := xr
                    cxr := xr
                    pxr : Rep
                    while not(empty?(cxr)) and not(done) repeat
                        t := first(cxr)
                        if t.k = sk then
                            tc := t.c + sc
                            if tc = 0 then
                                if first_time then
                                    nxr := rest(cxr)
                                else
                                    qsetrest!(pxr, rest(cxr))
                            else
                                t.c := tc
                            done := true
                        first_time := false
                        pxr := cxr
                        cxr := rest(cxr)
                    xr := nxr
                    if not(done) then
                        xr := cons([sk, sc], xr)
                xr

            (x : % = y : %) : Boolean ==
                xr := x::Rep
                yr := y::Rep
                #xr ~= #yr => false
                for s in yr repeat
                    sk := s.k
                    sc := s.c
                    done : Boolean := false
                    for t in xr while not(done) repeat
                        if t.k = sk then
                            t.c = sc => done := true
                            return false
                    if not(done) then return false
                true

            if A has CancellationAbelianMonoid then

                subtractIfCan(x : %, y : %) ==
                    yr := y ::Rep
                    empty?(yr) => x
                    xr : Rep := do_copy(x::Rep)
                    for s in yr repeat
                        sk := s.k
                        sc := s.c
                        done : Boolean := false
                        first_time : Boolean := true
                        nxr := xr
                        cxr := xr
                        pxr : Rep
                        while not(empty?(cxr)) and not(done) repeat
                            t := first(cxr)
                            if t.k = sk then
                                tcu := subtractIfCan(t.c, sc)
                                tcu case "failed" => return "failed"
                                tc := tcu::A
                                if tc = 0 then
                                    if first_time then
                                        nxr := rest(cxr)
                                    else
                                        qsetrest!(pxr, rest(cxr))
                                else
                                    t.c := tc
                                done := true
                            first_time := false
                            pxr := cxr
                            cxr := rest(cxr)
                        xr := nxr
                        if not(done) then
                            tcu := subtractIfCan(0, sc)
                            tcu case "failed" => return "failed"
                            xr := cons([sk, tcu::A], xr)
                    xr::%

            if A has AbelianGroup then

                - (x : %) == map(_-, x)

--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.
