NonNegativeChunky.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 Number.NonNegativeChunky
   (T, fromChunks, fromNumber, toNumber, fromChunky98, toChunky98,
    normalize, isNull, isPositive) where

import qualified Numeric.NonNegative.ChunkyPrivate as Chunky98
import qualified Numeric.NonNegative.Class as NonNeg98

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.NonNegative  as NonNeg
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 Control.Monad (liftM, liftM2, )

import Test.QuickCheck (Arbitrary(..))

import NumericPrelude
import Data.Tuple.HT (mapFst, mapPair, )
import PreludeBase
import qualified Prelude     as P98


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

The type is equivalent to 'Numeric.NonNegative.Chunky'.
-}
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)

{- |
Remove zero chunks.
-}
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
  -- null . toChunks . normalize

isPositive :: NonNeg.C a => T a -> Bool
isPositive = not . isNull



{-
normalizeZT :: ZeroTestable.C a => T a -> T a
normalizeZT = fromChunks . filter (not . isZero) . toChunks
-}

isNullListZT :: ZeroTestable.C a => [a] -> Bool
isNullListZT = null . filter (not . isZero)

isNullZT :: ZeroTestable.C a => T a -> Bool
isNullZT = isNullListZT . decons
  -- null . toChunks . normalize
{-
isPositiveZT :: ZeroTestable.C a => T a -> Bool
isPositiveZT = 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
   (-|) =
      lift2 (\x w ->
         let sub _ [] = []
             sub z (y:ys) =
                if z<y then (y-z):ys else sub (z-y) 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  = Cons []
   (+)   = lift2 (++)
   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
{-
   x0 - y0 =
      let d' = lift2 (\x y -> let (_,d,b) = glue x y in  d) x0 y0
      in  check "-" (not b || isNull d') d'
-}

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



{- * legacy instances -}

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 -- for unary minus
   (+)    = 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