module PreludeNatural(Integer(..),Natural,doubleFromNatural,readDigits,six,showNat,baseDigits,
isZeroN,zeroN,oneN,zero,natFromInt,intFromNatural) where
import Char(isDigit,ord,digitToInt)
import Ratio((%))
import Numeric(showInt)
import PreludeBuiltin(primDoubleZero,primDoubleFromInt)
import qualified Builtin as B
--import Debug.Trace
data Integer = Pos Natural | Neg Natural --deriving Show
newtype Natural = N {digits::Digits} --deriving Show
type Digits = [Int] -- sequence of unsigned "digits", least significant first
unN (N n) = n
zeroN = N []
oneN = N [one]
-- Avoid using overloaded numeric literals (i.e. fromInteger)
digit c = B.ord c B.- B.ord '0'
zero = digit '0'
one = digit '1'
two = digit '2'
six = digit '6'
nine = digit '9'
ten = digit ':'
instance Show Natural where show = showNat
showNat (N ds) =
case dropWhile (=='0') $ concatMap (pad . show) $ reverse ds of
[] -> "0"
s -> s
pad s = replicate (baseDigits-length s) '0'++s
instance Read Natural where
readsPrec _ = readParen False readsNatural
readsNatural s =
case lex s of
(ds,r):_ | all isDigit ds -> [(readDigits ds,r)]
_ -> []
readDigits [d] = N [digit d]
readDigits "10" = N [ten]
readDigits s= N . map rd . chunksOf baseDigits . reverse . dropWhile (=='0') $ s
where
rd [] = zero
rd (d:ds) = digit d+ten*rd ds
chunksOf n [] = []
chunksOf n s = take n s:chunksOf n (drop n s)
instance Num Natural where
(+) = addNatural
(-) = subNatural
(*) = mulNatural
abs = id
fromInteger = toNatural
signum n = if isZeroN n then zeroN else oneN
negate n = if isZeroN n then zeroN else error "Natural.negate"
-- | Choose the largest base such that (base-1)^2 <= (maxBound::Int)
-- so that we can multiply digits without overflowing. Use a power of ten
-- for efficient conversion to and from decimal representation.
base, baseDigits :: Int
base = ten^baseDigits --foldr1 (B.*) (replicate baseDigits ten)
baseDigits = pred intDigits `B.quot` two
intDigits = countDigits B.maxInt
countDigits n = if n `B.eqInt` zero then zero else one B.+ countDigits (n `B.quot` ten)
toNatural (Pos n) = n
toNatural (Neg n) | isZeroN n = zeroN
| otherwise = error "Natural.fromInteger: negative number"
doubleFromNatural (N as) = fromNat as
where
fromNat [] = primDoubleZero
fromNat (n:ns) = primDoubleFromInt n+dbase*fromNat ns
dbase = primDoubleFromInt base
intFromNatural (N as) = intFromNat as
intFromNat [] = zero
intFromNat (n:ns) = n+base*intFromNat ns
natFromInt n | n<zero = error $ "PreludeNatural.natFromInt: negative number: "
++show n
| otherwise = N (fromInt n)
where
fromInt n | n==zero = []
| otherwise = (n `rem` base):fromInt (n `quot` base)
addNatural (N as) (N bs) = N (add as bs)
add [] bs = bs
add as [] = as
add (a:as) (b:bs) = case a+b of
ab | ab<base -> ab:add as bs
| otherwise -> ab-base:succN (add as bs)
addSmall a [] = small a
addSmall a (b:bs) = case a+b of
ab | ab<base -> ab:bs
| otherwise -> ab-base:succN bs
succNatural (N as) = N (succN as)
succN [] = [one]
succN (a:as) = succN' (a+one) as
succN' b as | b<base = b:as
| otherwise = b-base:succN as
subNatural (N as) (N bs) = N (sub as bs)
sub [] bs = if isZeroN (N bs) then [] else error "Natural.-: negative result"
sub as [] = as
sub (a:as) (b:bs) | b==zero = a:sub as bs
| otherwise = if a>=b
then a-b:sub as bs
else a+base-b:predN (sub as bs)
predNatural (N as) = N (predN as)
predN [] = error "Natural.-: negative result"
predN (a:as) | a==zero = base-one:predN as
| otherwise = pred a:as
-- (a+10b)(c+10d) = ac+10*(ad+bc+10*bd)
mulNatural (N as) (N bs) = N (mul as bs)
mul ab@(a:b) cd@(c:d) | a==zero = zero:mul b cd
| c==zero = zero:mul ab d
| otherwise =
ac:(small q `add` mulSmall a d `add` mulSmall c b `add` mulBase (mul b d))
where
(q,ac) = quotRem (a*c) base
mul _ _ = []
small a = if a==zero then [] else [a]
mulSmall a [] = []
mulSmall a (b:bs) = ab:addSmall q (mulSmall a bs)
where
(q,ab) = quotRem (a*b) base
mulBase [] = []
mulBase as = zero:as
divBase (N as) = N (drop one as)
modBase e (N as) = N (take e as)
quotRemBase (N (a:as)) = (N as,small a)
--------------------------------------------------------------------------------
instance Eq Natural where
N [] == b = isZeroN b
a == N [] = isZeroN a
N (a:as) == N (b:bs) = a==b && N as==N bs
isZeroN (N ns) = all (==zero) ns
instance Ord Natural where
compare (N []) b = if isZeroN b then EQ else LT
compare a (N []) = if isZeroN a then EQ else GT
compare (N (a:as)) (N (b:bs)) = compare (N as,a) (N bs,b)
--------------------------------------------------------------------------------
instance Enum Natural where
toEnum i | i>=zero = natFromInt i
fromEnum = intFromNatural
succ = addNatural oneN
pred = predNatural
enumFrom = iterate succ
enumFromTo = genericEnumFromTo
enumFromThen a b = iterate (addNatural (b-a)) a
enumFromThenTo x y z = enumFromStepTo x (y-x) z
instance Real Natural where
toRational n = Pos n % Pos oneN
instance Integral Natural where
toInteger n = Pos n
quotRem (N a) (N b) = both N (qRemDigits a b)
both f (x,y) = (f x,f y)
-- Special-case some common patterns, to save the expense of doing
-- long division.
qRemDigits :: Digits -> Digits -> (Digits,Digits)
qRemDigits ds [e] | e==one = (ds, [])
qRemDigits [d] [e] = let (q,r) = d `quotRem` e in (small q,small r)
qRemDigits ds es | N ds < N es = ([],ds)
qRemDigits ds es = longDivision ds es
longDivision :: Digits -> Digits -> (Digits,Digits)
longDivision ds es =
-- trace ("long division "++show ds++show es) $
case es of
[] -> error "Natural: division by zero"
[e] -> quotRemSmall ds e
-- [e,f] -> quotRemSmall ds (e+base*f)
_ -> both decimal (reallyLong (binary ds) (binary es))
quotRemSmall ds e = walk (reverse ds) e ([],zero)
where
walk :: Digits -> Int -> (Digits, Int) -> (Digits, Digits)
walk [] e (quot,rem) = (quot,small rem)
walk (d:ds) e (quot,rem) = let (q,r) = (rem * base + d) `quotRem` e
in walk ds e (q:quot,r)
binary ds | isZeroN (N ds) = []
| otherwise = case quotRemSmall ds two of (ds',d) -> bit d:binary ds'
bit n = if isZeroN (N n) then O else I
decimal [] = []
decimal (O:bs) = mulSmall two (decimal bs)
decimal (I:bs) = succN (mulSmall two (decimal bs))
reallyLong :: Bits -> Bits -> (Bits,Bits)
reallyLong ds es | p<zero = ([],ds)
| otherwise = reallyLong' (reverse lo) hi es []
where
p = length ds - length es
(lo,hi) = splitAt p ds
-- | Simple but slow
reallyLong' hds ds es qs =
case subbin ds es of
Just ds' -> next ds' (I:qs)
Nothing -> next ds (O:qs)
where
next ds qs = case hds of
d:hds -> reallyLong' hds (d:ds) es qs
_ -> (qs,ds)
type Bits = [Bit]
data Bit = O | I deriving (Eq,Ord,Enum,Show)
double [] = []
double bs = O:bs
subbin as [] = Just as
subbin (O:as) (O:bs) = double <$> subbin as bs
subbin (I:as) (I:bs) = double <$> subbin as bs
subbin (I:as) (O:bs) = (I:) <$> subbin as bs
subbin (O:as) (I:bs) = (I:) <$> (predbin =<< subbin as bs)
subbin _ _ = Nothing
predbin (I:as) = Just (double as)
predbin (O:as) = (I:) <$> predbin as
predbin _ = Nothing