Chunky.hs

{- |
Copyright   :  (c) Henning Thielemann 2007

Maintainer  :  haskell@henning-thielemann.de
Stability   :  stable
Portability :  Haskell 98

A lazy number type, which is a generalization of lazy Peano numbers.
Comparisons can be made lazy and
thus computations are possible which are impossible with strict number types,
e.g. you can compute @let y = min (1+y) 2 in y@.
You can even work with infinite values.
However, depending on the granularity,
the memory consumption is higher than that for strict number types.
This number type is of interest for the merge operation of event lists,
which allows for co-recursive merges.
-}
module Numeric.NonNegative.Chunky
   (T, fromChunks, fromNumber, toNumber, normalize, isNull, isPositive) 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