Positive.hs

{-# LANGUAGE ViewPatterns #-}

module Numeric.Rational.Positive (Qp, fromFraction, toFraction, fromRational, toRational) where

import Prelude hiding (Num (..), Fractional (..), Eq (..), Ord (..), Real (..))
import qualified Prelude

import Algebra
import Data.Bits
import Data.Bool
import Data.Function (on)
import Data.Ratio
import Data.Semigroup (Sum (..), Product (..))
import Data.Universe.Class
import Numeric.Natural
import Relation.Binary.Comparison

data Qp = Qp {-# UNPACK #-}!Word {-# UNPACK #-}!Natural
  deriving (Show)

fromBits :: [Bool] -> Qp
fromBits = go 0 0 where
    go :: Word -> Natural -> [Bool] -> Qp
    go k n = k `seq` n `seq` \ case
        [] -> Qp k n
        b:bs -> go (k+1) (bool id (flip setBit $ fromIntegral k) b n) bs

toBits :: Qp -> [Bool]
toBits (Qp l n) = testBit n <$> [0..fromIntegral l-1]

fromFraction :: (Natural, Natural) -> Qp
fromFraction = fromBits . uncurry go where
    go :: Natural -> Natural -> [Bool]
    go p q = case compare p q of
        EQ -> []
        GT -> False : go (p∸q) q
        LT -> True  : go p (q∸p)

toFraction :: Qp -> (Natural, Natural)
toFraction = go . toBits where
    go [] = (1, 1)
    go (b:bs) | (p, q) <- go bs = bool (p+q, q) (p, p+q) b

fromRational :: Ratio Natural -> Qp
fromRational a = fromFraction (numerator a, denominator a)

toRational :: Qp -> Ratio Natural
toRational = go . toBits where
    go [] = 1
    go (False:bs) = 1 + go bs
    go (True :bs) = Prelude.recip (1 + Prelude.recip (go bs))

instance Preord Qp where a ≤ b = GT ≢ compare a b
instance PartialEq Qp where Qp l₁ n₁ ≡ Qp l₂ n₂ = (l₁, n₁) ≡ (l₂, n₂)
instance PartialOrd Qp where tryCompare a b = Just (compare a b)
instance Eq Qp
instance Ord Qp where
    compare = go `on` toBits where
        go [] [] = EQ
        go (a:_) [] = bool GT LT a
        go [] (b:_) = bool LT GT b
        go (a:as) (b:bs) = compare b a <> go as bs

instance {-# OVERLAPPING #-} Semigroup (Product Qp) where
    Product (toFraction -> (p₁, q₁)) <> Product (toFraction -> (p₂, q₂)) =
      (Product . fromFraction) (p₁ * p₂, q₁ * q₂)

instance {-# OVERLAPPING #-} Monoid (Product Qp) where
    mempty = Product (Qp 0 0)

instance Group (Product Qp) where
    invert (Product (Qp l n)) = Product (Qp l (xor n $ shiftL 1 (fromIntegral l) ∸ 1))

instance {-# OVERLAPPING #-} Semigroup (Sum Qp) where
    Sum (toFraction -> (p₁, q₁)) <> Sum (toFraction -> (p₂, q₂)) =
        (Sum . fromFraction) (p₁ * q₂ + p₂ * q₁, q₁ * q₂)

instance Universe Qp where
    universe = fromBits <$> go where go = [] : (go >>= traverse (:) [False, True])

instance Prelude.Eq Qp where (==) = (≡)
instance Prelude.Ord Qp where compare = compare
instance Prelude.Num Qp where
    fromInteger = fromRational . Prelude.fromInteger
    (+) = (+)
    a * b = fromRational $ ((*) `on` toRational) a b
    abs = id
    signum = pure 1
    (-) = undefined