{-# 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 n x
  | n == zero = zero
  | otherwise = x

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

-- | Faster implementation of 'atimes' or 'gtimes' when @x+x = 'zero'@.
timesCancelling :: (ToInteger a, AdditiveMonoid b) => a -> b -> b
timesCancelling n x
  | odd n = x
  | otherwise = 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 x y
  | y == zero = (stdRecip x, zero)
  | otherwise = case bezout y r of (a, b) -> (b, a - b*q)
  where
    (q, r) = divMod x 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 a b = extendedEuclidAux a b one zero zero one

extendedEuclidAux ::
    (Eq a, AbelianGroup a, StandardAssociate a, Euclidean a) =>
    a -> a -> a -> a -> a -> a -> [(a, a, a, a)]
extendedEuclidAux r_prev r s_prev s t_prev t =
    (q, r, s, t) : if r_next == zero then [] else
        extendedEuclidAux r r_next s s_next t t_next
  where
    (q, r_next) = divMod r_prev r
    s_next = s_prev - q*s
    t_next = t_prev - q*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