{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude, TemplateHaskell, TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | This module provides drop-in replacement for @'Prelude'@ module in base package,
-- based on algebraic hierarchy provided by
-- <https://hackage.haskell.org/package/algebra algebra> package.
-- You can use this module with @NoImplicitPrelude@ language option.
--
-- This module implicitly exports following modules:
--
-- * "Numeric.Algebra" module, except
--
-- * @'NA.fromInteger'@:
-- this module exports Prelude's @'fromInteger'@ to make number literals
-- work properly.
-- For @'NA.fromInteger'@ from @algebra@ package, use @'fromInteger''@.
--
-- * @('NA.^')@ is renamed to @('^^')@, and @('^')@ is redefined as @'NA.pow'@.
--
-- * The module "Numeric.Algebra.Unital.UnitNormalForm", except for @'NA.normalize'@;
-- hence its name is too general, we export it as @'normaliseUnit'@.
--
-- * Following modules are exported as-is:
--
-- * "Numeric.Decidable.Associates"
-- * "Numeric.Decidable.Units"
-- * "Numeric.Decidable.Zero"
-- * "Numeric.Domain.Class"
-- * "Numeric.Domain.Euclidean"
-- * "Numeric.Domain.GCD"
-- * "Numeric.Domain.Integral"
-- * "Numeric.Domain.PID"
-- * "Numeric.Domain.UFD"
-- * "Numeric.Field.Fraction"
-- * "Numeric.Semiring.ZeroProduct"
--
-- * Non-numeric part of this module is almost same as "BasicPrelude".
-- But the following combinators are not generalized from "Prelude":
--
-- * @'String'@-specific functions: @'getArgs'@, @'getContents'@,
-- @'getLine'@, @'interact'@, @'putStr'@, @'putStrLn'@,
-- @'read'@, @'readFile'@, @'writeFile'@, @'lines'@, @'unlines'@,
-- @'words'@ and @'unwords'@.
--
-- * @('.')@ is just a function composition; not a Categorical composition.
module AlgebraicPrelude
(module AlgebraicPrelude,
-- * Old Prelude's Numeric type classes and functions, without confliction
P.Num(abs,signum),P.Integral(),P.toInteger, P.Real(..), P.Fractional (),
P.Floating(..), P.RealFrac(..), P.RealFloat(..),
) where
import BasicPrelude as AlgebraicPrelude hiding
(Floating (..),
Fractional (..),
Integral (..),
Num (..),
Rational,
Real (..),
RealFloat (..),
RealFrac (..),
fromShow,
gcd,
getArgs,
getContents,
getLine,
id,
interact,
lcm,
lines,
product,
putStr,
putStrLn,
read,
readFile,
show,
subtract,
sum,
unlines,
unwords,
words,
writeFile,
(.),
(\\),
(^),
(^^))
import qualified Control.Lens.TH as L
import qualified Data.Ratio as P
import qualified Data.Semigroup as Semi
import Numeric.Algebra as AlgebraicPrelude hiding
(Order (..),
fromInteger,
(^))
import qualified Numeric.Algebra as NA
import Numeric.Algebra.Unital.UnitNormalForm as AlgebraicPrelude hiding
(normalize)
import qualified Numeric.Algebra.Unital.UnitNormalForm as NA
import Numeric.Decidable.Associates as AlgebraicPrelude
import Numeric.Decidable.Units as AlgebraicPrelude
import Numeric.Decidable.Zero as AlgebraicPrelude
import Numeric.Domain.Class as AlgebraicPrelude
import Numeric.Domain.Euclidean as AlgebraicPrelude
import Numeric.Domain.GCD as AlgebraicPrelude
import Numeric.Domain.Integral as AlgebraicPrelude
import Numeric.Domain.PID as AlgebraicPrelude
import Numeric.Domain.UFD as AlgebraicPrelude
import Numeric.Field.Fraction as AlgebraicPrelude
import Numeric.Semiring.ZeroProduct as AlgebraicPrelude
import Prelude as AlgebraicPrelude (Show (..),
ceiling,
div,
floor,
getContents,
getLine,
id,
interact,
lines,
mod,
putStr,
putStrLn,
readFile,
show,
unlines,
unwords,
words,
writeFile,
(.))
import qualified Prelude as P
-- * Basic types and renamed operations
-- | We use @'Fraction'@ instead of @'Ratio'@ for consistency.
type Rational = Fraction Integer
infixr 8 ^, ^^
-- | To work with Num literals.
fromInteger :: P.Num r => Integer -> r
fromInteger = P.fromInteger
{-# INLINE [1] fromInteger #-}
{-# RULES
"fromInteger/Integer"
fromInteger = id
#-}
-- | @algebra@ package's original @'NA.fromInteger'@.
fromInteger' :: Ring r => Integer -> r
fromInteger' = NA.fromInteger
fromRational :: DivisionRing r => P.Rational -> r
fromRational r = NA.fromInteger (P.numerator r) / NA.fromInteger (P.denominator r)
{-# INLINE [1] fromRational #-}
{-# RULES
"fromRational/Rational" [~1]
fromRational = id
#-}
normaliseUnit :: UnitNormalForm r => r -> r
normaliseUnit = NA.normalize
-- | Specialised version of @'pow'@ which takes @'Natural'@s as a power.
(^) :: Unital r => r -> Natural -> r
(^) = pow
-- | The original power function @('NA.^')@ of @algebra@
(^^) :: Division r => r -> Integer -> r
(^^) = (NA.^)
{-# RULES
"negate/Ring" forall (x :: Ring a => a).
P.negate x = NA.negate x
"minus/Ring" forall (x :: Ring a => a) y.
x P.- y = x NA.- y
#-}
-- * Combinator to use with @RebindableSyntax@ extensions.
ifThenElse :: Bool -> a -> a -> a
ifThenElse p t f = if p then t else f
-- * Wrapper types for conversion between @'Num'@ family
-- and algebraic hierarchy provided by @algebra@.
-- | Wrapping Prelude's numerical types to treat with
-- @'Numeric.Algebra'@ hierachy.
--
-- For @'Field'@ or @'Euclidean'@ instances, see @'WrapIntegral'@ and @'WrapField'@.
--
-- __N.B.__ This type provides a mean to convert from @'Num'@s
-- to @'Ring'@s, but there is no guarantee that
-- @'WrapNum' a@ is actually ring.
-- For example, due to precision limitation,
-- @'WrapPreldue' 'Double'@ even fails to be semigroup!
-- For another simpler example, even though @'Natural'@ comes
-- with @'Num'@ instance, but it doesn't support @'negate'@,
-- so it cannot be @'Group'@.
newtype WrapNum a = WrapNum { unwrapNum :: a }
deriving (Read, Show, Eq, Ord)
instance (P.Num a) => Additive (WrapNum a) where
WrapNum a + WrapNum b = WrapNum (a P.+ b)
{-# INLINE (+) #-}
sinnum1p n (WrapNum a) = WrapNum ((1 P.+ fromIntegral n) P.* a)
{-# INLINE sinnum1p #-}
instance (P.Num a) => LeftModule Natural (WrapNum a) where
n .* WrapNum r = WrapNum (P.fromIntegral n P.* r)
{-# INLINE (.*) #-}
instance (P.Num a) => RightModule Natural (WrapNum a) where
WrapNum r *. n = WrapNum (r P.* P.fromIntegral n)
{-# INLINE (*.) #-}
instance (P.Num a) => Monoidal (WrapNum a) where
zero = WrapNum (P.fromInteger 0)
{-# INLINE zero #-}
sinnum n (WrapNum a) = WrapNum ((fromIntegral n) P.* a)
{-# INLINE sinnum #-}
instance (P.Num a) => LeftModule Integer (WrapNum a) where
n .* WrapNum r = WrapNum (P.fromIntegral n P.* r)
{-# INLINE (.*) #-}
instance (P.Num a) => RightModule Integer (WrapNum a) where
WrapNum r *. n = WrapNum (r P.* P.fromIntegral n)
{-# INLINE (*.) #-}
instance (P.Num a) => Group (WrapNum a) where
negate (WrapNum a) = WrapNum $ P.negate a
{-# INLINE negate #-}
WrapNum a - WrapNum b = WrapNum (a P.- b)
{-# INLINE (-) #-}
subtract (WrapNum a) (WrapNum b) = WrapNum (P.subtract a b)
{-# INLINE subtract #-}
times n (WrapNum a) = WrapNum $ fromIntegral n P.* a
{-# INLINE times #-}
instance (P.Num a) => Multiplicative (WrapNum a) where
WrapNum p * WrapNum q = WrapNum (p P.* q)
{-# INLINE (*) #-}
pow1p (WrapNum p) n = WrapNum (p P.^ (n + 1))
{-# INLINE pow1p #-}
instance (P.Num a) => Unital (WrapNum a) where
one = WrapNum $ P.fromInteger 1
{-# INLINE one #-}
pow (WrapNum a) n = WrapNum $ a P.^ n
{-# INLINE pow #-}
instance P.Num a => Abelian (WrapNum a)
instance P.Num a => Semiring (WrapNum a)
instance P.Num a => Rig (WrapNum a) where
fromNatural = WrapNum . P.fromIntegral
{-# INLINE fromNatural #-}
instance P.Num a => Ring (WrapNum a) where
fromInteger = WrapNum . P.fromInteger
{-# INLINE fromInteger #-}
instance P.Num a => Commutative (WrapNum a)
instance (P.Num a, Eq a) => DecidableZero (WrapNum a) where
isZero (WrapNum a) = a == 0
{-# INLINE isZero #-}
-- | Similar to @'WrapNum'@, but produces @'Field'@ instances from
-- @'Fractional'@s.
--
-- See also: @'WrapIntegral'@ and @'WrapNum'@.
newtype WrapFractional a = WrapFractional { unwrapFractional :: a }
instance (P.Num a) => Additive (WrapFractional a) where
WrapFractional a + WrapFractional b = WrapFractional (a P.+ b)
{-# INLINE (+) #-}
sinnum1p n (WrapFractional a) = WrapFractional ((1 P.+ fromIntegral n) P.* a)
{-# INLINE sinnum1p #-}
instance (P.Num a) => LeftModule Natural (WrapFractional a) where
n .* WrapFractional r = WrapFractional (P.fromIntegral n P.* r)
{-# INLINE (.*) #-}
instance (P.Num a) => RightModule Natural (WrapFractional a) where
WrapFractional r *. n = WrapFractional (r P.* P.fromIntegral n)
{-# INLINE (*.) #-}
instance (P.Num a) => Monoidal (WrapFractional a) where
zero = WrapFractional (P.fromInteger 0)
{-# INLINE zero #-}
sinnum n (WrapFractional a) = WrapFractional ((fromIntegral n) P.* a)
{-# INLINE sinnum #-}
instance (P.Num a) => LeftModule Integer (WrapFractional a) where
n .* WrapFractional r = WrapFractional (P.fromIntegral n P.* r)
{-# INLINE (.*) #-}
instance (P.Num a) => RightModule Integer (WrapFractional a) where
WrapFractional r *. n = WrapFractional (r P.* P.fromIntegral n)
{-# INLINE (*.) #-}
instance (P.Num a) => Group (WrapFractional a) where
negate (WrapFractional a) = WrapFractional $ P.negate a
{-# INLINE negate #-}
WrapFractional a - WrapFractional b = WrapFractional (a P.- b)
{-# INLINE (-) #-}
subtract (WrapFractional a) (WrapFractional b) = WrapFractional (P.subtract a b)
{-# INLINE subtract #-}
times n (WrapFractional a) = WrapFractional $ fromIntegral n P.* a
{-# INLINE times #-}
instance (P.Num a) => Multiplicative (WrapFractional a) where
WrapFractional p * WrapFractional q = WrapFractional (p P.* q)
{-# INLINE (*) #-}
pow1p (WrapFractional p) n = WrapFractional (p P.^ (n + 1))
{-# INLINE pow1p #-}
instance (P.Num a) => Unital (WrapFractional a) where
one = WrapFractional $ P.fromInteger 1
{-# INLINE one #-}
pow (WrapFractional a) n = WrapFractional $ a P.^ n
{-# INLINE pow #-}
instance P.Num a => Abelian (WrapFractional a)
instance P.Num a => Semiring (WrapFractional a)
instance P.Num a => Rig (WrapFractional a) where
fromNatural = WrapFractional . P.fromIntegral
{-# INLINE fromNatural #-}
instance P.Num a => Ring (WrapFractional a) where
fromInteger = WrapFractional . P.fromInteger
{-# INLINE fromInteger #-}
instance P.Num a => Commutative (WrapFractional a)
instance (P.Num a, Eq a) => DecidableZero (WrapFractional a) where
isZero (WrapFractional a) = a == 0
{-# INLINE isZero #-}
instance P.Fractional a => Division (WrapFractional a) where
recip = WrapFractional . P.recip . unwrapFractional
{-# INLINE recip #-}
WrapFractional a / WrapFractional b = WrapFractional $ a P./ b
{-# INLINE (/) #-}
WrapFractional a \\ WrapFractional b = WrapFractional $ P.recip a P.* b
{-# INLINE (\\) #-}
WrapFractional a ^ n = WrapFractional (a P.^^ n)
{-# INLINE (^) #-}
instance (Eq a, P.Fractional a) => ZeroProductSemiring (WrapFractional a)
instance (Eq a, P.Fractional a) => DecidableUnits (WrapFractional a) where
isUnit (WrapFractional r) = r /= 0
{-# INLINE isUnit #-}
recipUnit (WrapFractional r) =
if r == 0
then Nothing
else Just (WrapFractional $ P.recip r)
{-# INLINE recipUnit #-}
instance (Eq a, P.Fractional a) => DecidableAssociates (WrapFractional a) where
isAssociate (WrapFractional a) (WrapFractional b) =
(a == 0 && b == 0) || (a /= 0 && b /= 0)
{-# INLINE isAssociate #-}
instance (Eq a, P.Fractional a) => UnitNormalForm (WrapFractional a)
instance (Eq a, P.Fractional a) => IntegralDomain (WrapFractional a)
instance (Eq a, P.Fractional a) => GCDDomain (WrapFractional a)
instance (Eq a, P.Fractional a) => Euclidean (WrapFractional a)
instance (Eq a, P.Fractional a) => PID (WrapFractional a)
instance (Eq a, P.Fractional a) => UFD (WrapFractional a)
-- | Similar to @'WrapNum'@, but produces @'Euclidean'@ instances from
-- @'Integral'@s.
--
-- See also: @'WrapFractional'@ and @'WrapNum'@.
newtype WrapIntegral a = WrapIntegral { unwrapIntegral :: a }
instance (P.Num a) => Additive (WrapIntegral a) where
WrapIntegral a + WrapIntegral b = WrapIntegral (a P.+ b)
{-# INLINE (+) #-}
sinnum1p n (WrapIntegral a) = WrapIntegral ((1 P.+ fromIntegral n) P.* a)
{-# INLINE sinnum1p #-}
instance (P.Num a) => LeftModule Natural (WrapIntegral a) where
n .* WrapIntegral r = WrapIntegral (P.fromIntegral n P.* r)
{-# INLINE (.*) #-}
instance (P.Num a) => RightModule Natural (WrapIntegral a) where
WrapIntegral r *. n = WrapIntegral (r P.* P.fromIntegral n)
{-# INLINE (*.) #-}
instance (P.Num a) => Monoidal (WrapIntegral a) where
zero = WrapIntegral (P.fromInteger 0)
{-# INLINE zero #-}
sinnum n (WrapIntegral a) = WrapIntegral ((fromIntegral n) P.* a)
{-# INLINE sinnum #-}
instance (P.Num a) => LeftModule Integer (WrapIntegral a) where
n .* WrapIntegral r = WrapIntegral (P.fromIntegral n P.* r)
{-# INLINE (.*) #-}
instance (P.Num a) => RightModule Integer (WrapIntegral a) where
WrapIntegral r *. n = WrapIntegral (r P.* P.fromIntegral n)
{-# INLINE (*.) #-}
instance (P.Num a) => Group (WrapIntegral a) where
negate (WrapIntegral a) = WrapIntegral $ P.negate a
{-# INLINE negate #-}
WrapIntegral a - WrapIntegral b = WrapIntegral (a P.- b)
{-# INLINE (-) #-}
subtract (WrapIntegral a) (WrapIntegral b) = WrapIntegral (P.subtract a b)
{-# INLINE subtract #-}
times n (WrapIntegral a) = WrapIntegral $ fromIntegral n P.* a
{-# INLINE times #-}
instance (P.Num a) => Multiplicative (WrapIntegral a) where
WrapIntegral p * WrapIntegral q = WrapIntegral (p P.* q)
{-# INLINE (*) #-}
pow1p (WrapIntegral p) n = WrapIntegral (p P.^ (n + 1))
{-# INLINE pow1p #-}
instance (P.Num a) => Unital (WrapIntegral a) where
one = WrapIntegral $ P.fromInteger 1
{-# INLINE one #-}
pow (WrapIntegral a) n = WrapIntegral $ a P.^ n
{-# INLINE pow #-}
instance P.Num a => Abelian (WrapIntegral a)
instance P.Num a => Semiring (WrapIntegral a)
instance P.Num a => Rig (WrapIntegral a) where
fromNatural = WrapIntegral . P.fromIntegral
{-# INLINE fromNatural #-}
instance P.Num a => Ring (WrapIntegral a) where
fromInteger = WrapIntegral . P.fromInteger
{-# INLINE fromInteger #-}
instance P.Num a => Commutative (WrapIntegral a)
instance (P.Num a, Eq a) => DecidableZero (WrapIntegral a) where
isZero (WrapIntegral a) = a == 0
{-# INLINE isZero #-}
instance (Eq a, P.Integral a) => ZeroProductSemiring (WrapIntegral a)
instance (Eq a, P.Integral a) => DecidableUnits (WrapIntegral a) where
isUnit (WrapIntegral r) = r == 1 || r == P.negate 1
{-# INLINE isUnit #-}
recipUnit (WrapIntegral r) =
if isUnit (WrapIntegral r)
then Nothing
else Just (WrapIntegral r)
{-# INLINE recipUnit #-}
instance (Eq a, P.Integral a) => DecidableAssociates (WrapIntegral a) where
isAssociate (WrapIntegral a) (WrapIntegral b) = P.abs a == P.abs b
{-# INLINE isAssociate #-}
instance (Eq a, P.Integral a) => UnitNormalForm (WrapIntegral a) where
splitUnit (WrapIntegral 0) = (WrapIntegral 1, WrapIntegral 0)
splitUnit (WrapIntegral a) = (WrapIntegral $ P.signum a, WrapIntegral $ P.abs a)
{-# INLINE splitUnit #-}
instance (Eq a, P.Integral a) => IntegralDomain (WrapIntegral a)
instance (Eq a, P.Integral a) => GCDDomain (WrapIntegral a) where
gcd (WrapIntegral a) (WrapIntegral b) = WrapIntegral (P.gcd a b)
{-# INLINE gcd #-}
lcm (WrapIntegral a) (WrapIntegral b) = WrapIntegral (P.lcm a b)
{-# INLINE lcm #-}
instance (Eq a, P.Integral a) => Euclidean (WrapIntegral a) where
divide (WrapIntegral f) (WrapIntegral g) =
let (q, r) = P.divMod f g
in (WrapIntegral q, WrapIntegral r)
{-# INLINE divide #-}
degree (WrapIntegral 0) = Nothing
degree (WrapIntegral a) = Just $ P.fromIntegral (P.abs a)
{-# INLINE degree #-}
quot (WrapIntegral a) (WrapIntegral b) = WrapIntegral $ P.div a b
{-# INLINE quot #-}
rem (WrapIntegral a) (WrapIntegral b) = WrapIntegral $ P.mod a b
{-# INLINE rem #-}
instance (Eq a, P.Integral a) => PID (WrapIntegral a)
instance (Eq a, P.Integral a) => UFD (WrapIntegral a)
-- | Turning types from @'Numeric.Algebra'@ into Prelude's Num instances.
--
-- N.B. Since @'Real'@'s @'toRational'@ constraint is too tight,
-- we won't provide the inverse of @'WrapIntegral'@ and
-- provide @'Fractional'@ instance only.
newtype WrapAlgebra a = WrapAlgebra { unwrapAlgebra :: a }
deriving (Read, Show, Eq, Ord)
instance (Ring a, UnitNormalForm a) => P.Num (WrapAlgebra a) where
WrapAlgebra a + WrapAlgebra b = WrapAlgebra $ a NA.+ b
{-# INLINE (+) #-}
WrapAlgebra a - WrapAlgebra b = WrapAlgebra $ a NA.- b
{-# INLINE (-) #-}
WrapAlgebra a * WrapAlgebra b = WrapAlgebra $ a NA.* b
{-# INLINE (*) #-}
fromInteger = WrapAlgebra . NA.fromInteger
{-# INLINE fromInteger #-}
signum = WrapAlgebra . leadingUnit . unwrapAlgebra
{-# INLINE signum #-}
abs = WrapAlgebra . normaliseUnit . unwrapAlgebra
{-# INLINE abs #-}
negate = WrapAlgebra . negate . unwrapAlgebra
{-# INLINE negate #-}
instance (DivisionRing a, UnitNormalForm a) => P.Fractional (WrapAlgebra a) where
WrapAlgebra a / WrapAlgebra b = WrapAlgebra (a / b)
{-# INLINE (/) #-}
recip (WrapAlgebra a) = WrapAlgebra (recip a)
{-# INLINE recip #-}
fromRational = WrapAlgebra . fromRational
{-# INLINE fromRational #-}
instance Euclidean a => P.Num (Fraction a) where
{-# SPECIALISE instance P.Num (Fraction Integer) #-}
(+) = (NA.+)
(-) = (NA.-)
negate = NA.negate
(*) = (NA.*)
fromInteger = NA.fromInteger
abs = normaliseUnit
signum = leadingUnit
instance Euclidean d => P.Fractional (Fraction d) where
{-# SPECIALISE instance P.Fractional (Fraction Integer) #-}
fromRational r = fromInteger' (P.numerator r) % fromInteger' (P.denominator r)
recip = NA.recip
(/) = (NA./)
-- | @'Monoid'@ instances for @'Additive'@s.
-- N.B. Unlike @'WrapNum'@, @'P.Num'@ instance is
-- just inhereted from the unwrapped data.
newtype Add a = Add { runAdd :: a }
deriving (Read, Show, Eq, Ord, P.Num)
instance Additive a => Semi.Semigroup (Add a) where
Add a <> Add b = Add (a NA.+ b)
{-# INLINE (<>) #-}
sconcat = Add . sum1 . map runAdd
{-# INLINE sconcat #-}
stimes n = Add . sinnum1p (P.fromIntegral n P.- 1) . runAdd
{-# INLINE stimes #-}
instance Monoidal a => Monoid (Add a) where
mappend = (Semi.<>)
{-# INLINE mappend #-}
mempty = Add zero
{-# INLINE mempty #-}
mconcat = Add . sum . map runAdd
{-# INLINE mconcat #-}
-- | @'Monoid'@ instances for @'Additive'@s.
-- N.B. Unlike @'WrapNum'@, @'P.Num'@ instance is
-- just inhereted from the unwrapped data.
newtype Mult a = Mult { runMult :: a }
deriving (Read, Show, Eq, Ord, P.Num)
instance Multiplicative a => Semi.Semigroup (Mult a) where
Mult a <> Mult b = Mult (a NA.* b)
{-# INLINE (<>) #-}
sconcat = Mult . product1 . map runMult
{-# INLINE sconcat #-}
stimes n = Mult . flip pow1p (P.fromIntegral n P.- 1) . runMult
{-# INLINE stimes #-}
instance Unital a => Monoid (Mult a) where
mappend = (Semi.<>)
{-# INLINE mappend #-}
mempty = Mult one
{-# INLINE mempty #-}
mconcat = Mult . product . map runMult
{-# INLINE mconcat #-}
L.makeWrapped ''WrapNum
L.makeWrapped ''WrapIntegral
L.makeWrapped ''WrapFractional
L.makeWrapped ''WrapAlgebra
L.makeWrapped ''Add
L.makeWrapped ''Mult