brush-strokes-0.1.0.0: src/lib/Math/Ring.hs

{-# LANGUAGE ScopedTypeVariables #-}

module Math.Ring
  ( AbelianGroup(..), Signed(..), Ring(..), Field(..)
  , Floating(..), Transcendental(..)

  , ViaPrelude(..), ViaAbelianGroup(..)

  , ifThenElse
  )
  where

-- base
import Prelude ( Num, Fractional )
import Prelude hiding ( Num(..), Fractional(..), Floating(..) )
import qualified Prelude
import Data.Coerce
  ( coerce )
import Data.Monoid
  ( Ap(..) )

-- groups
import Data.Group
  ( Group(invert) )

--------------------------------------------------------------------------------

infixl 6 +, -
infixl 7 *, /
infixr 8 ^

class AbelianGroup a where
  {-# MINIMAL (+), fromInteger, ( (-) | negate ) #-}

  (+) :: a -> a -> a
  (-) :: a -> a -> a
  negate :: a -> a
  fromInteger :: Integer -> a

  a - b = a + negate b
  negate b = fromInteger 0 - b

class AbelianGroup a => Signed a where
  abs    :: a -> a
  signum :: a -> a

class AbelianGroup a => Ring a where
  (*) :: a -> a -> a
  (^) :: a -> Word -> a
  (^) = defaultPow

class Ring a => Field a where
  {-# MINIMAL fromRational, ( recip | (/) ) #-}

  fromRational :: Rational -> a
  (/) :: a -> a -> a
  recip :: a -> a

  recip x = fromInteger 1 / x
  x / y = x * recip y

class Field a => Floating a where
  sqrt :: a -> a

class Floating a => Transcendental a where
  pi   :: a
  cos  :: a -> a
  sin  :: a -> a
  atan :: a -> a

--------------------------------------------------------------------------------

ifThenElse :: Bool -> a -> a -> a
ifThenElse b x y = if b then x else y

--------------------------------------------------------------------------------
-- A default power function, taken from base (GHC.Real).
--
-- DO NOT use with interval arithmetic!

{-# RULES
"defaultPow 2" forall x. defaultPow x 2 = x*x
"defaultPow 3" forall x. defaultPow x 3 = x*x*x
"defaultPow 4" forall x. defaultPow x 4 = let u = x*x in u*u
"defaultPow 5" forall x. defaultPow x 5 = let u = x*x in u*u*x
  #-}

{-# INLINE [1] defaultPow #-}
defaultPow :: Ring a => a -> Word -> a
defaultPow x0 y0
  | y0 < 0    = errorWithoutStackTrace "Negative exponent"
  | y0 == 0   = fromInteger 1
  | otherwise = powImpl x0 y0

powImpl :: Ring a => a -> Word -> a
-- powImpl : x0 ^ y0 = (x ^ y)
powImpl x y
  | even y    = powImpl (x * x) (y `quot` 2)
  | y == 1    = x
  | otherwise = powImplAcc (x * x) (y `quot` 2) x

{-# INLINABLE powImplAcc #-}
powImplAcc :: Ring a => a -> Word -> a -> a
-- powImplAcc : x0 ^ y0 = (x ^ y) * z
powImplAcc x y z
  | even y    = powImplAcc (x * x) (y `quot` 2) z
  | y == 1    = x * z
  | otherwise = powImplAcc (x * x) (y `quot` 2) (x * z)

--------------------------------------------------------------------------------

newtype ViaPrelude a = ViaPrelude { viaPrelude :: a }

instance Num a => AbelianGroup ( ViaPrelude a ) where
  (+) = coerce $ (Prelude.+) @a
  (-) = coerce $ (Prelude.-) @a
  fromInteger = coerce $ Prelude.fromInteger @a

instance Num a => Signed ( ViaPrelude a ) where
  abs    = coerce $ Prelude.abs    @a
  signum = coerce $ Prelude.signum @a

instance Num a => Ring ( ViaPrelude a ) where
  (*) = coerce $ (Prelude.*) @a
  (^) = coerce $ (Prelude.^) @a @Word

instance Fractional a => Field ( ViaPrelude a ) where
  fromRational = coerce $ Prelude.fromRational @a
  recip = coerce $ Prelude.recip @a
  (/) = coerce $ (Prelude./) @a

instance Prelude.Floating a => Floating ( ViaPrelude a ) where
  sqrt = coerce $ Prelude.sqrt @a

instance Prelude.Floating a => Transcendental ( ViaPrelude a ) where
  pi = coerce $ Prelude.pi @a
  sin = coerce $ Prelude.sin @a
  cos = coerce $ Prelude.cos @a
  atan = coerce $ Prelude.atan @a

--------------------------------------------------------------------------------

newtype ViaAbelianGroup a = ViaAbelianGroup { viaAbelianGroup :: a }

instance AbelianGroup a => Semigroup ( ViaAbelianGroup a ) where
  (<>) = coerce $ (+) @a
instance AbelianGroup a => Monoid    ( ViaAbelianGroup a ) where
  mempty = ViaAbelianGroup $ fromInteger 0
instance AbelianGroup a => Group     ( ViaAbelianGroup a ) where
  invert = coerce $ negate @a

--------------------------------------------------------------------------------

deriving via ViaPrelude Integer instance AbelianGroup   Integer
deriving via ViaPrelude Integer instance Ring           Integer
deriving via ViaPrelude Integer instance Signed         Integer

deriving via ViaPrelude Int     instance AbelianGroup   Int
deriving via ViaPrelude Int     instance Ring           Int
deriving via ViaPrelude Int     instance Signed         Int

deriving via ViaPrelude Word    instance AbelianGroup   Word
deriving via ViaPrelude Word    instance Ring           Word

deriving via ViaPrelude Float   instance AbelianGroup   Float
deriving via ViaPrelude Float   instance Ring           Float
deriving via ViaPrelude Float   instance Signed         Float
deriving via ViaPrelude Float   instance Field          Float
deriving via ViaPrelude Float   instance Floating       Float
deriving via ViaPrelude Float   instance Transcendental Float

deriving via ViaPrelude Double  instance AbelianGroup   Double
deriving via ViaPrelude Double  instance Ring           Double
deriving via ViaPrelude Double  instance Signed         Double
deriving via ViaPrelude Double  instance Field          Double
deriving via ViaPrelude Double  instance Floating       Double
deriving via ViaPrelude Double  instance Transcendental Double

--------------------------------------------------------------------------------

instance ( AbelianGroup r, Applicative f ) => AbelianGroup ( Ap f r ) where
  (+) = liftA2 $ (+) @r
  (-) = liftA2 $ (-) @r
  negate = fmap $ negate @r
  fromInteger = pure . fromInteger @r