{- | Copyright : (c) Henning Thielemann 2008 Maintainer : haskell@henning-thielemann.de Stability : stable Portability : Haskell 98 This module contains internal functions (*Unsafe) that I had liked to re-use in the NumericPrelude type hierarchy. However since the Eq and Ord instance already require the Num class, we cannot use that in the NumericPrelude. -} module Numeric.NonNegative.ChunkyPrivate (T, fromChunks, fromNumber, toNumber, normalize, isNull, isPositive, fromChunksUnsafe, toChunksUnsafe, ) where import qualified Numeric.NonNegative.Class as NonNeg import Control.Monad (liftM, liftM2) import Test.QuickCheck (Arbitrary(..)) {- | A chunky non-negative number is a list of non-negative numbers. It represents the sum of the list elements. It is possible to represent a finite number with infinitely many chunks by using an infinite number of zeros. Note the following problems: Addition is commutative only for finite representations. E.g. @let y = min (1+y) 2 in y@ is defined, @let y = min (y+1) 2 in y@ is not. -} newtype T a = Cons {decons :: [a]} fromChunks :: NonNeg.C a => [a] -> T a fromChunks = Cons fromNumber :: NonNeg.C a => a -> T a fromNumber = fromChunks . (:[]) toNumber :: NonNeg.C a => T a -> a toNumber = sum . decons instance (Show a) => Show (T a) where showsPrec p x = showParen (p>10) (showString "Chunky.fromChunks " . showsPrec 10 (decons x)) lift2 :: ([a] -> [a] -> [a]) -> (T a -> T a -> T a) lift2 f (Cons x) (Cons y) = Cons $ f x y {- | Remove zero chunks. -} normalize :: NonNeg.C a => T a -> T a normalize = Cons . filter (>0) . decons isNullList :: NonNeg.C a => [a] -> Bool isNullList = null . filter (>0) isNull :: NonNeg.C a => T a -> Bool isNull = isNullList . decons -- null . decons . normalize isPositive :: NonNeg.C a => T a -> Bool isPositive = not . isNull check :: String -> Bool -> a -> a check funcName b x = if b then x else error ("Numeric.NonNegative.Chunky."++funcName++": negative number") {- | In @glue x y == (z,r,b)@ @z@ represents @min x y@, @r@ represents @max x y - min x y@, and @x<y ==> b@ or @x>y ==> not b@, for @x==y@ the value of b is arbitrary. -} 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 ((y-x):ys)) GT -> (y, glue ((x-y):xs) ys) EQ -> (x, glue xs ys) in (z:zs,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 (Cons x) -| (Cons w) = let sub _ [] = [] sub z (y:ys) = if z<y then (y-z):ys else sub (z-y) ys in Cons (foldr sub x w) instance (NonNeg.C a) => Num (T a) where (+) = lift2 (++) (Cons x) - (Cons y) = let (_,d,b) = glue x y d' = Cons d in check "-" (not b || isNull d') d' negate x = check "negate" (isNull x) x fromInteger = fromNumber . fromInteger (*) = lift2 (liftM2 (*)) abs = id signum = fromNumber . (\b -> if b then 1 else 0) . isPositive instance (NonNeg.C a, Arbitrary a) => Arbitrary (T a) where arbitrary = liftM Cons arbitrary coarbitrary = undefined {- * Functions that may break invariants -} fromChunksUnsafe :: [a] -> T a fromChunksUnsafe = Cons {- | This routine exposes the inner structure of the lazy number, and I think it should be used with care. -} toChunksUnsafe :: T a -> [a] toChunksUnsafe = decons