)abbrev package SHP SturmHabichtPackage
++ Author: Lalo Gonzalez-Vega
++ Date Created: 1994?
++ Basic Functions:
++ Related Constructors:
++ Also See:
++ AMS Classifications:
++ Keywords: localization
++ References:
++ Description:
++ This package provides functions for counting real roots of
++ univariate polynomials over an OrderedIntegralDomain.

SturmHabichtPackage(R, UP) : T == C where
  R : OrderedIntegralDomain
  UP : UnivariatePolynomialCategory R

  L ==> List
  INT ==> Integer
  NNI ==> NonNegativeInteger

  T == with
     SturmHabichtSequence : (UP, UP) -> L UP
       ++ SturmHabichtSequence(p1, p2) computes the Sturm-Habicht
       ++ sequence of p1 and p2
     SturmHabichtCoefficients : (UP, UP) -> L R
       ++ SturmHabichtCoefficients(p1, p2) computes the principal
       ++ Sturm-Habicht coefficients of p1 and p2
     SturmHabicht : (UP, UP) -> INT
       ++ SturmHabicht(p1, p2) computes c_{+}-c_{-} where
       ++ c_{+} is the number of real roots of p1 with p2>0 and c_{-}
       ++ is the number of real roots of p1 with p2<0. If p2=1 what
       ++ you get is the number of real roots of p1.
     countRealRoots : UP -> INT
       ++ countRealRoots(p) says how many real roots p has
     if R has GcdDomain then
        SturmHabichtMultiple : (UP, UP) -> INT
          ++ SturmHabichtMultiple(p1, p2) computes c_{+}-c_{-} where
          ++ c_{+} is the number of real roots of p1 with p2>0 and c_{-}
          ++ is the number of real roots of p1 with p2<0. If p2=1 what
          ++ you get is the number of real roots of p1.
        countRealRootsMultiple : UP -> INT
          ++ countRealRootsMultiple(p) says how many real roots p has,
          ++ counted with multiplicity


  C == add
     import from SubResultantPackage(R, UP)

     delta: NNI -> R
     polsth1: (UP, NNI, UP, NNI, R) -> L UP
     polsth2: (UP, NNI, UP, NNI, R) -> L UP
     polsth3: (UP, NNI, UP, NNI, R) -> L UP
     variation: L R -> INT
     permanence: L R -> INT
     qzeros: L R -> L R
     epsil: (NNI, R, R) -> INT
     numbnce: L R -> NNI
     numbce: L R -> NNI
     wfunctaux: L R -> INT
     wfunct: L R -> INT

-- Computation of the delta function:

     delta(int1 : NNI) : R ==
       (-1)^((int1*(int1+1) exquo 2)::NNI)


-- Computation of the Sturm-Habicht sequence of two polynomials P and Q
-- in R[x] where R is an ordered integral domain

     polsth1(p1 : UP, p : NNI, p2 : UP, q : NNI, c1 : R) : L UP ==
         sc1 := (sign(c1))::R
         Pr1 := pseudoRemainder(differentiate(p1)*p2, p1)
         Pr2 := (Pr1 exquo c1^q)::UP
         c2 := leadingCoefficient(Pr2)
         r  := degree(Pr2)
         Pr3 := monomial(sc1^((p-r-1)::NNI), 0)*p1
         Pr4 := monomial(sc1^((p-r-1)::NNI), 0)*Pr2
         Listf : L UP := [Pr3, Pr4]
         if r < p-1 then
             Pr5 := monomial(delta((p-r-1)::NNI)*c2^((p-r-1)::NNI), 0)*Pr2
             Listf := append(Listf, new((p-r-2)::NNI, 0))
             Listf := append(Listf, [Pr5])
         List1 : L UP := if Pr1 = 0 then Listf
                          else parts subresultantVector(p1, Pr2)
         List2 : L UP := []
         for j in 0..(r-1) repeat
             Pr6 := monomial(delta((p-j-1)::NNI), 0)*List1.(j+1)
             List2 := append([Pr6], List2)
         append(Listf, List2)

     polsth2(p1 : UP, p : NNI, p2 : UP, q : NNI, c1 : R) : L UP ==
         sc1 := (sign(c1))::R
         Pr1 := monomial(sc1, 0)*p1
         Pr2 := differentiate(p1)*p2
         Pr3 := monomial(sc1, 0)*Pr2
         Listf : L UP := [Pr1, Pr3]
         sres := subresultantVector(p1, Pr2)
         List2 : L UP := []
         for j in 0..(p-2) repeat
             Pr4 := monomial(delta((p-j-1)::NNI), 0)*sres.j
             Pr5 := (Pr4 exquo c1)::UP
             List2 := append([Pr5], List2)
         append(Listf, List2)

     polsth3(p1 : UP, p : NNI, p2 : UP, q : NNI, c1 : R) : L UP ==
         sc1 := (sign(c1))::R
         q1  := (q-1)::NNI
         v := p+q1
         Pr1 := monomial(delta(q1)*sc1^(q+1), 0)*p1
         Listf : L UP := [Pr1]
         sres := subresultantVector(differentiate(p1)*p2, p1)
         List2 : L UP := []
         for j in 0..((p-1)::NNI) repeat
             Pr2 := monomial(delta((v-j)::NNI), 0)*sres.j
             Pr3 := (Pr2 exquo c1)::UP
             List2 := append([Pr3], List2)
         append(Listf, List2)

     SturmHabichtSequence(p1, p2) : L UP ==
       p : NNI := degree(p1)
       q : NNI := degree(p2)
       c1 : R := leadingCoefficient(p1)
       c1 = 1 or q = 1 => polsth1(p1, p, p2, q, c1)
       q = 0 => polsth2(p1, p, p2, q, c1)
       polsth3(p1, p, p2, q, c1)


-- Computation of the Sturm-Habicht principal coefficients of two
-- polynomials P and Q in R[x] where R is an ordered integral domain

     SturmHabichtCoefficients(p1, p2) : L R ==
         List1 := SturmHabichtSequence(p1, p2)
         qp := #List1
         [coefficient(p, (qp-j)::NNI) for p in List1 for j in 1..qp]


-- Computation of the number of sign variations of a list of non zero
-- elements in an ordered integral domain

     variation(Lsig : L R) : INT ==
       size?(Lsig, 1) => 0
       elt1 : R := first Lsig
       elt2 : R := Lsig.2
       sig1 : R := (sign(elt1*elt2))::R
       List1 : L R := rest Lsig
       sig1 = 1 => variation List1
       1+variation List1


-- Computation of the number of sign permanences of a list of non zero
-- elements in an ordered integral domain

     permanence(Lsig : L R) : INT ==
       size?(Lsig, 1) => 0
       elt1 : R := first Lsig
       elt2 : R := Lsig.2
       sig1 : R := (sign(elt1*elt2))::R
       List1 : L R := rest Lsig
       sig1 = -1 => permanence List1
       1+permanence List1


-- Computation of the functional W which works over a list of elements
-- in an ordered integral domain, with non zero first element

     qzeros(Lsig : L R) : L R ==
         Lsig := reverse Lsig
         while first Lsig = 0 repeat
             Lsig := rest Lsig
         reverse! Lsig

     epsil(int1 : NNI, elt1 : R, elt2 : R) : INT ==
       int1 = 0 => 0
       odd? int1 => 0
       ct1 : INT := if elt1 > 0 then 1 else -1
       ct2 : INT := if elt2 > 0 then 1 else -1
       ct3 := (int1 exquo 2)::NNI
       ct4 := ct1*ct2
       ((-1)^ct3)*ct4

     numbnce(Lsig : L R) : NNI ==
         empty?(Lsig) => 0
         first Lsig = 0 => 0
         1 + numbnce(rest Lsig)

     numbce(Lsig : L R) : NNI ==
         empty?(Lsig) => 0
         first Lsig ~= 0 => 0
         1 + numbce rest Lsig

     wfunctaux(Lsig : L R) : INT ==
         empty?(Lsig) => 0
         List2 : L R := []
         List1 : L R := Lsig
         cont1 : NNI := numbnce(List1)
         for j in 1..cont1 repeat
             List2 := append(List2, [first List1])
             List1 := rest List1
         ind2 : INT := 0
         cont2 : NNI := numbce(List1)
         for j in 1..cont2 repeat
             List1 := rest List1
         if cont2 > 0 then
             ind2 := epsil(cont2, last List2, first List1)
         ind3 : INT := permanence(List2) - variation(List2)
         ind4 : INT := ind2+ind3
         ind4 + wfunctaux(List1)

     wfunct(Lsig : L R) : INT ==
         List1 : L R := qzeros(Lsig)
         wfunctaux(List1)


-- Computation of the integer number:
--    #[{a in Rc(R)/P(a)=0 Q(a)>0}] - #[{a in Rc(R)/P(a)=0 Q(a)<0}]
-- where:
--    - R is an ordered integral domain,
--    - Rc(R) is the real clousure of R,
--    - P and Q are polynomials in R[x],
--    - by #[A] we note the cardinal of the set A

-- In particular:
--      - SturmHabicht(P,1) is the number of "real" roots of P,
--      - SturmHabicht(P,Q^2) is the number of "real" roots of P making Q neq 0

     SturmHabicht(p1 : UP, p2 : UP) : INT ==
         p2 = 0 => 0
         degree(p1) = 0 => 0
         List1 : L UP := SturmHabichtSequence(p1, p2)
         wfunct [leadingCoefficient p for p in List1]

     countRealRoots(p1) : INT == SturmHabicht(p1, 1)

     if R has GcdDomain then
        SturmHabichtMultiple(p1, p2) : INT ==
          p2 = 0 => 0
          degree(p1) = 0 => 0
          SH : L UP := SturmHabichtSequence(p1, p2)
          qp : NNI := #SH
          ans := wfunct [coefficient(p, (qp-j)::NNI) for p in SH for j in 1..qp]
          SH := reverse SH
          while first SH = 0 repeat SH := rest SH
          degree first SH = 0 => ans
          -- OK: it probably wasn't square free, so this item is probably the
          -- gcd of p1 and p1'
          -- unless p1 and p2 have a factor in common (naughty!)
          differentiate(p1) exquo first SH case UP =>
             -- it was the gcd of p1 and p1'
             ans+SturmHabichtMultiple(first SH, p2)
          sqfr := factorList squareFree p1
          #sqfr = 1 and sqfr.first.exponent = 1 => ans
          reduce("+", [f.exponent*SturmHabicht(f.factor, p2) for f in sqfr])

        countRealRootsMultiple(p1) : INT == SturmHabichtMultiple(p1, 1)

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