{- |
Copyright   :  (c) Henning Thielemann 2008-2010

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, toChunks, toNumber,
    zero, normalize, isNull, isPositive,
    divModStrict,
    fromChunksUnsafe, toChunksUnsafe, ) where

import qualified Numeric.NonNegative.Class as NonNeg
import Control.Monad (liftM, liftM2)
import Data.Monoid (Monoid(mempty, mappend), )
import Data.Semigroup (Semigroup((<>)), )
import Data.Tuple.HT (mapSnd, )

import Test.QuickCheck (Arbitrary(arbitrary, shrink))

{- |
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 {forall a. T a -> [a]
decons :: [a]}


fromChunks :: NonNeg.C a => [a] -> T a
fromChunks :: forall a. C a => [a] -> T a
fromChunks = [a] -> T a
forall a. [a] -> T a
Cons

fromNumber :: NonNeg.C a => a -> T a
fromNumber :: forall a. C a => a -> T a
fromNumber = [a] -> T a
forall a. C a => [a] -> T a
fromChunks ([a] -> T a) -> (a -> [a]) -> a -> T a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[])


{- |
This routine exposes the inner structure of the lazy number.
-}
toChunks :: T a -> [a]
toChunks :: forall a. T a -> [a]
toChunks = T a -> [a]
forall a. T a -> [a]
decons

toNumber :: NonNeg.C a => T a -> a
toNumber :: forall a. C a => T a -> a
toNumber =  [a] -> a
forall a. C a => [a] -> a
NonNeg.sum ([a] -> a) -> (T a -> [a]) -> T a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T a -> [a]
forall a. T a -> [a]
decons


instance (Show a) => Show (T a) where
   showsPrec :: Int -> T a -> ShowS
showsPrec Int
p T a
x =
      Bool -> ShowS -> ShowS
showParen (Int
pInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
10)
         (String -> ShowS
showString String
"Chunky.fromChunks " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
10 (T a -> [a]
forall a. T a -> [a]
decons T a
x))


lift2 :: ([a] -> [a] -> [a]) -> (T a -> T a -> T a)
lift2 :: forall a. ([a] -> [a] -> [a]) -> T a -> T a -> T a
lift2 [a] -> [a] -> [a]
f (Cons [a]
x) (Cons [a]
y) = [a] -> T a
forall a. [a] -> T a
Cons ([a] -> T a) -> [a] -> T a
forall a b. (a -> b) -> a -> b
$ [a] -> [a] -> [a]
f [a]
x [a]
y

zero :: T a
zero :: forall a. T a
zero = [a] -> T a
forall a. [a] -> T a
Cons []

{- |
Remove zero chunks.
-}
normalize :: NonNeg.C a => T a -> T a
normalize :: forall a. C a => T a -> T a
normalize = [a] -> T a
forall a. [a] -> T a
Cons ([a] -> T a) -> (T a -> [a]) -> T a -> T a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
forall a. C a => a
NonNeg.zero) ([a] -> [a]) -> (T a -> [a]) -> T a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T a -> [a]
forall a. T a -> [a]
decons

isNullList :: NonNeg.C a => [a] -> Bool
isNullList :: forall a. C a => [a] -> Bool
isNullList = [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a] -> Bool) -> ([a] -> [a]) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
forall a. C a => a
NonNeg.zero)

isNull :: NonNeg.C a => T a -> Bool
isNull :: forall a. C a => T a -> Bool
isNull = [a] -> Bool
forall a. C a => [a] -> Bool
isNullList ([a] -> Bool) -> (T a -> [a]) -> T a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T a -> [a]
forall a. T a -> [a]
decons
  -- null . decons . normalize

isPositive :: NonNeg.C a => T a -> Bool
isPositive :: forall a. C a => T a -> Bool
isPositive = Bool -> Bool
not (Bool -> Bool) -> (T a -> Bool) -> T a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T a -> Bool
forall a. C a => T a -> Bool
isNull

check :: String -> Bool -> a -> a
check :: forall a. String -> Bool -> a -> a
check String
funcName Bool
b a
x =
   if Bool
b
     then a
x
     else String -> a
forall a. HasCallStack => String -> a
error (String
"Numeric.NonNegative.Chunky."String -> ShowS
forall a. [a] -> [a] -> [a]
++String
funcNameString -> ShowS
forall a. [a] -> [a] -> [a]
++String
": negative number")


glue :: (NonNeg.C a) => [a] -> [a] -> ([a], (Bool, [a]))
glue :: forall a. C a => [a] -> [a] -> ([a], (Bool, [a]))
glue [] [a]
ys = ([], (Bool
True,  [a]
ys))
glue [a]
xs [] = ([], (Bool
False, [a]
xs))
glue (a
x:[a]
xs) (a
y:[a]
ys) =
   let (a
z,~([a]
zs,(Bool, [a])
brs)) =
          (((Bool, a) -> ([a], (Bool, [a])))
 -> (a, (Bool, a)) -> (a, ([a], (Bool, [a]))))
-> (a, (Bool, a))
-> ((Bool, a) -> ([a], (Bool, [a])))
-> (a, ([a], (Bool, [a])))
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Bool, a) -> ([a], (Bool, [a])))
-> (a, (Bool, a)) -> (a, ([a], (Bool, [a])))
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd (a -> a -> (a, (Bool, a))
forall a. C a => a -> a -> (a, (Bool, a))
NonNeg.split a
x a
y) (((Bool, a) -> ([a], (Bool, [a]))) -> (a, ([a], (Bool, [a]))))
-> ((Bool, a) -> ([a], (Bool, [a]))) -> (a, ([a], (Bool, [a])))
forall a b. (a -> b) -> a -> b
$
          \(Bool
b,a
d) ->
             if Bool
b
               then [a] -> [a] -> ([a], (Bool, [a]))
forall a. C a => [a] -> [a] -> ([a], (Bool, [a]))
glue [a]
xs ([a] -> ([a], (Bool, [a]))) -> [a] -> ([a], (Bool, [a]))
forall a b. (a -> b) -> a -> b
$
                    if a
forall a. C a => a
NonNeg.zero a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
d
                      then [a]
ys else a
da -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys
               else [a] -> [a] -> ([a], (Bool, [a]))
forall a. C a => [a] -> [a] -> ([a], (Bool, [a]))
glue (a
da -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs) [a]
ys
   in  (a
za -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
zs,(Bool, [a])
brs)

equalList :: (NonNeg.C a) => [a] -> [a] -> Bool
equalList :: forall a. C a => [a] -> [a] -> Bool
equalList [a]
x [a]
y =
   [a] -> Bool
forall a. C a => [a] -> Bool
isNullList ([a] -> Bool) -> [a] -> Bool
forall a b. (a -> b) -> a -> b
$ (Bool, [a]) -> [a]
forall a b. (a, b) -> b
snd ((Bool, [a]) -> [a]) -> (Bool, [a]) -> [a]
forall a b. (a -> b) -> a -> b
$ ([a], (Bool, [a])) -> (Bool, [a])
forall a b. (a, b) -> b
snd (([a], (Bool, [a])) -> (Bool, [a]))
-> ([a], (Bool, [a])) -> (Bool, [a])
forall a b. (a -> b) -> a -> b
$ [a] -> [a] -> ([a], (Bool, [a]))
forall a. C a => [a] -> [a] -> ([a], (Bool, [a]))
glue [a]
x [a]
y

compareList :: (NonNeg.C a) => [a] -> [a] -> Ordering
compareList :: forall a. C a => [a] -> [a] -> Ordering
compareList [a]
x [a]
y =
   let (Bool
b,[a]
r) = ([a], (Bool, [a])) -> (Bool, [a])
forall a b. (a, b) -> b
snd (([a], (Bool, [a])) -> (Bool, [a]))
-> ([a], (Bool, [a])) -> (Bool, [a])
forall a b. (a -> b) -> a -> b
$ [a] -> [a] -> ([a], (Bool, [a]))
forall a. C a => [a] -> [a] -> ([a], (Bool, [a]))
glue [a]
x [a]
y
   in  if [a] -> Bool
forall a. C a => [a] -> Bool
isNullList [a]
r
         then Ordering
EQ
         else if Bool
b then Ordering
LT else Ordering
GT

minList :: (NonNeg.C a) => [a] -> [a] -> [a]
minList :: forall a. C a => [a] -> [a] -> [a]
minList [a]
x [a]
y =
   ([a], (Bool, [a])) -> [a]
forall a b. (a, b) -> a
fst (([a], (Bool, [a])) -> [a]) -> ([a], (Bool, [a])) -> [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a] -> ([a], (Bool, [a]))
forall a. C a => [a] -> [a] -> ([a], (Bool, [a]))
glue [a]
x [a]
y

maxList :: (NonNeg.C a) => [a] -> [a] -> [a]
maxList :: forall a. C a => [a] -> [a] -> [a]
maxList [a]
x [a]
y =
   -- matching the inner pair lazily is important
   let ([a]
z,~(Bool
_,[a]
r)) = [a] -> [a] -> ([a], (Bool, [a]))
forall a. C a => [a] -> [a] -> ([a], (Bool, [a]))
glue [a]
x [a]
y in [a]
z[a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++[a]
r


instance (NonNeg.C a) => Eq (T a) where
   (Cons [a]
x) == :: T a -> T a -> Bool
== (Cons [a]
y) = [a] -> [a] -> Bool
forall a. C a => [a] -> [a] -> Bool
equalList [a]
x [a]
y

instance (NonNeg.C a) => Ord (T a) where
   compare :: T a -> T a -> Ordering
compare (Cons [a]
x) (Cons [a]
y) = [a] -> [a] -> Ordering
forall a. C a => [a] -> [a] -> Ordering
compareList [a]
x [a]
y
   min :: T a -> T a -> T a
min = ([a] -> [a] -> [a]) -> T a -> T a -> T a
forall a. ([a] -> [a] -> [a]) -> T a -> T a -> T a
lift2 [a] -> [a] -> [a]
forall a. C a => [a] -> [a] -> [a]
minList
   max :: T a -> T a -> T a
max = ([a] -> [a] -> [a]) -> T a -> T a -> T a
forall a. ([a] -> [a] -> [a]) -> T a -> T a -> T a
lift2 [a] -> [a] -> [a]
forall a. C a => [a] -> [a] -> [a]
maxList


{- |
This instance is not correct with respect to the equality check
if the involved numbers contain zero chunks.
-}
instance (NonNeg.C a) => NonNeg.C (T a) where
   split :: T a -> T a -> (T a, (Bool, T a))
split (Cons [a]
xs) (Cons [a]
ys) =
      let ([a]
zs, ~(Bool
b, [a]
rs)) = [a] -> [a] -> ([a], (Bool, [a]))
forall a. C a => [a] -> [a] -> ([a], (Bool, [a]))
glue [a]
xs [a]
ys
      in  ([a] -> T a
forall a. [a] -> T a
Cons [a]
zs, (Bool
b, [a] -> T a
forall a. [a] -> T a
Cons [a]
rs))
{-
   (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 a) => Num (T a) where
   + :: T a -> T a -> T a
(+) = T a -> T a -> T a
forall a. Monoid a => a -> a -> a
mappend
   (Cons [a]
x) - :: T a -> T a -> T a
- (Cons [a]
y) =
      let (Bool
b,[a]
d) = ([a], (Bool, [a])) -> (Bool, [a])
forall a b. (a, b) -> b
snd (([a], (Bool, [a])) -> (Bool, [a]))
-> ([a], (Bool, [a])) -> (Bool, [a])
forall a b. (a -> b) -> a -> b
$ [a] -> [a] -> ([a], (Bool, [a]))
forall a. C a => [a] -> [a] -> ([a], (Bool, [a]))
glue [a]
x [a]
y
          d' :: T a
d' = [a] -> T a
forall a. [a] -> T a
Cons [a]
d
      in String -> Bool -> T a -> T a
forall a. String -> Bool -> a -> a
check String
"-" (Bool -> Bool
not Bool
b Bool -> Bool -> Bool
|| T a -> Bool
forall a. C a => T a -> Bool
isNull T a
d') T a
d'
   negate :: T a -> T a
negate T a
x = String -> Bool -> T a -> T a
forall a. String -> Bool -> a -> a
check String
"negate" (T a -> Bool
forall a. C a => T a -> Bool
isNull T a
x) T a
x
   fromInteger :: Integer -> T a
fromInteger = a -> T a
forall a. C a => a -> T a
fromNumber (a -> T a) -> (Integer -> a) -> Integer -> T a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> a
forall a. Num a => Integer -> a
fromInteger
   * :: T a -> T a -> T a
(*)    = ([a] -> [a] -> [a]) -> T a -> T a -> T a
forall a. ([a] -> [a] -> [a]) -> T a -> T a -> T a
lift2 ((a -> a -> a) -> [a] -> [a] -> [a]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 a -> a -> a
forall a. Num a => a -> a -> a
(*))
   abs :: T a -> T a
abs    = T a -> T a
forall a. a -> a
id
   signum :: T a -> T a
signum = a -> T a
forall a. C a => a -> T a
fromNumber (a -> T a) -> (T a -> a) -> T a -> T a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\Bool
b -> if Bool
b then a
1 else a
0) (Bool -> a) -> (T a -> Bool) -> T a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T a -> Bool
forall a. C a => T a -> Bool
isPositive


instance (Real a, NonNeg.C a) => Real (T a) where
   toRational :: T a -> Rational
toRational = a -> Rational
forall a. Real a => a -> Rational
toRational (a -> Rational) -> (T a -> a) -> T a -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T a -> a
forall a. C a => T a -> a
toNumber

{- required for Integral instance -}
instance (Enum a, NonNeg.C a) => Enum (T a) where
   toEnum :: Int -> T a
toEnum   = a -> T a
forall a. C a => a -> T a
fromNumber (a -> T a) -> (Int -> a) -> Int -> T a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a
forall a. Enum a => Int -> a
toEnum
   fromEnum :: T a -> Int
fromEnum = a -> Int
forall a. Enum a => a -> Int
fromEnum (a -> Int) -> (T a -> a) -> T a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T a -> a
forall a. C a => T a -> a
toNumber

instance (Integral a, NonNeg.C a) => Integral (T a) where
   toInteger :: T a -> Integer
toInteger = a -> Integer
forall a. Integral a => a -> Integer
toInteger (a -> Integer) -> (T a -> a) -> T a -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T a -> a
forall a. C a => T a -> a
toNumber
   quot :: T a -> T a -> T a
quot = T a -> T a -> T a
forall a. Integral a => a -> a -> a
div
   rem :: T a -> T a -> T a
rem  = T a -> T a -> T a
forall a. Integral a => a -> a -> a
mod
   quotRem :: T a -> T a -> (T a, T a)
quotRem = T a -> T a -> (T a, T a)
forall a. Integral a => a -> a -> (a, a)
divMod
   divMod :: T a -> T a -> (T a, T a)
divMod T a
x T a
y =
      (a -> T a) -> (T a, a) -> (T a, T a)
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd a -> T a
forall a. C a => a -> T a
fromNumber ((T a, a) -> (T a, T a)) -> (T a, a) -> (T a, T a)
forall a b. (a -> b) -> a -> b
$
      T a -> a -> (T a, a)
forall a. (Integral a, C a) => T a -> a -> (T a, a)
divModStrict T a
x (T a -> a
forall a. C a => T a -> a
toNumber T a
y)

divModStrict ::
   (Integral a, NonNeg.C a) =>
   T a -> a -> (T a, a)
divModStrict :: forall a. (Integral a, C a) => T a -> a -> (T a, a)
divModStrict T a
x0 a
y =
   let recourse :: [a] -> a -> ([a], a)
recourse [] a
r = ([], a
r)
       recourse (a
x:[a]
xs) a
r0 =
          let (a
q1,a
r1) = a -> a -> (a, a)
forall a. Integral a => a -> a -> (a, a)
divMod (a
xa -> a -> a
forall a. Num a => a -> a -> a
+a
r0) a
y
              ([a]
q2,a
r2) = [a] -> a -> ([a], a)
recourse [a]
xs a
r1
          in  (a
q1a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
q2,a
r2)
       ([a]
cs,a
rm) = [a] -> a -> ([a], a)
recourse (T a -> [a]
forall a. T a -> [a]
toChunks T a
x0) a
0
   in  ([a] -> T a
forall a. C a => [a] -> T a
fromChunks [a]
cs, a
rm)


instance Semigroup (T a) where
   <> :: T a -> T a -> T a
(<>) = ([a] -> [a] -> [a]) -> T a -> T a -> T a
forall a. ([a] -> [a] -> [a]) -> T a -> T a -> T a
lift2 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++)

instance Monoid (T a) where
   mempty :: T a
mempty = T a
forall a. T a
zero
   mappend :: T a -> T a -> T a
mappend = ([a] -> [a] -> [a]) -> T a -> T a -> T a
forall a. ([a] -> [a] -> [a]) -> T a -> T a -> T a
lift2 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++)

instance (NonNeg.C a, Arbitrary a) => Arbitrary (T a) where
   arbitrary :: Gen (T a)
arbitrary = ([a] -> T a) -> Gen [a] -> Gen (T a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [a] -> T a
forall a. [a] -> T a
Cons Gen [a]
forall a. Arbitrary a => Gen a
arbitrary
   shrink :: T a -> [T a]
shrink (Cons [a]
xs) = ([a] -> T a) -> [[a]] -> [T a]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> T a
forall a. [a] -> T a
Cons ([[a]] -> [T a]) -> [[a]] -> [T a]
forall a b. (a -> b) -> a -> b
$ [a] -> [[a]]
forall a. Arbitrary a => a -> [a]
shrink [a]
xs


{- * Functions that may break invariants -}

fromChunksUnsafe :: [a] -> T a
fromChunksUnsafe :: forall a. [a] -> T a
fromChunksUnsafe = [a] -> T a
forall a. [a] -> T a
Cons

{- |
This routine exposes the inner structure of the lazy number
and is actually the same as 'toChunks'.
It was considered dangerous,
but you can observe the lazy structure
in tying-the-knot applications anyway.
So the explicit revelation of the chunks seems not to be worse.
-}
toChunksUnsafe :: T a -> [a]
toChunksUnsafe :: forall a. T a -> [a]
toChunksUnsafe = T a -> [a]
forall a. T a -> [a]
decons