PartialFraction.hs

{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}
module Test.MathObj.PartialFraction where

import qualified MathObj.PartialFraction      as PartialFraction
import qualified MathObj.Polynomial           as Poly
import qualified Number.Ratio                 as Ratio

import qualified Algebra.PrincipalIdealDomain as PID
import qualified Algebra.Ring                 as Ring
import qualified Algebra.Indexable            as Indexable
import qualified Algebra.Vector               as Vector
-- import Algebra.Vector((*>))

import qualified Algebra.Laws as Laws
import qualified Test.QuickCheck as QC

import NumericPrelude.Monad (untilM)
import Test.NumericPrelude.Utility (testUnit)
import Test.QuickCheck (quickCheck)
import qualified Test.HUnit as HUnit


import PreludeBase as P
import NumericPrelude as NP


{- * Properties for generic types -}

fractionConv :: (PID.C a, Indexable.C a) => [a] -> a -> Bool
fractionConv xs y =
   PartialFraction.toFraction (PartialFraction.fromFactoredFraction xs y) ==
   y % product xs

fractionConvAlt :: (PID.C a, Indexable.C a) => [a] -> a -> Bool
fractionConvAlt xs y =
   PartialFraction.fromFactoredFraction xs y ==
   PartialFraction.fromFactoredFractionAlt xs y

scaleInt :: (PID.C a, Indexable.C a) => a -> PartialFraction.T a -> Bool
scaleInt k a =
   PartialFraction.toFraction (PartialFraction.scaleInt k a) ==
   Ratio.scale k (PartialFraction.toFraction a)

add :: (PID.C a, Indexable.C a) => PartialFraction.T a -> PartialFraction.T a -> Bool
add = Laws.homomorphism PartialFraction.toFraction (+) (+)

sub :: (PID.C a, Indexable.C a) => PartialFraction.T a -> PartialFraction.T a -> Bool
sub = Laws.homomorphism PartialFraction.toFraction (-) (-)

mul :: (PID.C a, Indexable.C a) => PartialFraction.T a -> PartialFraction.T a -> Bool
mul = Laws.homomorphism PartialFraction.toFraction (*) (*)



{- * Properties for Integers -}

{- |
Arbitrary instance of that type generates irreducible elements for tests.
Choosing from a list of examples is a simple yet effective design.
If we would construct irreducible elements by a clever algorithm
we might obtain multiple primes only rarely.
-}
newtype SmallPrime = SmallPrime {intFromSmallPrime :: Integer}

type IntFraction = ([SmallPrime],Integer)

instance QC.Arbitrary SmallPrime where
   arbitrary =
      let primes = [2,3,5,7,11,13]
      in  fmap SmallPrime $ QC.elements (primes ++ map negate primes)
   coarbitrary = undefined

instance Show SmallPrime where
   show = show . intFromSmallPrime


fractionConvInt :: [SmallPrime] -> Integer -> Bool
fractionConvInt =
   fractionConv . map intFromSmallPrime

fractionConvAltInt :: [SmallPrime] -> Integer -> Bool
fractionConvAltInt =
   fractionConvAlt . map intFromSmallPrime

fromSmallPrimes :: IntFraction -> PartialFraction.T Integer
fromSmallPrimes (xs,y) =
   PartialFraction.fromFactoredFraction (map intFromSmallPrime xs) y


scaleIntInt :: Integer -> IntFraction -> Bool
scaleIntInt k a =
   scaleInt k (fromSmallPrimes a)

addInt :: IntFraction -> IntFraction -> Bool
addInt q0 q1 =
   add
      (fromSmallPrimes q0)
      (fromSmallPrimes q1)

subInt :: IntFraction -> IntFraction -> Bool
subInt q0 q1 =
   sub
      (fromSmallPrimes q0)
      (fromSmallPrimes q1)

mulInt :: IntFraction -> IntFraction -> Bool
mulInt q0 q1 =
   mul
      (fromSmallPrimes q0)
      (fromSmallPrimes q1)


intTests :: HUnit.Test
intTests =
   HUnit.TestLabel "integer" $
   HUnit.TestList $
   map testUnit $
      ("conversion between partial and ordinary fraction", quickCheck fractionConvInt) :
      ("two conversion routines from factored fractions", quickCheck fractionConvAltInt) :
      ("integer scaling", quickCheck scaleIntInt) :
      ("addition", quickCheck addInt) :
      ("subtraction", quickCheck subInt) :
      ("multiplication", quickCheck mulInt) :
      []


{- * Properties for Polynomials -}

newtype IrredPoly = IrredPoly {polyFromIrredPoly :: Poly.T Rational}

type RatPolynomial = Poly.T Rational
type PolyFraction = ([IrredPoly],RatPolynomial)

instance QC.Arbitrary IrredPoly where
   arbitrary =
      do poly <- QC.elements (map Poly.fromCoeffs [[2,3],[2,0,1],[3,0,1],[1,-3,0,1]])
         unit <- untilM (not. isZero) QC.arbitrary
         return (IrredPoly (unit Vector.*> poly))
   coarbitrary = undefined

instance Show IrredPoly where
   show = show . polyFromIrredPoly


fractionConvPoly :: [IrredPoly] -> RatPolynomial -> Bool
fractionConvPoly =
   fractionConv . map polyFromIrredPoly

fractionConvAltPoly :: [IrredPoly] -> RatPolynomial -> Bool
fractionConvAltPoly =
   fractionConvAlt . map polyFromIrredPoly

fromIrredPolys :: PolyFraction -> PartialFraction.T RatPolynomial
fromIrredPolys (xs,y) =
   PartialFraction.fromFactoredFraction (map polyFromIrredPoly xs) y


scaleIntPoly :: RatPolynomial -> PolyFraction -> Bool
scaleIntPoly k a =
   scaleInt k (fromIrredPolys a)

addPoly :: PolyFraction -> PolyFraction -> Bool
addPoly q0 q1 =
   add
      (fromIrredPolys q0)
      (fromIrredPolys q1)

subPoly :: PolyFraction -> PolyFraction -> Bool
subPoly q0 q1 =
   sub
      (fromIrredPolys q0)
      (fromIrredPolys q1)

mulPoly :: PolyFraction -> PolyFraction -> Bool
mulPoly q0 q1 =
   mul
      (fromIrredPolys q0)
      (fromIrredPolys q1)



polyTests :: HUnit.Test
polyTests =
   HUnit.TestLabel "polynomial" $
   HUnit.TestList $
   map testUnit $
{- this test fails, because addition may result in leading zero coefficients,
      that is, polynomial addition does not contain a normalization
      if it would contain one, we would exclude computable reals -}
-- wrong     ("conversion between partial and ordinary fraction", quickCheck fractionConvPoly) :
-- wrong     ("two conversion routines from factored fractions", quickCheck fractionConvAltPoly) :
-- too slow      ("integer scaling", quickCheck scaleIntPoly) :
-- too slow      ("addition", quickCheck addPoly) :
-- too slow      ("subtraction", quickCheck subPoly) :
-- too slow      ("multiplication", quickCheck mulPoly) :
      []


tests :: HUnit.Test
tests =
   HUnit.TestLabel "partial fraction" $
   HUnit.TestList $
      intTests :
--      polyTests :
      []