```{-# LANGUAGE RebindableSyntax #-}

module Data.YAP.Algebra.Internal (
module Data.YAP.Algebra.Internal,
Ratio(..)
) where

import Prelude hiding (
(+), (-), negate, (*), fromInteger,
div, mod, divMod, (/), recip,
subtract, gcd, lcm)
import qualified Prelude
import GHC.Real (Ratio(..))

infixl 7  *, /, `div`, `mod`
infixl 6  +, -

infixl 7  %

-- | An Abelian group has an commutative associative binary operation
-- with an identity and inverses.
--
-- Minimal complete definition: 'zero', @('+')@ and (@('-')@ or 'negate').
class  AbelianGroup a  where
-- | The identity of @('+')@.
zero             :: a
-- | A commutative associative operation with identity @zero@.
(+), (-)         :: a -> a -> a
-- | Inverse for @('+')@ (unary negation).
negate           :: a -> a

x - y            =  x + negate y
negate x         =  zero - x

-- | A ring: addition forms an Abelian group, and multiplication defines
-- a monoid and distributes over addition.
-- Multiplication is not guaranteed to be commutative.
--
-- Minimal complete definition: @('*')@ and 'fromInteger'.
class  (AbelianGroup a) => Ring a where
-- | An associative operation with identity @'fromInteger' 1@,
-- distributing over @('+')@ and 'zero'.
(*)              :: a -> a -> a

-- | Conversion from 'Integer', the initial ring:
-- 'fromInteger' is the unique function preserving 'zero', @('+')@,
-- @('-')@ and @('*')@, and for which @'fromInteger' 1@ is the
-- identity of @('*')@.
--
-- An integer literal represents the application of the function
-- 'fromInteger' to the appropriate value of type 'Integer',
-- so such literals have type @('Ring' a) => a@.
fromInteger      :: Integer -> a

-- | A integral domain (a non-trivial commutative 'Ring' with no zero
-- divisors) on which the Euclid's algorithm for 'gcd' works.
--
-- Minimal complete definition:
--  ('divMod' or ('div' and 'mod')) and 'unit'.
class  (Eq a, Ring a) => EuclideanDomain a  where
div, mod         :: a -> a -> a
-- ^ Division with remainder: for any @d /= 0@,
--
-- * @n == 'div' n d * d + 'mod' n d@
--
-- * @'mod' (n + a*d) d == 'mod' n d@
--
-- * @'mod' n d@ is smaller than @d@ in some well-founded order.
--
-- For integral types, @'mod' n d@ is a non-negative integer smaller
-- than the absolute value of @d@.
divMod           :: a -> a -> (a,a)
-- ^ @'divMod' n d == ('div' n d, 'mod' n d)@

associate, unit  :: a -> a
-- ^ For each @x@ there is a decomposition @x == 'associate' x * 'unit' x@
-- such that @'unit' x@ has a multiplicative inverse and
--
-- * if @x@ and @y@ are factors of each other, then @'associate' x == 'associate' y@
--
-- * @'associate' 1 == 1@
--
-- For integral types, @'associate' x@ is a non-negative integer and
-- @'unit' x@ is @-1@ or @1@.

n `divMod` d     =  (n `div` d, n `mod` d)
n `div` d        =  q  where (q,_) = divMod n d
n `mod` d        =  r  where (_,r) = divMod n d

associate x      =  x `div` unit x

-- | A commutative 'Ring' in which all non-zero elements have multiplicative
-- inverses.
--
-- Minimal complete definition: 'recip' or @('/')@.
class  (Ring a) => Field a  where
(/)              :: a -> a -> a
-- | Multiplicative inverse.
recip            :: a -> a

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

-------------------------------------------------------------------------
-- instances for Prelude numeric types
-------------------------------------------------------------------------

instance  AbelianGroup Int  where
zero            =  0
(+)             =  (Prelude.+)
(-)             =  (Prelude.-)
negate          =  Prelude.negate

instance  Ring Int  where
(*)             =  (Prelude.*)
fromInteger     =  Prelude.fromInteger

instance  EuclideanDomain Int  where
div             =  Prelude.div
mod             =  Prelude.mod
associate x     =  abs x
unit x          =  if x < 0 then -1 else 1

instance  AbelianGroup Integer  where
zero            =  0
(+)             =  (Prelude.+)
(-)             =  (Prelude.-)
negate          =  Prelude.negate

instance  Ring Integer  where
(*)             =  (Prelude.*)
fromInteger     =  id

instance  EuclideanDomain Integer  where
div             =  Prelude.div
mod             =  Prelude.mod
associate x     =  abs x
unit x          =  if x < 0 then -1 else 1

instance  AbelianGroup Float  where
zero            =  0
(+)             =  (Prelude.+)
(-)             =  (Prelude.-)
negate          =  Prelude.negate

instance  Ring Float  where
(*)             =  (Prelude.*)
fromInteger     =  Prelude.fromInteger

instance  Field Float  where
(/)             =  (Prelude./)

instance  AbelianGroup Double  where
zero            =  0
(+)             =  (Prelude.+)
(-)             =  (Prelude.-)
negate          =  Prelude.negate

instance  Ring Double  where
(*)             =  (Prelude.*)
fromInteger     =  Prelude.fromInteger

instance  Field Double  where
(/)             =  (Prelude./)

-- Numeric functions

-- | The same as @'flip' ('-')@.
--
-- Because @-@ is treated specially in the Haskell grammar,
-- @(-@ /e/@)@ is not a section, but an application of prefix negation.
-- However, @('subtract'@ /exp/@)@ is equivalent to the disallowed section.
{-# INLINE subtract #-}
subtract         :: (AbelianGroup a) => a -> a -> a
subtract         =  flip (-)

-- | @'gcd' x y@ is a common factor of @x@ and @y@ such that
--
-- * @'associate' ('gcd' x y) == 'gcd' x y@, and
--
-- * any common factor of @x@ and @y@ is a factor of @'gcd' x y@.
gcd              :: (EuclideanDomain a) => a -> a -> a
gcd x 0          =  associate x
gcd x y          =  gcd y (x `mod` y)

-- | @'lcm' x y@ is a common multiple of @x@ and @y@ such that
--
-- * @'associate' ('lcm' x y) == 'lcm' x y@, and
--
-- * any common multiple of @x@ and @y@ is a multiple of @'lcm' x y@.
lcm              :: (EuclideanDomain a) => a -> a -> a
lcm _ 0          =  0
lcm 0 _          =  0
lcm x y          =  associate ((x `div` (gcd x y)) * y)

-- Other types

-- | Forms the ratio of two values in a Euclidean domain (e.g. 'Integer').
{-# SPECIALISE (%) :: Integer -> Integer -> Rational #-}
(%)                     :: (EuclideanDomain a) => a -> a -> Ratio a

-- | Extract the numerator of the ratio in reduced form:
-- the numerator and denominator have no common factor and the denominator
-- is positive.
numerator               :: (EuclideanDomain a) => Ratio a -> a

-- | Extract the denominator of the ratio in reduced form:
-- the numerator and denominator have no common factor and the denominator
-- is positive.
denominator             :: (EuclideanDomain a) => Ratio a -> a

-- y /= 0 && x % y = n :% d ==>
--      associate d = d &&
--      x*d = y*n
--      x*d' = y*n' ==> exists a. d' = a*d && n' = a*n
x % y                   =  (x `div` (d * unit y')) :% associate y'
where y' = y `div` d
d = gcd x y

numerator (x :% _)      =  x

denominator (_ :% y)    =  y

{-
instance  (EuclideanDomain a, Ord a) => Ord (Ratio a)  where
(x:%y) <= (x':%y')  =  x * y' <= x' * y
(x:%y) <  (x':%y')  =  x * y' <  x' * y
-}

instance  (EuclideanDomain a) => AbelianGroup (Ratio a)  where
zero                =  zero :% 1
(x:%y) + (x':%y')   =  (x*y' + x'*y) % (y*y')
negate (x:%y)       =  (-x) :% y

instance  (EuclideanDomain a) => Ring (Ratio a)  where
(x:%y) * (x':%y')   =  (x * x') % (y * y')
fromInteger x       =  fromInteger x :% 1

instance  (EuclideanDomain a) => Field (Ratio a)  where
(x:%y) / (x':%y')   =  (x*y') % (y*x')
recip (x:%y)        =  y % x

{-
ratPrec = 7 :: Int

(\r -> [(x%y,u) | (x,s)   <- readsPrec (ratPrec+1) r,
("%",t) <- lex s,
(y,u)   <- readsPrec (ratPrec+1) t ])

instance  (EuclideanDomain a, Show a)  => Show (Ratio a)  where
showsPrec p (x:%y)  =  showParen (p > ratPrec)
(showsPrec (ratPrec+1) x .
showString " % " .
showsPrec (ratPrec+1) y)
-}

-- | Direct product
instance  (AbelianGroup a, AbelianGroup b) => AbelianGroup (a,b)  where
zero            =  (zero, zero)
(x,y) + (x',y') =  (x+x', y+y')
(x,y) - (x',y') =  (x-x', y-y')
negate (x,y)    =  (negate x, negate y)

-- | Direct product
instance  (Ring a, Ring b) => Ring (a,b)  where
(x,y) * (x',y') =  (x*x', y*y')
fromInteger n   =  (fromInteger n, fromInteger n)

ifThenElse :: Bool -> a -> a -> a
ifThenElse True x _ = x
ifThenElse False _ y = y
```