module Text.PercentFormat.Quotient
( Quotient
, (%)
, infinity
, nan
, isInfinite
, isNaN
, readQ
, maybeReadQ
, digits
, fracDigits
)
where
import Prelude hiding (isInfinite, isNaN)
import Data.Char (isDigit)
import Data.Maybe (fromMaybe)
import Data.List (findIndex)
import qualified Data.Ratio as R
import Text.PercentFormat.Utils
data Quotient = Integer :% Integer
infixl 7 :%
instance Eq Quotient where
(0 :% 0) == _ = False
_ == (0 :% 0) = False
(x :% y) == (x' :% y') = (x * y') == (x' * y)
instance Ord Quotient where
(0 :% 0) `compare` _ = GT
_ `compare` (0 :% 0) = GT
(x :% y) `compare` (x' :% y') = (x * y') `compare` (x' * y)
instance Show Quotient where
showsPrec d (0 :% 0) = showString "NaN"
showsPrec d (x :% 0) | x < 0 = showParen (d > 6) $ showString "-Infinity"
| otherwise = showString "Infinity"
showsPrec d (x :% y) = showParen (d > 7)
$ showsPrec 7 x . showString " % " . showsPrec 7 y
(%) :: Integer -> Integer -> Quotient
0 % 0 = 0 :% 0
x % 0 = signum x :% 0
x % y = (x * signum y `quot` d) :% (abs y `quot` d)
where
d = gcd x y
infixl 7 %
infinity :: Quotient
infinity = 1 % 0
nan :: Quotient
nan = 0 % 0
isInfinite :: Quotient -> Bool
isInfinite q = q == infinity || q == (-infinity)
isNaN :: Quotient -> Bool
isNaN q = q /= q
instance Num Quotient where
negate (x :% y) = negate x % y
(x :% y) + (x' :% y') = (x * y' + x' * y) % (y * y')
(x :% y) * (x' :% y') = (x * x') % (y * y')
abs (x :% y) = abs x % abs y
signum (x :% y) = signum x * signum y % 1
fromInteger = (% 1)
instance Fractional Quotient where
recip (x :% y) = y % x
fromRational q = R.numerator q % R.denominator q
instance Real Quotient where
toRational (x :% y) = x R.% y
instance RealFrac Quotient where
properFraction (x :% y) = (fromInteger q, r % y)
where (q,r) = quotRem x y
maybeReadQ :: String -> Maybe Quotient
maybeReadQ "Infinity" = Just infinity
maybeReadQ "NaN" = Just nan
maybeReadQ "inf" = Just infinity
maybeReadQ "nan" = Just nan
maybeReadQ ('-':s) = negate <$> maybeReadQ s
where
f <$> Nothing = Nothing
f <$> (Just x) = Just (f x)
maybeReadQ ('(':s) = case span (/= ')') s of
(s',')':s'') -> maybeReadQ (s' ++ s'')
_ -> Nothing
maybeReadQ (d:s) | not (isDigit d) = Nothing
maybeReadQ etc = Just $
case span isDigit etc of
("",_) -> error "readQ: the impossible happened"
(i,'.':etc) -> case span isDigit etc of
(j,'e':'-':e:tc) | isDigit e ->
read (i++j) % 10 ^ (length j + read (e:takeWhile isDigit tc))
(j,'e':e:tc) | isDigit e ->
read (i++j) * 10 ^ (read (e:takeWhile isDigit tc)) % 10 ^ length j
(j,etc) -> read (i++j) % 10 ^ length j
(i,'%':e:tc) | isDigit e -> case span isDigit (e:tc) of
(j,etc) -> read i % read j
(i,' ':'%':' ':e:tc) | isDigit e -> case span isDigit (e:tc) of
(j,etc) -> read i % read j
(i,etc) -> read i % 1
readQ :: String -> Quotient
readQ = fromMaybe (error "No number to read") . maybeReadQ
digits :: Int -> Quotient -> Either String ([Int],[Int],[Int])
digits b (0 :% 0) = Left "NaN"
digits b (n :% 0) = Left "Infinity"
digits b q = Right (ids,fds,pds)
where
(i,q') = properFraction q
(fds,pds) = fracDigits b q'
ids = case integerToDigits b i of
[] -> [0]
ds -> ds
fracDigits :: Int -> Quotient -> ([Int],[Int])
fracDigits b q | q < 0 = fracDigits b (abs q)
fracDigits b q | q >= 1 = fracDigits b (snd $ properFraction q)
fracDigits b q = let (fds,psz) = fun [] q
fsz = length fds - psz
in splitAt fsz fds
where
fun :: [(Integer,Integer)] -> Quotient -> ([Int],Int)
fun hist (0 :% _) = ([],0)
fun hist (x :% y) = case findIndex (==(x,y)) hist of
Nothing -> (fromInteger q:fds,psz)
Just i -> ([],i+1)
where
(q,r) = (x * toInteger b) `quotRem` y
(fds,psz) = fun ((x,y):hist) (r % y)