{-# LANGUAGE RebindableSyntax #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.YAP.Algebra
-- Copyright   :  (c) Ross Paterson 2011
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  R.Paterson@city.ac.uk
-- Stability   :  provisional
-- Portability :  portable
--
-- Classes corresponding to common structures from abstract algebra,
-- defined as superclasses of the Haskell 2010 numeric classes, yielding
-- the following class hierarchy (grey classes are unchanged):
--
-- <<images/hierarchy.svg>>
--
-----------------------------------------------------------------------------

module Data.YAP.Algebra (
    -- * Addition
    AdditiveMonoid(..),
    atimesIdempotent, timesCancelling,
    -- * Subtraction
    AbelianGroup(..),
    subtract,
    gtimesIdempotent,
    -- * Multiplication
    Semiring(..),
    Ring(..),
    StandardAssociate(..),
    -- * Division with remainder
    Euclidean(..),
    gcd, lcm, bezout, extendedEuclid,
    -- * Exact division
    DivisionSemiring(..),
    Semifield(..),
    DivisionRing,
    Field,
    -- * Embeddings
    -- | These classes define one-to-one embeddings.  In contrast,
    -- the functions 'fromNatural' and 'fromInteger' (in 'Semiring' and
    -- 'Ring' respectively) are not required to be one-to-one.
    FromRational(..),
    ToRational(..), ToInteger(..),
    -- * Differentiation and integration
    Differentiable(..), Integrable(..),
    -- * Mapping
    AdditiveFunctor(..),
  ) where

import Data.YAP.Algebra.Internal
import Prelude.YAP

-- | Faster implementation of 'atimes' when addition is idempotent.
atimesIdempotent :: (ToInteger b, AdditiveMonoid a) => b -> a -> a
atimesIdempotent :: forall b a. (ToInteger b, AdditiveMonoid a) => b -> a -> a
atimesIdempotent b
n a
x
  | b
n b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
forall a. AdditiveMonoid a => a
zero = a
forall a. AdditiveMonoid a => a
zero
  | Bool
otherwise = a
x

-- | Faster implementation of 'gtimes' when addition is idempotent.
gtimesIdempotent :: (ToInteger b, AbelianGroup a) => b -> a -> a
gtimesIdempotent :: forall b a. (ToInteger b, AbelianGroup a) => b -> a -> a
gtimesIdempotent b
n a
x = case b -> b -> Ordering
forall a. Ord a => a -> a -> Ordering
compare b
n b
forall a. AdditiveMonoid a => a
zero of
    Ordering
LT -> a -> a
forall a. AbelianGroup a => a -> a
negate a
x
    Ordering
EQ -> a
forall a. AdditiveMonoid a => a
zero
    Ordering
GT -> a
x

-- | Faster implementation of 'atimes' or 'gtimes' when @x+x = 'zero'@.
timesCancelling :: (ToInteger a, AdditiveMonoid b) => a -> b -> b
timesCancelling :: forall b a. (ToInteger b, AdditiveMonoid a) => b -> a -> a
timesCancelling a
n b
x
  | a -> Bool
forall a. ToInteger a => a -> Bool
odd a
n = b
x
  | Bool
otherwise = b
forall a. AdditiveMonoid a => a
zero

-- | @'bezout' x y = (a, b)@ such that @a*x + b*y = 'gcd' x y@
-- (Bézout's identity).
--
-- In particular, if @x@ and @y@ are coprime (i.e. @'gcd' x y == 'one'@),
--
-- * @b@ is the multiplicative inverse of @y@ modulo @x@.
--
-- * @a@ is the multiplicative inverse of @x@ modulo @y@.
--
-- * @j*a*x + i*b*y@ is equivalent to @i@ modulo @x@ and to @j@ modulo @y@
--   (Chinese Remainder Theorem).
bezout :: (Eq a, AbelianGroup a, StandardAssociate a, Euclidean a) =>
    a -> a -> (a, a)
bezout :: forall a.
(Eq a, AbelianGroup a, StandardAssociate a, Euclidean a) =>
a -> a -> (a, a)
bezout a
x a
y
  | a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. AdditiveMonoid a => a
zero = (a -> a
forall a. StandardAssociate a => a -> a
stdRecip a
x, a
forall a. AdditiveMonoid a => a
zero)
  | Bool
otherwise = case a -> a -> (a, a)
forall a.
(Eq a, AbelianGroup a, StandardAssociate a, Euclidean a) =>
a -> a -> (a, a)
bezout a
y a
r of (a
a, a
b) -> (a
b, a
a a -> a -> a
forall a. AbelianGroup a => a -> a -> a
- a
ba -> a -> a
forall a. Semiring a => a -> a -> a
*a
q)
  where
    (a
q, a
r) = a -> a -> (a, a)
forall a. Euclidean a => a -> a -> (a, a)
divMod a
x a
y

-- | The list of quadruples \((q_i, r_i, s_i, t_i)\) generated by the
-- extended Euclidean algorithm, which is a maximal list satisfying:
--
-- * \(r_{i-1} = q_i r_i + r_{i+1}\) with \(r_{i+1}\) smaller than \(r_i\),
--   where \(r_0 = a\) and \(r_1 = b\), and
--
-- * \(r_i = s_i a + t_i b\).
--
-- The last \(r_i\) in the list is a greatest common divisor of \(a\)
-- and \(b\), so that the second equation above becomes Bézout's identity.
extendedEuclid :: (Eq a, AbelianGroup a, StandardAssociate a, Euclidean a) =>
    a -> a -> [(a, a, a, a)]
extendedEuclid :: forall a.
(Eq a, AbelianGroup a, StandardAssociate a, Euclidean a) =>
a -> a -> [(a, a, a, a)]
extendedEuclid a
a a
b = a -> a -> a -> a -> a -> a -> [(a, a, a, a)]
forall a.
(Eq a, AbelianGroup a, StandardAssociate a, Euclidean a) =>
a -> a -> a -> a -> a -> a -> [(a, a, a, a)]
extendedEuclidAux a
a a
b a
forall a. Semiring a => a
one a
forall a. AdditiveMonoid a => a
zero a
forall a. AdditiveMonoid a => a
zero a
forall a. Semiring a => a
one

extendedEuclidAux ::
    (Eq a, AbelianGroup a, StandardAssociate a, Euclidean a) =>
    a -> a -> a -> a -> a -> a -> [(a, a, a, a)]
extendedEuclidAux :: forall a.
(Eq a, AbelianGroup a, StandardAssociate a, Euclidean a) =>
a -> a -> a -> a -> a -> a -> [(a, a, a, a)]
extendedEuclidAux a
r_prev a
r a
s_prev a
s a
t_prev a
t =
    (a
q, a
r, a
s, a
t) (a, a, a, a) -> [(a, a, a, a)] -> [(a, a, a, a)]
forall a. a -> [a] -> [a]
: if a
r_next a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. AdditiveMonoid a => a
zero then [] else
        a -> a -> a -> a -> a -> a -> [(a, a, a, a)]
forall a.
(Eq a, AbelianGroup a, StandardAssociate a, Euclidean a) =>
a -> a -> a -> a -> a -> a -> [(a, a, a, a)]
extendedEuclidAux a
r a
r_next a
s a
s_next a
t a
t_next
  where
    (a
q, a
r_next) = a -> a -> (a, a)
forall a. Euclidean a => a -> a -> (a, a)
divMod a
r_prev a
r
    s_next :: a
s_next = a
s_prev a -> a -> a
forall a. AbelianGroup a => a -> a -> a
- a
qa -> a -> a
forall a. Semiring a => a -> a -> a
*a
s
    t_next :: a
t_next = a
t_prev a -> a -> a
forall a. AbelianGroup a => a -> a -> a
- a
qa -> a -> a
forall a. Semiring a => a -> a -> a
*a
t

-- | A differential semiring
class (Semiring a) => Differentiable a where
    -- | A monoid homomorphism that satisfies
    --
    -- * @'derivative' 'one' = 'zero'@
    --
    -- * @'derivative' (a * b) = a*'derivative' b + 'derivative' a*b@
    --
    derivative :: a -> a

-- | A differential semiring with anti-differentiation
class (Differentiable a) => Integrable a where
    -- | A monoid homomorphism that is a pre-inverse of 'derivative', i.e.
    --
    -- * @'derivative' ('integral' a) = a@
    --
    integral :: a -> a

-- | A functor on additive monoids
class AdditiveFunctor f where
    -- | Map with a function that preserves 'zero' and '(+)'.
    mapAdditive :: (AdditiveMonoid a, AdditiveMonoid b) =>
        (a -> b) -> f a -> f b