module Number.NonNegativeChunky
(T, fromChunks, toChunks, fromNumber, toNumber, fromChunky98, toChunky98,
minMaxDiff, normalize, isNull, isPositive) where
import qualified Numeric.NonNegative.ChunkyPrivate as Chunky98
import qualified Numeric.NonNegative.Class as NonNeg98
import qualified Algebra.NonNegative as NonNeg
import qualified Algebra.Field as Field
import qualified Algebra.Real as Real
import qualified Algebra.Ring as Ring
import qualified Algebra.Additive as Additive
import qualified Algebra.ToInteger as ToInteger
import qualified Algebra.ToRational as ToRational
import qualified Algebra.IntegralDomain as Integral
import qualified Algebra.RealIntegral as RealIntegral
import qualified Algebra.ZeroTestable as ZeroTestable
import Algebra.ZeroTestable (isZero, )
import qualified Algebra.Monoid as Monoid
import qualified Data.Monoid as Mn98
import Control.Monad (liftM, liftM2, )
import Test.QuickCheck (Arbitrary(..))
import NumericPrelude
import Data.Tuple.HT (mapFst, mapPair, )
import PreludeBase
import qualified Prelude as P98
newtype T a = Cons {decons :: [a]}
fromChunks :: NonNeg.C a => [a] -> T a
fromChunks = Cons
toChunks :: NonNeg.C a => T a -> [a]
toChunks = decons
fromChunky98 :: (NonNeg.C a, NonNeg98.C a) => Chunky98.T a -> T a
fromChunky98 = fromChunks . Chunky98.toChunksUnsafe
toChunky98 :: (NonNeg.C a, NonNeg98.C a) => T a -> Chunky98.T a
toChunky98 = Chunky98.fromChunks . toChunks
fromNumber :: NonNeg.C a => a -> T a
fromNumber = fromChunks . (:[])
toNumber :: NonNeg.C a => T a -> a
toNumber = sum . toChunks
lift2 :: NonNeg.C a => ([a] -> [a] -> [a]) -> (T a -> T a -> T a)
lift2 f x y =
fromChunks $ f (toChunks x) (toChunks y)
normalize :: NonNeg.C a => T a -> T a
normalize = fromChunks . filter (>zero) . toChunks
isNullList :: NonNeg.C a => [a] -> Bool
isNullList = null . filter (>zero)
isNull :: NonNeg.C a => T a -> Bool
isNull = isNullList . toChunks
isPositive :: NonNeg.C a => T a -> Bool
isPositive = not . isNull
isNullListZT :: ZeroTestable.C a => [a] -> Bool
isNullListZT = null . filter (not . isZero)
isNullZT :: ZeroTestable.C a => T a -> Bool
isNullZT = isNullListZT . decons
check :: String -> Bool -> a -> a
check funcName b x =
if b
then x
else error ("Numeric.NonNegative.Chunky."++funcName++": negative number")
glue :: (NonNeg.C a) => [a] -> [a] -> ([a], [a], Bool)
glue [] ys = ([], ys, True)
glue xs [] = ([], xs, False)
glue (x:xs) (y:ys) =
let (z,(zs,rs,b)) =
case compare x y of
LT -> (x, glue xs ((yx):ys))
GT -> (y, glue ((xy):xs) ys)
EQ -> (x, glue xs ys)
in (z:zs,rs,b)
minMaxDiff :: (NonNeg.C a) => T a -> T a -> (T a, T a, Bool)
minMaxDiff (Cons xs) (Cons ys) =
let (zs, rs, b) = glue xs ys
in (Cons zs, Cons rs, b)
equalList :: (NonNeg.C a) => [a] -> [a] -> Bool
equalList x y =
let (_,r,_) = glue x y
in isNullList r
compareList :: (NonNeg.C a) => [a] -> [a] -> Ordering
compareList x y =
let (_,r,b) = glue x y
in if isNullList r
then EQ
else if b then LT else GT
minList :: (NonNeg.C a) => [a] -> [a] -> [a]
minList x y =
let (z,_,_) = glue x y in z
maxList :: (NonNeg.C a) => [a] -> [a] -> [a]
maxList x y =
let (z,r,_) = glue x y in z++r
instance (NonNeg.C a) => Eq (T a) where
(Cons x) == (Cons y) = equalList x y
instance (NonNeg.C a) => Ord (T a) where
compare (Cons x) (Cons y) = compareList x y
min = lift2 minList
max = lift2 maxList
instance (NonNeg.C a) => NonNeg.C (T a) where
(-|) =
lift2 (\x w ->
let sub _ [] = []
sub z (y:ys) =
if z<y then (yz):ys else sub (zy) ys
in foldr sub x w)
instance (ZeroTestable.C a) => ZeroTestable.C (T a) where
isZero = isNullZT
instance (NonNeg.C a) => Additive.C (T a) where
zero = Monoid.idt
(+) = (Monoid.<*>)
x y =
let (_,d,b) = glue (toChunks x) (toChunks y)
d' = fromChunks d
in check "-" (not b || isNull d') d'
negate x = check "negate" (isNull x) x
instance (Ring.C a, NonNeg.C a) => Ring.C (T a) where
one = fromNumber one
(*) = lift2 (liftM2 (*))
fromInteger = fromNumber . fromInteger
instance (Ring.C a, ZeroTestable.C a, NonNeg.C a) => Real.C (T a) where
abs = id
signum = fromNumber . (\b -> if b then one else zero) . isPositive
instance (ToInteger.C a, NonNeg.C a) => ToInteger.C (T a) where
toInteger = sum . map toInteger . toChunks
instance (ToRational.C a, NonNeg.C a) => ToRational.C (T a) where
toRational = sum . map toRational . toChunks
instance (RealIntegral.C a, NonNeg.C a) => RealIntegral.C (T a) where
quot = div
rem = mod
quotRem = divMod
instance (Ord a, Integral.C a, NonNeg.C a) => Integral.C (T a) where
divMod x0 y0 =
let y = toChunks y0
recurse x =
let (r,d,b) = glue y x
in if not b
then ([], r)
else mapFst (one:) (recurse d)
in mapPair
(fromChunks, fromChunks)
(recurse (toChunks x0))
instance (Show a) => Show (T a) where
showsPrec p x =
showParen (p>10)
(showString "Chunky.fromChunks " . showsPrec 10 (decons x))
instance (NonNeg.C a, Arbitrary a) => Arbitrary (T a) where
arbitrary = liftM Cons arbitrary
coarbitrary = undefined
legacyInstance :: a
legacyInstance =
error "legacy Ring.C instance for simple input of numeric literals"
instance (Ring.C a, Eq a, Show a, NonNeg.C a) => P98.Num (T a) where
fromInteger = fromNumber . fromInteger
negate = Additive.negate
(+) = legacyInstance
(*) = legacyInstance
abs = legacyInstance
signum = legacyInstance
instance (Field.C a, Eq a, Show a, NonNeg.C a) => P98.Fractional (T a) where
fromRational = fromNumber . fromRational
(/) = legacyInstance
instance (NonNeg.C a) => Mn98.Monoid (T a) where
mempty = Monoid.idt
mappend = (Monoid.<*>)
instance (NonNeg.C a) => Monoid.C (T a) where
idt = Cons []
(<*>) = lift2 (++)