{-# Language AllowAmbiguousTypes #-}
module Data.Connection.Round (
TripInt16(..)
, ceil16
, floor16
, trunc16
, round16
, TripInt32(..)
, ceil32
, floor32
, trunc32
, round32
, Mode(..)
, half
, tied
, above
, below
, addWith
, negWith
, subWith
, mulWith
, fmaWith
, remWith
, divWith
, divWith'
) where
import Data.Bool
import Data.Connection
import Data.Connection.Float
import Data.Connection.Ratio
import Data.Float
import Data.Int
import Data.Prd
import Data.Ratio
import Data.Semifield
import Data.Semilattice
import Data.Semilattice.Top
import Data.Semiring
import Prelude hiding (until, Ord(..), Num(..), Fractional(..), (^), Bounded)
import Test.Logic (xor)
class Prd a => TripInt16 a where
xxxi16 :: Trip a (Extended Int16)
ceil16 :: TripInt16 a => a -> a
ceil16 = unitl xxxi16
floor16 :: TripInt16 a => a -> a
floor16 = counitr xxxi16
trunc16 :: (Additive-Monoid) a => TripInt16 a => a -> a
trunc16 x = bool (ceil16 x) (floor16 x) $ x >= zero
round16 :: (Additive-Group) a => TripInt16 a => a -> a
round16 x | above xxxi16 x = ceil16 x
| below xxxi16 x = floor16 x
| otherwise = trunc16 x
class Prd a => TripInt32 a where
xxxi32 :: Trip a (Extended Int32)
ceil32 :: TripInt32 a => a -> a
ceil32 = unitl xxxi32
floor32 :: TripInt32 a => a -> a
floor32 = counitr xxxi32
trunc32 :: (Additive-Monoid) a => TripInt32 a => a -> a
trunc32 x = bool (ceil32 x) (floor32 x) $ x >= zero
round32 :: (Additive-Group) a => TripInt32 a => a -> a
round32 x | above xxxi32 x = ceil32 x
| below xxxi32 x = floor32 x
| otherwise = trunc32 x
data Mode =
RNZ
| RTP
| RTN
| RTZ
deriving (Eq, Show)
half :: Prd a => Prd b => (Additive-Group) a => Trip a b -> a -> Maybe Ordering
half t x = pcompare (x - unitl t x) (counitr t x - x)
above :: Prd a => Prd b => (Additive-Group) a => Trip a b -> a -> Bool
above t = maybe False (== GT) . half t
below :: Prd a => Prd b => (Additive-Group) a => Trip a b -> a -> Bool
below t = maybe False (== LT) . half t
tied :: Prd a => Prd b => (Additive-Group) a => Trip a b -> a -> Bool
tied t = maybe False (== EQ) . half t
addWith :: (Prd a, Prd b, (Additive-Group) a) => Trip a b -> Mode -> b -> b -> b
addWith t@(Trip _ f _) rm x y = rnd t rm (addSgn t rm x y) (f x + f y)
negWith :: (Prd a, Prd b, (Additive-Group) a) => Trip a b -> Mode -> b -> b
negWith t@(Trip _ f _) rm x = rnd t rm (neg' t rm x) (zero - f x)
subWith :: (Prd a, Prd b, (Additive-Group) a) => Trip a b -> Mode -> b -> b -> b
subWith t@(Trip _ f _) rm x y = rnd t rm (subSgn t rm x y) (f x - f y)
mulWith :: (Prd a, Prd b, Ring a) => Trip a b -> Mode -> b -> b -> b
mulWith t@(Trip _ f _) rm x y = rnd t rm (xorSgn t rm x y) (f x * f y)
fmaWith :: (Prd a, Prd b, Ring a) => Trip a b -> Mode -> b -> b -> b -> b
fmaWith t@(Trip _ f _) rm x y z = rnd t rm (fmaSgn t rm x y z) $ f x * f y + f z
remWith :: (Prd a, Prd b, Field a) => Trip a b -> Mode -> b -> b -> b
remWith t rm x y = fmaWith t rm (negWith t rm $ divWith t rm x y) y x
divWith :: (Prd a, Prd b, Field a) => Trip a b -> Mode -> b -> b -> b
divWith t@(Trip _ f _) rm x y = rnd t rm (xorSgn t rm x y) (f x / f y)
divWith' :: (Prd a, Prd b, Field a) => Trip a b -> Mode -> b -> b -> b
divWith' t@(Trip _ f _) rm x y | xorSgn t rm x y = rnd t rm True (negate $ f x / f y)
| otherwise = rnd t rm False (f x / f y)
truncateWith :: (Prd a, Prd b, (Additive-Monoid) a) => Trip a b -> a -> b
truncateWith t x = bool (ceilingWith t x) (floorWith t x) $ x >= zero
ceilingWith :: Prd a => Prd b => Trip a b -> a -> b
ceilingWith = connl . tripl
floorWith :: Prd a => Prd b => Trip a b -> a -> b
floorWith = connr . tripr
roundWith :: (Prd a, Prd b, (Additive-Group) a) => Trip a b -> a -> b
roundWith t x | above t x = ceilingWith t x
| below t x = floorWith t x
| otherwise = truncateWith t x
rsz :: (Prd a, Prd b) => Trip a b -> Bool -> a -> b
rsz t = bool (floorWith t) (ceilingWith t)
rnd :: (Prd a, Prd b, (Additive-Group) a) => Trip a b -> Mode -> Bool -> a -> b
rnd t RNZ s x = bool (roundWith t x) (rsz t s x) $ x =~ zero
rnd t RTP s x = bool (ceilingWith t x) (rsz t s x) $ x =~ zero
rnd t RTN s x = bool (floorWith t x) (rsz t s x) $ x =~ zero
rnd t RTZ s x = bool (truncateWith t x) (rsz t s x) $ x =~ zero
neg' :: (Prd a, Prd b, (Additive-Group) a) => Trip a b -> Mode -> b -> Bool
neg' t rm x = x < rnd t rm False zero
addSgn :: (Prd a, Prd b, (Additive-Group) a) => Trip a b -> Mode -> b -> b -> Bool
addSgn t rm x y | rm == RTN = neg' t rm x || neg' t rm y
| otherwise = neg' t rm x && neg' t rm y
subSgn :: (Prd a, Prd b, (Additive-Group) a) => Trip a b -> Mode -> b -> b -> Bool
subSgn t rm x y = not (addSgn t rm x y)
xorSgn :: (Prd a, Prd b, (Additive-Group) a) => Trip a b -> Mode -> b -> b -> Bool
xorSgn t rm x y = neg' t rm x `xor` neg' t rm y
fmaSgn :: (Prd a, Prd b, Ring a) => Trip a b -> Mode -> b -> b -> b -> Bool
fmaSgn t rm x y z = addSgn t rm (mulWith t rm x y) z
instance TripInt16 Float where
xxxi16 = f32i16
instance TripInt16 Double where
xxxi16 = f64i16
instance TripInt16 (Ratio Integer) where
xxxi16 = rati16
instance TripInt32 Double where
xxxi32 = f64i32
instance TripInt32 (Ratio Integer) where
xxxi32 = rati32