{-# LANGUAGE BangPatterns       #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE Safe               #-}
-- | Positive binary natural numbers, 'BinP'.
--
-- This module is designed to be imported qualified.
--
module Data.BinP (
    BinP(..),
    -- * Conversions
    cata,
    toNatural,
    fromNatural,
    toNat,
    -- * Showing
    explicitShow,
    explicitShowsPrec,
    -- * Extras
    predMaybe,
    -- * Aliases
    binP1, binP2, binP3, binP4, binP5, binP6, binP7, binP8, binP9,
    ) where

import Control.DeepSeq (NFData (..))
import Data.Bits       (Bits (..))
import Data.Data       (Data)
import Data.Hashable   (Hashable (..))
import Data.Monoid     (mappend)
import Data.Nat        (Nat (..))
import Data.Typeable   (Typeable)
import GHC.Exception   (ArithException (..), throw)
import Numeric.Natural (Natural)

import qualified Data.Nat        as N
import qualified Test.QuickCheck as QC

-- $setup
-- >>> import Data.List (sort)

-------------------------------------------------------------------------------
-- BinP
-------------------------------------------------------------------------------

-- | Non-zero binary natural numbers.
--
-- We could have called this type @Bin1@,
-- but that's used as type alias for promoted @'BP' 'BE'@ in "Data.Type.Bin".
data BinP
    = BE        -- ^ one
    | B0 BinP  -- ^ mult2
    | B1 BinP  -- ^ mult2 plus 1
  deriving (BinP -> BinP -> Bool
(BinP -> BinP -> Bool) -> (BinP -> BinP -> Bool) -> Eq BinP
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BinP -> BinP -> Bool
== :: BinP -> BinP -> Bool
$c/= :: BinP -> BinP -> Bool
/= :: BinP -> BinP -> Bool
Eq, Typeable, Typeable @(*) BinP
Typeable @(*) BinP =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> BinP -> c BinP)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c BinP)
-> (BinP -> Constr)
-> (BinP -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable @(* -> *) t =>
    (forall d. Data d => c (t d)) -> Maybe (c BinP))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable @(* -> * -> *) t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c BinP))
-> ((forall b. Data b => b -> b) -> BinP -> BinP)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> BinP -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> BinP -> r)
-> (forall u. (forall d. Data d => d -> u) -> BinP -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> BinP -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> BinP -> m BinP)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> BinP -> m BinP)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> BinP -> m BinP)
-> Data BinP
BinP -> Constr
BinP -> DataType
(forall b. Data b => b -> b) -> BinP -> BinP
forall a.
Typeable @(*) a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable @(* -> *) t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable @(* -> * -> *) t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> BinP -> u
forall u. (forall d. Data d => d -> u) -> BinP -> [u]
forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> BinP -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> BinP -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> BinP -> m BinP
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> BinP -> m BinP
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c BinP
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> BinP -> c BinP
forall (t :: * -> *) (c :: * -> *).
Typeable @(* -> *) t =>
(forall d. Data d => c (t d)) -> Maybe (c BinP)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable @(* -> * -> *) t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c BinP)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> BinP -> c BinP
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> BinP -> c BinP
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c BinP
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c BinP
$ctoConstr :: BinP -> Constr
toConstr :: BinP -> Constr
$cdataTypeOf :: BinP -> DataType
dataTypeOf :: BinP -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable @(* -> *) t =>
(forall d. Data d => c (t d)) -> Maybe (c BinP)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable @(* -> *) t =>
(forall d. Data d => c (t d)) -> Maybe (c BinP)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable @(* -> * -> *) t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c BinP)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable @(* -> * -> *) t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c BinP)
$cgmapT :: (forall b. Data b => b -> b) -> BinP -> BinP
gmapT :: (forall b. Data b => b -> b) -> BinP -> BinP
$cgmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> BinP -> r
gmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> BinP -> r
$cgmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> BinP -> r
gmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> BinP -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> BinP -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> BinP -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> BinP -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> BinP -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> BinP -> m BinP
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> BinP -> m BinP
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> BinP -> m BinP
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> BinP -> m BinP
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> BinP -> m BinP
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> BinP -> m BinP
Data)

-------------------------------------------------------------------------------
-- Instances
-------------------------------------------------------------------------------

-- |
--
-- >>> sort [ 1 .. 9 :: BinP ]
-- [1,2,3,4,5,6,7,8,9]
--
-- >>> sort $ reverse [ 1 .. 9 :: BinP ]
-- [1,2,3,4,5,6,7,8,9]
--
-- >>> sort $ [ 1 .. 9 ] ++ [ 1 .. 9 :: BinP ]
-- [1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8,9,9]
--
instance Ord BinP where
    compare :: BinP -> BinP -> Ordering
compare = Ordering -> BinP -> BinP -> Ordering
go Ordering
EQ where
        go :: Ordering -> BinP -> BinP -> Ordering
go  Ordering
acc BinP
BE     BinP
BE     = Ordering
acc
        go Ordering
_acc BinP
BE     BinP
_      = Ordering
LT
        go Ordering
_acc BinP
_      BinP
BE     = Ordering
GT
        go  Ordering
acc (B0 BinP
a) (B0 BinP
b) = Ordering -> BinP -> BinP -> Ordering
go Ordering
acc BinP
a BinP
b
        go  Ordering
acc (B1 BinP
a) (B1 BinP
b) = Ordering -> BinP -> BinP -> Ordering
go Ordering
acc BinP
a BinP
b
        go Ordering
_acc (B0 BinP
a) (B1 BinP
b) = Ordering -> BinP -> BinP -> Ordering
go Ordering
LT  BinP
a BinP
b
        go Ordering
_acc (B1 BinP
a) (B0 BinP
b) = Ordering -> BinP -> BinP -> Ordering
go Ordering
GT  BinP
a BinP
b

instance Show BinP where
    showsPrec :: Int -> BinP -> ShowS
showsPrec Int
d = Int -> Natural -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
d (Natural -> ShowS) -> (BinP -> Natural) -> BinP -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinP -> Natural
toNatural

instance Num BinP where
    fromInteger :: Integer -> BinP
fromInteger = Natural -> BinP
fromNatural (Natural -> BinP) -> (Integer -> Natural) -> Integer -> BinP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Natural
forall a. Num a => Integer -> a
fromInteger

    BinP
BE   + :: BinP -> BinP -> BinP
+ BinP
b    = BinP -> BinP
forall a. Enum a => a -> a
succ BinP
b
    BinP
b    + BinP
BE   = BinP -> BinP
forall a. Enum a => a -> a
succ BinP
b
    B0 BinP
a + B0 BinP
b = BinP -> BinP
B0 (BinP
a BinP -> BinP -> BinP
forall a. Num a => a -> a -> a
+ BinP
b)
    B0 BinP
a + B1 BinP
b = BinP -> BinP
B1 (BinP
a BinP -> BinP -> BinP
forall a. Num a => a -> a -> a
+ BinP
b)
    B1 BinP
a + B0 BinP
b = BinP -> BinP
B1 (BinP
a BinP -> BinP -> BinP
forall a. Num a => a -> a -> a
+ BinP
b)
    B1 BinP
a + B1 BinP
b = BinP -> BinP
B0 (BinP -> BinP
forall a. Enum a => a -> a
succ (BinP
a BinP -> BinP -> BinP
forall a. Num a => a -> a -> a
+ BinP
b))

    BinP
BE * :: BinP -> BinP -> BinP
* BinP
b = BinP
b
    BinP
a  * BinP
BE = BinP
a
    B0 BinP
a * B0 BinP
b = BinP -> BinP
B0 (BinP -> BinP
B0 (BinP
a BinP -> BinP -> BinP
forall a. Num a => a -> a -> a
* BinP
b))
    B1 BinP
a * B0 BinP
b = BinP -> BinP
B0 (BinP -> BinP
B0 (BinP
a BinP -> BinP -> BinP
forall a. Num a => a -> a -> a
* BinP
b)) BinP -> BinP -> BinP
forall a. Num a => a -> a -> a
+ BinP -> BinP
B0 BinP
b
    B0 BinP
a * B1 BinP
b = BinP -> BinP
B0 (BinP -> BinP
B0 (BinP
a BinP -> BinP -> BinP
forall a. Num a => a -> a -> a
* BinP
b)) BinP -> BinP -> BinP
forall a. Num a => a -> a -> a
+ BinP -> BinP
B0 BinP
a
    B1 BinP
a * B1 BinP
b = BinP -> BinP
B1 (BinP -> BinP
B0 (BinP
a BinP -> BinP -> BinP
forall a. Num a => a -> a -> a
* BinP
b)) BinP -> BinP -> BinP
forall a. Num a => a -> a -> a
+ BinP -> BinP
B0 BinP
a BinP -> BinP -> BinP
forall a. Num a => a -> a -> a
+ BinP -> BinP
B0 BinP
b

    abs :: BinP -> BinP
abs = BinP -> BinP
forall a. a -> a
id

    signum :: BinP -> BinP
signum BinP
_ = BinP
BE

    negate :: BinP -> BinP
negate BinP
_ = String -> BinP
forall a. HasCallStack => String -> a
error String
"negate @Bin"

instance Real BinP where
    toRational :: BinP -> Rational
toRational = Integer -> Rational
forall a. Real a => a -> Rational
toRational (Integer -> Rational) -> (BinP -> Integer) -> BinP -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinP -> Integer
forall a. Integral a => a -> Integer
toInteger

instance Integral BinP where
    toInteger :: BinP -> Integer
toInteger = Natural -> Integer
forall a. Integral a => a -> Integer
toInteger (Natural -> Integer) -> (BinP -> Natural) -> BinP -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinP -> Natural
toNatural

    quotRem :: BinP -> BinP -> (BinP, BinP)
quotRem BinP
_ BinP
_ = String -> (BinP, BinP)
forall a. HasCallStack => String -> a
error String
"quotRem @Bin is not implemented"

instance Enum BinP where
    succ :: BinP -> BinP
succ BinP
BE     = BinP -> BinP
B0 BinP
BE
    succ (B0 BinP
n) = BinP -> BinP
B1 BinP
n
    succ (B1 BinP
n) = BinP -> BinP
B0 (BinP -> BinP
forall a. Enum a => a -> a
succ BinP
n)

    pred :: BinP -> BinP
pred BinP
n = case BinP -> Maybe BinP
predMaybe BinP
n of
        Maybe BinP
Nothing -> ArithException -> BinP
forall a e. Exception e => e -> a
throw ArithException
Underflow
        Just BinP
m  -> BinP
m

    toEnum :: Int -> BinP
toEnum Int
n = case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
n Int
1 of
        Ordering
LT -> ArithException -> BinP
forall a e. Exception e => e -> a
throw ArithException
Underflow
        Ordering
EQ -> BinP
BE
        Ordering
GT -> case Int
n Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
2 of
            (Int
m, Int
0) -> BinP -> BinP
B0 (Int -> BinP
forall a. Enum a => Int -> a
toEnum Int
m)
            (Int
m, Int
_) -> BinP -> BinP
B1 (Int -> BinP
forall a. Enum a => Int -> a
toEnum Int
m)

    fromEnum :: BinP -> Int
fromEnum BinP
BE     = Int
1
    fromEnum (B0 BinP
n) = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* BinP -> Int
forall a. Enum a => a -> Int
fromEnum BinP
n
    fromEnum (B1 BinP
n) = Int -> Int
forall a. Enum a => a -> a
succ (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* BinP -> Int
forall a. Enum a => a -> Int
fromEnum BinP
n)

instance NFData BinP where
    rnf :: BinP -> ()
rnf BinP
BE     = ()
    rnf (B0 BinP
n) = BinP -> ()
forall a. NFData a => a -> ()
rnf BinP
n
    rnf (B1 BinP
n) = BinP -> ()
forall a. NFData a => a -> ()
rnf BinP
n

instance Hashable BinP where
    hashWithSalt :: Int -> BinP -> Int
hashWithSalt = Int -> BinP -> Int
forall a. HasCallStack => a
undefined

predMaybe :: BinP -> Maybe BinP
predMaybe :: BinP -> Maybe BinP
predMaybe BinP
BE     = Maybe BinP
forall a. Maybe a
Nothing
predMaybe (B1 BinP
n) = BinP -> Maybe BinP
forall a. a -> Maybe a
Just (BinP -> BinP
B0 BinP
n)
predMaybe (B0 BinP
n) = BinP -> Maybe BinP
forall a. a -> Maybe a
Just (Maybe BinP -> BinP
mult2Plus1 (BinP -> Maybe BinP
predMaybe BinP
n))
  where
    mult2Plus1 :: Maybe BinP -> BinP
    mult2Plus1 :: Maybe BinP -> BinP
mult2Plus1 = BinP -> (BinP -> BinP) -> Maybe BinP -> BinP
forall b a. b -> (a -> b) -> Maybe a -> b
maybe BinP
BE BinP -> BinP
B1

-------------------------------------------------------------------------------
-- Bits
-------------------------------------------------------------------------------

-- | __NOTE__: '.&.', 'xor', 'shiftR' and 'rotateR' are __NOT_ implemented.
-- They may make number zero.
--
instance Bits BinP where
    B0 BinP
a .|. :: BinP -> BinP -> BinP
.|. B0 BinP
b = BinP -> BinP
B0 (BinP
a BinP -> BinP -> BinP
forall a. Bits a => a -> a -> a
.|. BinP
b)
    B0 BinP
a .|. B1 BinP
b = BinP -> BinP
B1 (BinP
a BinP -> BinP -> BinP
forall a. Bits a => a -> a -> a
.|. BinP
b)
    B1 BinP
a .|. B0 BinP
b = BinP -> BinP
B1 (BinP
a BinP -> BinP -> BinP
forall a. Bits a => a -> a -> a
.|. BinP
b)
    B1 BinP
a .|. B1 BinP
b = BinP -> BinP
B1 (BinP
a BinP -> BinP -> BinP
forall a. Bits a => a -> a -> a
.|. BinP
b)

    BinP
BE   .|. B0 BinP
b = BinP -> BinP
B1 BinP
b
    BinP
BE   .|. B1 BinP
b = BinP -> BinP
B1 BinP
b
    B0 BinP
b .|. BinP
BE   = BinP -> BinP
B1 BinP
b
    B1 BinP
b .|. BinP
BE   = BinP -> BinP
B1 BinP
b

    BinP
BE   .|. BinP
BE   = BinP
BE

    bit :: Int -> BinP
bit Int
n
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = BinP
BE
        | Bool
otherwise = BinP -> BinP
B0 (Int -> BinP
forall a. Bits a => Int -> a
bit (Int -> Int
forall a. Enum a => a -> a
pred Int
n))

    shiftL :: BinP -> Int -> BinP
shiftL BinP
b Int
n
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0    = BinP
b
        | Bool
otherwise = BinP -> Int -> BinP
forall a. Bits a => a -> Int -> a
shiftL (BinP -> BinP
B0 BinP
b) (Int -> Int
forall a. Enum a => a -> a
pred Int
n)

    rotateL :: BinP -> Int -> BinP
rotateL = BinP -> Int -> BinP
forall a. Bits a => a -> Int -> a
shiftL

    popCount :: BinP -> Int
popCount = Int -> BinP -> Int
forall {t}. Enum t => t -> BinP -> t
go Int
1 where
        go :: t -> BinP -> t
go !t
acc BinP
BE     = t
acc
        go !t
acc (B0 BinP
b) = t -> BinP -> t
go t
acc BinP
b
        go !t
acc (B1 BinP
b) = t -> BinP -> t
go (t -> t
forall a. Enum a => a -> a
succ t
acc) BinP
b

    testBit :: BinP -> Int -> Bool
testBit BinP
BE     Int
0 = Bool
True
    testBit (B0 BinP
_) Int
0 = Bool
False
    testBit (B1 BinP
_) Int
0 = Bool
True
    testBit BinP
BE     Int
_ = Bool
False
    testBit (B0 BinP
b) Int
n = BinP -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit BinP
b (Int -> Int
forall a. Enum a => a -> a
pred Int
n)
    testBit (B1 BinP
b) Int
n = BinP -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit BinP
b (Int -> Int
forall a. Enum a => a -> a
pred Int
n)

    zeroBits :: BinP
zeroBits          = String -> BinP
forall a. HasCallStack => String -> a
error String
"zeroBits @BinP is undefined"
    clearBit :: BinP -> Int -> BinP
clearBit BinP
_ Int
_      = String -> BinP
forall a. HasCallStack => String -> a
error String
"clearBit @BinP is undefined"
    complementBit :: BinP -> Int -> BinP
complementBit BinP
_ Int
_ = String -> BinP
forall a. HasCallStack => String -> a
error String
"complementBit @BinP is undefined"
    xor :: BinP -> BinP -> BinP
xor BinP
_ BinP
_           = String -> BinP
forall a. HasCallStack => String -> a
error String
"xor @BinP is undefined"
    .&. :: BinP -> BinP -> BinP
(.&.) BinP
_ BinP
_         = String -> BinP
forall a. HasCallStack => String -> a
error String
"(.&.) @BinP is undefined"
    shiftR :: BinP -> Int -> BinP
shiftR BinP
_          = String -> Int -> BinP
forall a. HasCallStack => String -> a
error String
"shiftR @BinP is undefined"
    rotateR :: BinP -> Int -> BinP
rotateR BinP
_         = String -> Int -> BinP
forall a. HasCallStack => String -> a
error String
"shiftL @BinP is undefined"
    complement :: BinP -> BinP
complement  BinP
_     = String -> BinP
forall a. HasCallStack => String -> a
error String
"compelement @BinP is undefined"
    bitSizeMaybe :: BinP -> Maybe Int
bitSizeMaybe BinP
_    = Maybe Int
forall a. Maybe a
Nothing
    bitSize :: BinP -> Int
bitSize BinP
_         = String -> Int
forall a. HasCallStack => String -> a
error String
"bitSize @BinP is undefined"
    isSigned :: BinP -> Bool
isSigned BinP
_        = Bool
True

-------------------------------------------------------------------------------
-- QuickCheck
-------------------------------------------------------------------------------

instance QC.Arbitrary BinP where
    arbitrary :: Gen BinP
arbitrary = do
        [Bool]
bs <- Gen [Bool]
forall a. Arbitrary a => Gen a
QC.arbitrary :: QC.Gen [Bool]
        BinP -> Gen BinP
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool -> BinP -> BinP) -> BinP -> [Bool] -> BinP
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Bool
b -> if Bool
b then BinP -> BinP
B1 else BinP -> BinP
B0) BinP
BE [Bool]
bs)

    shrink :: BinP -> [BinP]
shrink BinP
BE     = []
    shrink (B1 BinP
b) = BinP
b BinP -> [BinP] -> [BinP]
forall a. a -> [a] -> [a]
: BinP -> BinP
B0 BinP
b BinP -> [BinP] -> [BinP]
forall a. a -> [a] -> [a]
: (BinP -> BinP) -> [BinP] -> [BinP]
forall a b. (a -> b) -> [a] -> [b]
map BinP -> BinP
B1 (BinP -> [BinP]
forall a. Arbitrary a => a -> [a]
QC.shrink BinP
b)
    shrink (B0 BinP
b) = BinP
b BinP -> [BinP] -> [BinP]
forall a. a -> [a] -> [a]
: (BinP -> BinP) -> [BinP] -> [BinP]
forall a b. (a -> b) -> [a] -> [b]
map BinP -> BinP
B0 (BinP -> [BinP]
forall a. Arbitrary a => a -> [a]
QC.shrink BinP
b)

instance QC.CoArbitrary BinP where
    coarbitrary :: forall b. BinP -> Gen b -> Gen b
coarbitrary = Maybe (Either BinP BinP) -> Gen b -> Gen b
forall b. Maybe (Either BinP BinP) -> Gen b -> Gen b
forall a b. CoArbitrary a => a -> Gen b -> Gen b
QC.coarbitrary (Maybe (Either BinP BinP) -> Gen b -> Gen b)
-> (BinP -> Maybe (Either BinP BinP)) -> BinP -> Gen b -> Gen b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinP -> Maybe (Either BinP BinP)
sp where
        sp :: BinP -> Maybe (Either BinP BinP)
        sp :: BinP -> Maybe (Either BinP BinP)
sp BinP
BE     = Maybe (Either BinP BinP)
forall a. Maybe a
Nothing
        sp (B0 BinP
b) = Either BinP BinP -> Maybe (Either BinP BinP)
forall a. a -> Maybe a
Just (BinP -> Either BinP BinP
forall a b. a -> Either a b
Left BinP
b)
        sp (B1 BinP
b) = Either BinP BinP -> Maybe (Either BinP BinP)
forall a. a -> Maybe a
Just (BinP -> Either BinP BinP
forall a b. b -> Either a b
Right BinP
b)

instance QC.Function BinP where
    function :: forall b. (BinP -> b) -> BinP :-> b
function = (BinP -> Maybe (Either BinP BinP))
-> (Maybe (Either BinP BinP) -> BinP) -> (BinP -> b) -> BinP :-> b
forall b a c.
Function b =>
(a -> b) -> (b -> a) -> (a -> c) -> a :-> c
QC.functionMap BinP -> Maybe (Either BinP BinP)
sp (BinP
-> (Either BinP BinP -> BinP) -> Maybe (Either BinP BinP) -> BinP
forall b a. b -> (a -> b) -> Maybe a -> b
maybe BinP
BE ((BinP -> BinP) -> (BinP -> BinP) -> Either BinP BinP -> BinP
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either BinP -> BinP
B0 BinP -> BinP
B1)) where
        sp :: BinP -> Maybe (Either BinP BinP)
        sp :: BinP -> Maybe (Either BinP BinP)
sp BinP
BE     = Maybe (Either BinP BinP)
forall a. Maybe a
Nothing
        sp (B0 BinP
b) = Either BinP BinP -> Maybe (Either BinP BinP)
forall a. a -> Maybe a
Just (BinP -> Either BinP BinP
forall a b. a -> Either a b
Left BinP
b)
        sp (B1 BinP
b) = Either BinP BinP -> Maybe (Either BinP BinP)
forall a. a -> Maybe a
Just (BinP -> Either BinP BinP
forall a b. b -> Either a b
Right BinP
b)

-------------------------------------------------------------------------------
-- Showing
-------------------------------------------------------------------------------

-- | 'show' displaying a structure of 'BinP'.
--
-- >>> explicitShow 11
-- "B1 (B1 (B0 BE))"
explicitShow :: BinP -> String
explicitShow :: BinP -> String
explicitShow BinP
n = Int -> BinP -> ShowS
explicitShowsPrec Int
0 BinP
n String
""

-- | 'showsPrec' displaying a structure of 'BinP'.
explicitShowsPrec :: Int -> BinP -> ShowS
explicitShowsPrec :: Int -> BinP -> ShowS
explicitShowsPrec Int
_ BinP
BE
    = String -> ShowS
showString String
"BE"
explicitShowsPrec Int
d (B0 BinP
n)
    = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10)
    (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"B0 "
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> BinP -> ShowS
explicitShowsPrec Int
11 BinP
n
explicitShowsPrec Int
d (B1 BinP
n)
    = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10)
    (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"B1 "
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> BinP -> ShowS
explicitShowsPrec Int
11 BinP
n

-------------------------------------------------------------------------------
-- Conversions
-------------------------------------------------------------------------------

-- | 'toNatural' for 'BinP'.
toNatural :: BinP -> Natural
toNatural :: BinP -> Natural
toNatural BinP
BE     = Natural
1
toNatural (B0 BinP
n) = Natural
2 Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* BinP -> Natural
toNatural BinP
n
toNatural (B1 BinP
n) = Natural
2 Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* BinP -> Natural
toNatural BinP
n Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1

-- | 'fromNatural' for 'BinP'.
--
-- Throws when given 0.
fromNatural :: Natural -> BinP
fromNatural :: Natural -> BinP
fromNatural Natural
0 = ArithException -> BinP
forall a e. Exception e => e -> a
throw ArithException
Underflow
fromNatural Natural
1 = BinP
BE
fromNatural Natural
n = case Natural
n Natural -> Natural -> (Natural, Natural)
forall a. Integral a => a -> a -> (a, a)
`divMod` Natural
2 of
    (Natural
m, Natural
0) -> BinP -> BinP
B0 (Natural -> BinP
fromNatural Natural
m)
    (Natural
m, Natural
_) -> BinP -> BinP
B1 (Natural -> BinP
fromNatural Natural
m)

-- | Fold 'BinP'.
cata
    :: a        -- ^ \(1\)
    -> (a -> a) -- ^ \(2x\)
    -> (a -> a) -- ^ \(2x + 1\)
    -> BinP
    -> a
cata :: forall a. a -> (a -> a) -> (a -> a) -> BinP -> a
cata a
z a -> a
o a -> a
i = BinP -> a
go where
    go :: BinP -> a
go BinP
BE     = a
z
    go (B0 BinP
b) = a -> a
o (BinP -> a
go BinP
b)
    go (B1 BinP
b) = a -> a
i (BinP -> a
go BinP
b)

-- | Convert from 'BinP' to 'Nat'.
toNat :: BinP -> Nat
toNat :: BinP -> Nat
toNat = Nat -> (Nat -> Nat) -> (Nat -> Nat) -> BinP -> Nat
forall a. a -> (a -> a) -> (a -> a) -> BinP -> a
cata (Nat -> Nat
S Nat
Z) Nat -> Nat
o Nat -> Nat
i where
    o :: Nat -> Nat
    o :: Nat -> Nat
o = Nat -> (Nat -> Nat) -> Nat -> Nat
forall a. a -> (a -> a) -> Nat -> a
N.cata Nat
Z (Nat -> Nat
S (Nat -> Nat) -> (Nat -> Nat) -> Nat -> Nat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Nat -> Nat
S)

    i :: Nat -> Nat
    i :: Nat -> Nat
i = Nat -> Nat
S (Nat -> Nat) -> (Nat -> Nat) -> Nat -> Nat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Nat -> Nat
o

-------------------------------------------------------------------------------
-- Aliases
-------------------------------------------------------------------------------

binP1, binP2, binP3, binP4, binP5, binP6, binP7, binP8, binP9 :: BinP
binP1 :: BinP
binP1 = BinP
BE
binP2 :: BinP
binP2 = BinP -> BinP
B0 BinP
BE
binP3 :: BinP
binP3 = BinP -> BinP
B1 BinP
BE
binP4 :: BinP
binP4 = BinP -> BinP
B0 BinP
binP2
binP5 :: BinP
binP5 = BinP -> BinP
B1 BinP
binP2
binP6 :: BinP
binP6 = BinP -> BinP
B0 BinP
binP3
binP7 :: BinP
binP7 = BinP -> BinP
B1 BinP
binP3
binP8 :: BinP
binP8 = BinP -> BinP
B0 BinP
binP4
binP9 :: BinP
binP9 = BinP -> BinP
B1 BinP
binP4