{-# LANGUAGE TypeSynonymInstances #-}

{-# LANGUAGE FlexibleInstances #-}

{-# LANGUAGE ConstraintKinds #-}

module DSLsofMath.Algebra where

import qualified Data.Ratio

import qualified Prelude

import Prelude (Double, Rational, Int, Integer, Bool(..), otherwise,

Foldable(foldr), (.), const, (==), (<), error)

import Data.Complex

infixl 6 -

infixl 6 +

infixl 7 *

infixl 7 /

class Additive a where

zero :: a

(+) :: a -> a -> a

sum :: (Foldable t, Additive a) => t a -> a

sum = foldr (+) zero

times :: Additive a => Integer -> a -> a

times n0 = if n0 < 0 then error "Algebra.Classes.times: negative number of times"

else go n0

where go 0 _ = zero

go 1 x = x

go n x = if r == 0 then twoy else x + twoy

where (m,r) = n `Prelude.divMod` 2

y = go m x

twoy = y+y

(-) :: AddGroup a => a -> a -> a

x - y = x + negate y

class Additive a => AddGroup a where

negate :: a -> a

mult :: AddGroup a => Integer -> a -> a

mult n x = if n < 0 then negate (times (negate n) x) else times n x

class Multiplicative a where

one :: a

(*) :: a -> a -> a

two :: (Additive a, Multiplicative a) => a

two = one+one

(^+) :: Multiplicative a => a -> Int -> a

x0 ^+ n0 = if n0 < 0 then error "Algebra.Classes.^: negative exponent"

else go n0 x0

where go 0 _ = one

go 1 x = x

go n x = if r == 0 then y2 else x * y2

where (m,r) = n `Prelude.divMod` 2

y = go m x

y2 = y * y

type Ring a = (AddGroup a, Multiplicative a)

fromInteger :: Ring a => Integer -> a

fromInteger n = mult n one

fromIntegral :: (Prelude.Integral a, Ring b) => a -> b

fromIntegral = fromInteger . Prelude.toInteger

class Multiplicative a => MulGroup a where

{-# MINIMAL (recip | (/)) #-}

recip :: a -> a

recip x = one / x

(/) :: a -> a -> a

x / y = x * recip y

(^) :: MulGroup a => a -> Int -> a

a ^ b | b < 0 = recip (a ^+ (negate b))

| otherwise = (a ^+ b)

type Field a = (Ring a, MulGroup a)

fromRational :: Field a => Data.Ratio.Ratio Integer -> a

fromRational x = fromInteger (Data.Ratio.numerator x) / fromInteger (Data.Ratio.denominator x)

class Field a => Algebraic a where

sqrt :: a -> a

class Field a => Transcendental a where

pi :: a

exp :: a -> a

sin :: a -> a

cos :: a -> a

cosh, sinh :: Transcendental a => a -> a

cosh x = (exp x + exp (negate x))/two

sinh x = (exp x - exp (negate x))/two

instance Additive Int where (+) = (Prelude.+); zero = 0

instance Additive Integer where (+) = (Prelude.+); zero = 0

instance Additive Rational where (+) = (Prelude.+); zero = 0

instance Additive Double where (+) = (Prelude.+); zero = 0

instance AddGroup Int where negate = Prelude.negate

instance AddGroup Integer where negate = Prelude.negate

instance AddGroup Rational where negate = Prelude.negate

instance AddGroup Double where negate = Prelude.negate

instance Multiplicative Int where (*) = (Prelude.*); one = 1

instance Multiplicative Integer where (*) = (Prelude.*); one = 1

instance Multiplicative Rational where (*) = (Prelude.*); one = 1

instance Multiplicative Double where (*) = (Prelude.*); one = 1

instance MulGroup Rational where (/) = (Prelude./); recip = Prelude.recip

instance MulGroup Double where (/) = (Prelude./); recip = Prelude.recip

lift0 :: a -> (x->a)

lift1 :: (a->b) -> (x->a) -> (x->b)

lift2 :: (a->b->c) -> (x->a) -> (x->b) -> (x->c)

lift0 = const

lift1 = (.)

lift2 op2 f g = \x -> op2 (f x) (g x)

instance Additive a => Additive (x -> a) where (+) = lift2 (+); zero = lift0 zero

instance Multiplicative a => Multiplicative (x -> a) where (*) = lift2 (*); one = lift0 one

instance AddGroup a => AddGroup (x -> a) where negate = lift1 negate

instance MulGroup a => MulGroup (x -> a) where recip = lift1 recip

instance Algebraic a => Algebraic (x -> a) where sqrt = lift1 sqrt

instance Transcendental a => Transcendental (x -> a) where

pi = lift0 pi; sin = lift1 sin; cos = lift1 cos; exp = lift1 exp

instance Algebraic Double where sqrt = Prelude.sqrt

instance Transcendental Double where

pi = Prelude.pi; sin = Prelude.sin; cos = Prelude.cos; exp = Prelude.exp

instance Additive a => Additive (Complex a) where (+) = addC; zero = zeroC

instance Ring a => Multiplicative (Complex a) where (*) = mulC; one = oneC

instance AddGroup a => AddGroup (Complex a) where negate = negateC

instance Field a => MulGroup (Complex a) where recip = recipC

addC :: Additive a => Complex a -> Complex a -> Complex a

addC (x :+ y) (x' :+ y') = (x + x') :+ (y+y')

negateC :: AddGroup a => Complex a -> Complex a

negateC (a :+ b) = negate a :+ negate b

mulC :: Ring a => Complex a -> Complex a -> Complex a

mulC (a :+ b) (a' :+ b') = (a * a' - b * b') :+ (a * b' + b * a')

toC :: Additive a => a -> Complex a

toC x = x :+ zero

zeroC :: Additive a => Complex a

zeroC = toC zero

oneC :: (Additive a, Multiplicative a) => Complex a

oneC = toC one

recipC (a :+ b) = (a / m) :+ (negate b / m)

where m = a*a + b*b

instance (Algebraic a, Prelude.RealFloat a) => Algebraic (Complex a) where

sqrt = Prelude.sqrt

instance (Transcendental a) => Transcendental (Complex a) where

pi = piC; exp = expC; sin = sinC; cos = cosC

piC :: Transcendental a => Complex a

piC = toC pi

expC, sinC, cosC, sinhC, coshC :: Transcendental a => Complex a -> Complex a

expC (x:+y) = expx * cos y :+ expx * sin y where expx = exp x

sinC (x:+y) = sin x * cosh y :+ cos x * sinh y

cosC (x:+y) = cos x * cosh y :+ negate (sin x * sinh y)

sinhC (x:+y) = cos y * sinh x :+ sin y * cosh x

coshC (x:+y) = cos y * cosh x :+ sin y * sinh x

ifThenElse :: Bool -> p -> p -> p

ifThenElse c a b = if c then a else b

neg :: AddGroup a => a -> a

neg = negate -- |neg| is used to typeset unary minus as a shorter dash, closer to its argument

frac :: MulGroup a => a -> a -> a

frac = (/) -- |frac| is used to typeset a fraction (more compactly than |x / y|)