{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE Unsafe #-}
{-# OPTIONS_HADDOCK not-home #-}
module GHC.Natural
(
Natural(..)
, isValidNatural
, naturalFromInteger
, wordToNatural
, naturalToWordMaybe
, minusNaturalMaybe
, powModNatural
) where
#include "MachDeps.h"
import GHC.Arr
import GHC.Base
import {-# SOURCE #-} GHC.Exception (underflowException)
#if defined(MIN_VERSION_integer_gmp)
import GHC.Integer.GMP.Internals
import Data.Word
import Data.Int
#endif
import GHC.Num
import GHC.Real
import GHC.Read
import GHC.Show
import GHC.Enum
import GHC.List
import Data.Bits
default ()
{-# NOINLINE underflowError #-}
underflowError :: a
underflowError = raise# underflowException
#if defined(MIN_VERSION_integer_gmp)
data Natural = NatS# GmpLimb#
| NatJ# {-# UNPACK #-} !BigNat
deriving (Eq,Ord)
isValidNatural :: Natural -> Bool
isValidNatural (NatS# _) = True
isValidNatural (NatJ# bn) = isTrue# (isValidBigNat# bn)
&& I# (sizeofBigNat# bn) > 0
{-# RULES
"fromIntegral/Natural->Natural" fromIntegral = id :: Natural -> Natural
"fromIntegral/Natural->Integer" fromIntegral = toInteger :: Natural->Integer
"fromIntegral/Natural->Word" fromIntegral = naturalToWord
"fromIntegral/Natural->Word8"
fromIntegral = (fromIntegral :: Word -> Word8) . naturalToWord
"fromIntegral/Natural->Word16"
fromIntegral = (fromIntegral :: Word -> Word16) . naturalToWord
"fromIntegral/Natural->Word32"
fromIntegral = (fromIntegral :: Word -> Word32) . naturalToWord
"fromIntegral/Natural->Int8"
fromIntegral = (fromIntegral :: Int -> Int8) . naturalToInt
"fromIntegral/Natural->Int16"
fromIntegral = (fromIntegral :: Int -> Int16) . naturalToInt
"fromIntegral/Natural->Int32"
fromIntegral = (fromIntegral :: Int -> Int32) . naturalToInt
#-}
{-# RULES
"fromIntegral/Word->Natural" fromIntegral = wordToNatural
"fromIntegral/Word8->Natural"
fromIntegral = wordToNatural . (fromIntegral :: Word8 -> Word)
"fromIntegral/Word16->Natural"
fromIntegral = wordToNatural . (fromIntegral :: Word16 -> Word)
"fromIntegral/Word32->Natural"
fromIntegral = wordToNatural . (fromIntegral :: Word32 -> Word)
"fromIntegral/Int->Natural" fromIntegral = intToNatural
"fromIntegral/Int8->Natural"
fromIntegral = intToNatural . (fromIntegral :: Int8 -> Int)
"fromIntegral/Int16->Natural"
fromIntegral = intToNatural . (fromIntegral :: Int16 -> Int)
"fromIntegral/Int32->Natural"
fromIntegral = intToNatural . (fromIntegral :: Int32 -> Int)
#-}
#if WORD_SIZE_IN_BITS == 64
{-# RULES
"fromIntegral/Natural->Word64"
fromIntegral = (fromIntegral :: Word -> Word64) . naturalToWord
"fromIntegral/Natural->Int64"
fromIntegral = (fromIntegral :: Int -> Int64) . naturalToInt
"fromIntegral/Word64->Natural"
fromIntegral = wordToNatural . (fromIntegral :: Word64 -> Word)
"fromIntegral/Int64->Natural"
fromIntegral = intToNatural . (fromIntegral :: Int64 -> Int)
#-}
#endif
instance Show Natural where
showsPrec p (NatS# w#) = showsPrec p (W# w#)
showsPrec p (NatJ# bn) = showsPrec p (Jp# bn)
instance Read Natural where
readsPrec d = map (\(n, s) -> (fromInteger n, s))
. filter ((>= 0) . (\(x,_)->x)) . readsPrec d
instance Num Natural where
fromInteger = naturalFromInteger
(+) = plusNatural
(*) = timesNatural
(-) = minusNatural
abs = id
signum (NatS# 0##) = NatS# 0##
signum _ = NatS# 1##
negate (NatS# 0##) = NatS# 0##
negate _ = underflowError
naturalFromInteger :: Integer -> Natural
naturalFromInteger (S# i#) | I# i# >= 0 = NatS# (int2Word# i#)
naturalFromInteger (Jp# bn) = bigNatToNatural bn
naturalFromInteger _ = underflowError
{-# INLINE naturalFromInteger #-}
instance Real Natural where
toRational (NatS# w) = toRational (W# w)
toRational (NatJ# bn) = toRational (Jp# bn)
#if OPTIMISE_INTEGER_GCD_LCM
{-# RULES
"gcd/Natural->Natural->Natural" gcd = gcdNatural
"lcm/Natural->Natural->Natural" lcm = lcmNatural
#-}
gcdNatural :: Natural -> Natural -> Natural
gcdNatural (NatS# 0##) y = y
gcdNatural x (NatS# 0##) = x
gcdNatural (NatS# 1##) _ = (NatS# 1##)
gcdNatural _ (NatS# 1##) = (NatS# 1##)
gcdNatural (NatJ# x) (NatJ# y) = bigNatToNatural (gcdBigNat x y)
gcdNatural (NatJ# x) (NatS# y) = NatS# (gcdBigNatWord x y)
gcdNatural (NatS# x) (NatJ# y) = NatS# (gcdBigNatWord y x)
gcdNatural (NatS# x) (NatS# y) = NatS# (gcdWord x y)
lcmNatural :: Natural -> Natural -> Natural
lcmNatural (NatS# 0##) _ = (NatS# 0##)
lcmNatural _ (NatS# 0##) = (NatS# 0##)
lcmNatural (NatS# 1##) y = y
lcmNatural x (NatS# 1##) = x
lcmNatural x y = (x `quot` (gcdNatural x y)) * y
#endif
instance Enum Natural where
succ n = n `plusNatural` NatS# 1##
pred n = n `minusNatural` NatS# 1##
toEnum = intToNatural
fromEnum (NatS# w) | i >= 0 = i
where
i = fromIntegral (W# w)
fromEnum _ = errorWithoutStackTrace "fromEnum: out of Int range"
enumFrom x = enumDeltaNatural x (NatS# 1##)
enumFromThen x y
| x <= y = enumDeltaNatural x (y-x)
| otherwise = enumNegDeltaToNatural x (x-y) (NatS# 0##)
enumFromTo x lim = enumDeltaToNatural x (NatS# 1##) lim
enumFromThenTo x y lim
| x <= y = enumDeltaToNatural x (y-x) lim
| otherwise = enumNegDeltaToNatural x (x-y) lim
enumDeltaNatural :: Natural -> Natural -> [Natural]
enumDeltaNatural !x d = x : enumDeltaNatural (x+d) d
enumDeltaToNatural :: Natural -> Natural -> Natural -> [Natural]
enumDeltaToNatural x0 delta lim = go x0
where
go x | x > lim = []
| otherwise = x : go (x+delta)
enumNegDeltaToNatural :: Natural -> Natural -> Natural -> [Natural]
enumNegDeltaToNatural x0 ndelta lim = go x0
where
go x | x < lim = []
| x >= ndelta = x : go (x-ndelta)
| otherwise = [x]
instance Integral Natural where
toInteger (NatS# w) = wordToInteger w
toInteger (NatJ# bn) = Jp# bn
divMod = quotRem
div = quot
mod = rem
quotRem _ (NatS# 0##) = divZeroError
quotRem n (NatS# 1##) = (n,NatS# 0##)
quotRem n@(NatS# _) (NatJ# _) = (NatS# 0##, n)
quotRem (NatS# n) (NatS# d) = case quotRem (W# n) (W# d) of
(q,r) -> (wordToNatural q, wordToNatural r)
quotRem (NatJ# n) (NatS# d) = case quotRemBigNatWord n d of
(# q,r #) -> (bigNatToNatural q, NatS# r)
quotRem (NatJ# n) (NatJ# d) = case quotRemBigNat n d of
(# q,r #) -> (bigNatToNatural q, bigNatToNatural r)
quot _ (NatS# 0##) = divZeroError
quot n (NatS# 1##) = n
quot (NatS# _) (NatJ# _) = NatS# 0##
quot (NatS# n) (NatS# d) = wordToNatural (quot (W# n) (W# d))
quot (NatJ# n) (NatS# d) = bigNatToNatural (quotBigNatWord n d)
quot (NatJ# n) (NatJ# d) = bigNatToNatural (quotBigNat n d)
rem _ (NatS# 0##) = divZeroError
rem _ (NatS# 1##) = NatS# 0##
rem n@(NatS# _) (NatJ# _) = n
rem (NatS# n) (NatS# d) = wordToNatural (rem (W# n) (W# d))
rem (NatJ# n) (NatS# d) = NatS# (remBigNatWord n d)
rem (NatJ# n) (NatJ# d) = bigNatToNatural (remBigNat n d)
instance Ix Natural where
range (m,n) = [m..n]
inRange (m,n) i = m <= i && i <= n
unsafeIndex (m,_) i = fromIntegral (i-m)
index b i | inRange b i = unsafeIndex b i
| otherwise = indexError b i "Natural"
instance Bits Natural where
NatS# n .&. NatS# m = wordToNatural (W# n .&. W# m)
NatS# n .&. NatJ# m = wordToNatural (W# n .&. W# (bigNatToWord m))
NatJ# n .&. NatS# m = wordToNatural (W# (bigNatToWord n) .&. W# m)
NatJ# n .&. NatJ# m = bigNatToNatural (andBigNat n m)
NatS# n .|. NatS# m = wordToNatural (W# n .|. W# m)
NatS# n .|. NatJ# m = NatJ# (orBigNat (wordToBigNat n) m)
NatJ# n .|. NatS# m = NatJ# (orBigNat n (wordToBigNat m))
NatJ# n .|. NatJ# m = NatJ# (orBigNat n m)
NatS# n `xor` NatS# m = wordToNatural (W# n `xor` W# m)
NatS# n `xor` NatJ# m = NatJ# (xorBigNat (wordToBigNat n) m)
NatJ# n `xor` NatS# m = NatJ# (xorBigNat n (wordToBigNat m))
NatJ# n `xor` NatJ# m = bigNatToNatural (xorBigNat n m)
complement _ = errorWithoutStackTrace "Bits.complement: Natural complement undefined"
bitSizeMaybe _ = Nothing
bitSize = errorWithoutStackTrace "Natural: bitSize"
isSigned _ = False
bit i@(I# i#) | i < finiteBitSize (0::Word) = wordToNatural (bit i)
| otherwise = NatJ# (bitBigNat i#)
testBit (NatS# w) i = testBit (W# w) i
testBit (NatJ# bn) (I# i#) = testBitBigNat bn i#
clearBit n@(NatS# w#) i
| i < finiteBitSize (0::Word) = let !(W# w2#) = clearBit (W# w#) i in NatS# w2#
| otherwise = n
clearBit (NatJ# bn) (I# i#) = bigNatToNatural (clearBitBigNat bn i#)
setBit (NatS# w#) i@(I# i#)
| i < finiteBitSize (0::Word) = let !(W# w2#) = setBit (W# w#) i in NatS# w2#
| otherwise = bigNatToNatural (setBitBigNat (wordToBigNat w#) i#)
setBit (NatJ# bn) (I# i#) = bigNatToNatural (setBitBigNat bn i#)
complementBit (NatS# w#) i@(I# i#)
| i < finiteBitSize (0::Word) = let !(W# w2#) = complementBit (W# w#) i in NatS# w2#
| otherwise = bigNatToNatural (setBitBigNat (wordToBigNat w#) i#)
complementBit (NatJ# bn) (I# i#) = bigNatToNatural (complementBitBigNat bn i#)
shiftL n 0 = n
shiftL (NatS# 0##) _ = NatS# 0##
shiftL (NatS# 1##) i = bit i
shiftL (NatS# w) (I# i#)
= bigNatToNatural $ shiftLBigNat (wordToBigNat w) i#
shiftL (NatJ# bn) (I# i#)
= bigNatToNatural $ shiftLBigNat bn i#
shiftR n 0 = n
shiftR (NatS# w) i = wordToNatural $ shiftR (W# w) i
shiftR (NatJ# bn) (I# i#) = bigNatToNatural (shiftRBigNat bn i#)
rotateL = shiftL
rotateR = shiftR
popCount (NatS# w) = popCount (W# w)
popCount (NatJ# bn) = I# (popCountBigNat bn)
zeroBits = NatS# 0##
plusNatural :: Natural -> Natural -> Natural
plusNatural (NatS# 0##) y = y
plusNatural x (NatS# 0##) = x
plusNatural (NatS# x) (NatS# y)
= case plusWord2# x y of
(# 0##, l #) -> NatS# l
(# h, l #) -> NatJ# (wordToBigNat2 h l)
plusNatural (NatS# x) (NatJ# y) = NatJ# (plusBigNatWord y x)
plusNatural (NatJ# x) (NatS# y) = NatJ# (plusBigNatWord x y)
plusNatural (NatJ# x) (NatJ# y) = NatJ# (plusBigNat x y)
timesNatural :: Natural -> Natural -> Natural
timesNatural _ (NatS# 0##) = NatS# 0##
timesNatural (NatS# 0##) _ = NatS# 0##
timesNatural x (NatS# 1##) = x
timesNatural (NatS# 1##) y = y
timesNatural (NatS# x) (NatS# y) = case timesWord2# x y of
(# 0##, 0## #) -> NatS# 0##
(# 0##, xy #) -> NatS# xy
(# h , l #) -> NatJ# $ wordToBigNat2 h l
timesNatural (NatS# x) (NatJ# y) = NatJ# $ timesBigNatWord y x
timesNatural (NatJ# x) (NatS# y) = NatJ# $ timesBigNatWord x y
timesNatural (NatJ# x) (NatJ# y) = NatJ# $ timesBigNat x y
minusNatural :: Natural -> Natural -> Natural
minusNatural x (NatS# 0##) = x
minusNatural (NatS# x) (NatS# y) = case subWordC# x y of
(# l, 0# #) -> NatS# l
_ -> underflowError
minusNatural (NatS# _) (NatJ# _) = underflowError
minusNatural (NatJ# x) (NatS# y)
= bigNatToNatural $ minusBigNatWord x y
minusNatural (NatJ# x) (NatJ# y)
= bigNatToNatural $ minusBigNat x y
minusNaturalMaybe :: Natural -> Natural -> Maybe Natural
minusNaturalMaybe x (NatS# 0##) = Just x
minusNaturalMaybe (NatS# x) (NatS# y) = case subWordC# x y of
(# l, 0# #) -> Just (NatS# l)
_ -> Nothing
where
minusNaturalMaybe (NatS# _) (NatJ# _) = Nothing
minusNaturalMaybe (NatJ# x) (NatS# y)
= Just $ bigNatToNatural $ minusBigNatWord x y
minusNaturalMaybe (NatJ# x) (NatJ# y)
| isTrue# (isNullBigNat# res) = Nothing
| otherwise = Just (bigNatToNatural res)
where
res = minusBigNat x y
bigNatToNatural :: BigNat -> Natural
bigNatToNatural bn
| isTrue# (sizeofBigNat# bn ==# 1#) = NatS# (bigNatToWord bn)
| isTrue# (isNullBigNat# bn) = underflowError
| otherwise = NatJ# bn
naturalToBigNat :: Natural -> BigNat
naturalToBigNat (NatS# w#) = wordToBigNat w#
naturalToBigNat (NatJ# bn) = bn
intToNatural :: Int -> Natural
intToNatural i | i<0 = underflowError
intToNatural (I# i#) = NatS# (int2Word# i#)
naturalToWord :: Natural -> Word
naturalToWord (NatS# w#) = W# w#
naturalToWord (NatJ# bn) = W# (bigNatToWord bn)
naturalToInt :: Natural -> Int
naturalToInt (NatS# w#) = I# (word2Int# w#)
naturalToInt (NatJ# bn) = I# (bigNatToInt bn)
#else /* !defined(MIN_VERSION_integer_gmp) */
newtype Natural = Natural Integer
deriving (Eq,Ord,Ix)
isValidNatural :: Natural -> Bool
isValidNatural (Natural i) = i >= 0
instance Read Natural where
readsPrec d = map (\(n, s) -> (Natural n, s))
. filter ((>= 0) . (\(x,_)->x)) . readsPrec d
instance Show Natural where
showsPrec d (Natural i) = showsPrec d i
instance Num Natural where
Natural n + Natural m = Natural (n + m)
{-# INLINE (+) #-}
Natural n * Natural m = Natural (n * m)
{-# INLINE (*) #-}
Natural n - Natural m | result < 0 = underflowError
| otherwise = Natural result
where result = n - m
{-# INLINE (-) #-}
abs (Natural n) = Natural n
{-# INLINE abs #-}
signum (Natural n) = Natural (signum n)
{-# INLINE signum #-}
fromInteger = naturalFromInteger
{-# INLINE fromInteger #-}
naturalFromInteger :: Integer -> Natural
naturalFromInteger n
| n >= 0 = Natural n
| otherwise = underflowError
{-# INLINE naturalFromInteger #-}
minusNaturalMaybe :: Natural -> Natural -> Maybe Natural
minusNaturalMaybe x y
| x >= y = Just (x - y)
| otherwise = Nothing
instance Bits Natural where
Natural n .&. Natural m = Natural (n .&. m)
{-# INLINE (.&.) #-}
Natural n .|. Natural m = Natural (n .|. m)
{-# INLINE (.|.) #-}
xor (Natural n) (Natural m) = Natural (xor n m)
{-# INLINE xor #-}
complement _ = errorWithoutStackTrace "Bits.complement: Natural complement undefined"
{-# INLINE complement #-}
shift (Natural n) = Natural . shift n
{-# INLINE shift #-}
rotate (Natural n) = Natural . rotate n
{-# INLINE rotate #-}
bit = Natural . bit
{-# INLINE bit #-}
setBit (Natural n) = Natural . setBit n
{-# INLINE setBit #-}
clearBit (Natural n) = Natural . clearBit n
{-# INLINE clearBit #-}
complementBit (Natural n) = Natural . complementBit n
{-# INLINE complementBit #-}
testBit (Natural n) = testBit n
{-# INLINE testBit #-}
bitSizeMaybe _ = Nothing
{-# INLINE bitSizeMaybe #-}
bitSize = errorWithoutStackTrace "Natural: bitSize"
{-# INLINE bitSize #-}
isSigned _ = False
{-# INLINE isSigned #-}
shiftL (Natural n) = Natural . shiftL n
{-# INLINE shiftL #-}
shiftR (Natural n) = Natural . shiftR n
{-# INLINE shiftR #-}
rotateL (Natural n) = Natural . rotateL n
{-# INLINE rotateL #-}
rotateR (Natural n) = Natural . rotateR n
{-# INLINE rotateR #-}
popCount (Natural n) = popCount n
{-# INLINE popCount #-}
zeroBits = Natural 0
instance Real Natural where
toRational (Natural a) = toRational a
{-# INLINE toRational #-}
instance Enum Natural where
pred (Natural 0) = errorWithoutStackTrace "Natural.pred: 0"
pred (Natural n) = Natural (pred n)
{-# INLINE pred #-}
succ (Natural n) = Natural (succ n)
{-# INLINE succ #-}
fromEnum (Natural n) = fromEnum n
{-# INLINE fromEnum #-}
toEnum n | n < 0 = errorWithoutStackTrace "Natural.toEnum: negative"
| otherwise = Natural (toEnum n)
{-# INLINE toEnum #-}
enumFrom = coerce (enumFrom :: Integer -> [Integer])
enumFromThen x y
| x <= y = coerce (enumFromThen :: Integer -> Integer -> [Integer]) x y
| otherwise = enumFromThenTo x y 0
enumFromTo = coerce (enumFromTo :: Integer -> Integer -> [Integer])
enumFromThenTo
= coerce (enumFromThenTo :: Integer -> Integer -> Integer -> [Integer])
instance Integral Natural where
quot (Natural a) (Natural b) = Natural (quot a b)
{-# INLINE quot #-}
rem (Natural a) (Natural b) = Natural (rem a b)
{-# INLINE rem #-}
div (Natural a) (Natural b) = Natural (div a b)
{-# INLINE div #-}
mod (Natural a) (Natural b) = Natural (mod a b)
{-# INLINE mod #-}
divMod (Natural a) (Natural b) = (Natural q, Natural r)
where (q,r) = divMod a b
{-# INLINE divMod #-}
quotRem (Natural a) (Natural b) = (Natural q, Natural r)
where (q,r) = quotRem a b
{-# INLINE quotRem #-}
toInteger (Natural a) = a
{-# INLINE toInteger #-}
#endif
wordToNatural :: Word -> Natural
#if defined(MIN_VERSION_integer_gmp)
wordToNatural (W# w#) = NatS# w#
#else
wordToNatural w = Natural (fromIntegral w)
#endif
naturalToWordMaybe :: Natural -> Maybe Word
#if defined(MIN_VERSION_integer_gmp)
naturalToWordMaybe (NatS# w#) = Just (W# w#)
naturalToWordMaybe (NatJ# _) = Nothing
#else
naturalToWordMaybe (Natural i)
| i <= maxw = Just (fromIntegral i)
| otherwise = Nothing
where
maxw = toInteger (maxBound :: Word)
#endif
powModNatural :: Natural -> Natural -> Natural -> Natural
#if defined(MIN_VERSION_integer_gmp)
powModNatural _ _ (NatS# 0##) = divZeroError
powModNatural _ _ (NatS# 1##) = NatS# 0##
powModNatural _ (NatS# 0##) _ = NatS# 1##
powModNatural (NatS# 0##) _ _ = NatS# 0##
powModNatural (NatS# 1##) _ _ = NatS# 1##
powModNatural (NatS# b) (NatS# e) (NatS# m) = NatS# (powModWord b e m)
powModNatural b e (NatS# m)
= NatS# (powModBigNatWord (naturalToBigNat b) (naturalToBigNat e) m)
powModNatural b e (NatJ# m)
= bigNatToNatural (powModBigNat (naturalToBigNat b) (naturalToBigNat e) m)
#else
powModNatural _ _ 0 = divZeroError
powModNatural _ _ 1 = 0
powModNatural _ 0 _ = 1
powModNatural 0 _ _ = 0
powModNatural 1 _ _ = 1
powModNatural b0 e0 m = go b0 e0 1
where
go !b e !r
| odd e = go b' e' (r*b `mod` m)
| e == 0 = r
| otherwise = go b' e' r
where
b' = b*b `mod` m
e' = e `unsafeShiftR` 1
#endif