{-# LANGUAGE CPP                        #-}
{-# LANGUAGE Safe                       #-}
{-# LANGUAGE PolyKinds                  #-}
{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE DefaultSignatures          #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE RebindableSyntax           #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE TypeFamilies               #-}

module Data.Algebra where
{- (
    type FreeAlgebra
  , Algebra(..)
  , type FreeComposition
  , Composition(..)
  , type FreeUnital
  , Unital(..)
  , type FreeDivision
  , Division(..)
  , (.*.)
  , (//)
  , (.@.)
  , unit
  , norm
  , conj
  , triple
  , reciprocal

) where
-}

import safe Control.Category ((>>>))
import safe Data.Bool
import safe Data.Complex
import safe Data.Functor.Rep
import safe Data.Semifield
import safe Data.Semigroup.Additive as A
import safe Data.Semigroup.Multiplicative as M
import safe Data.Semimodule
import safe Data.Semiring hiding ((//))
import safe Prelude hiding (Num(..), Fractional(..), Real, sum, product)
import Data.Functor.Classes

import safe qualified Data.IntSet as IntSet
import safe qualified Data.Set as Set


import qualified Data.Sequence as Seq
import Data.Sequence hiding (reverse,index)
import qualified Control.Monad as M

-- | An algebra over a free semimodule.
--type FreeAlgebra a f = (FreeSemimodule a f, Algebra a (Rep f))
type FreeAlgebra a f = (Free f, (Additive-Group) (f a), Algebra a (Rep f))

-- | A unital algebra over a free semimodule.
type FreeUnital a f = (FreeAlgebra a f, Unital a (Rep f))

-- | A unital algebra over a free semimodule.
type FreeClifford a f = (FreeUnital a f, Clifford a (Rep f))

-- | < https://en.wikipedia.org/wiki/Algebra_over_a_field#Generalization:_algebra_over_a_ring Algebra > over a semiring.
--
-- Needn't be associative or unital.
--
class Semiring a => Algebra a b where
  aappend :: (b -> b -> a) -> b -> a


infixl 7 .*.

-- | Multiplication operator on a free algebra.
--
-- In particular this is cross product on the standard basis in /R^3/:
--
-- >>> V3 1 0 0 .*. V3 0 1 0 .*. V3 0 1 0 :: V3 Int
-- V3 (-1) 0 0
-- >>> V3 1 0 0 .*. (V3 0 1 0 .*. V3 0 1 0) :: V3 Int
-- V3 0 0 0
--
-- For Lie algebras like one above, '.*.' satisfies the following properties:
--
-- @ 
-- a '.*.' a = 'zero'
-- a '.*.' b = 'negate' ( b '.*.' a ) , 
-- a '.*.' ( b <> c ) = ( a '.*.' b ) <> ( a '.*.' c ) , 
-- ( r a ) '.*.' b = a '.*.' ( r b ) = r ( a '.*.' b ) . 
-- a '.*.' ( b '.*.' c ) <> b '.*.' ( c '.*.' a ) <> c '.*.' ( a '.*.' b ) = 'mempty' . 
-- @
--
-- See < https://en.wikipedia.org/wiki/Jacobi_identity Jacobi identity >.
--
-- /Caution/ in general (.*.) needn't be commutative, nor even associative.
--
-- For associative algebras, consider implementing `Multiplicative``-``Semigroup` as well for clarity:
--
-- >>> (1 :+ 2) .*. (3 :+ 4) :: Complex Int
-- (-5) :+ 10
-- >>> (1 :+ 2) * (3 :+ 4) :: Complex Int
-- (-5) :+ 10
-- >>> qi .*. qj :: QuatM
-- Quaternion 0.000000 (V3 0.000000 0.000000 1.000000)
-- >>> qi * qj :: QuatM
-- Quaternion 0.000000 (V3 0.000000 0.000000 1.000000)
--
(.*.) :: FreeAlgebra a f => f a -> f a -> f a
(.*.) x y = tabulate $ aappend (\i j -> index x i * index y j)


class (Semiring a, Algebra a b) => Unital a b where
  aempty :: a -> b -> a

-- | Unital element of a free unital algebra.
--
-- >>> aaempty :: Complex Int
-- 1 :+ 0
-- >>> aaempty :: QuatD
-- Quaternion 1.0 (V3 0.0 0.0 0.0)
--
unit :: FreeUnital a f => f a
unit = tabulate $ aempty one


-- | A (not necessarily associative) < https://en.wikipedia.org/wiki/Division_algebra division algebra >.
--
class (Semifield a, FreeUnital a f) => Division a f where

  -- | Reciprocal operator.
  --
  -- When /f/ is a composition algebra we must have:
  --
  -- @ 'arecip' x = ('recip' $ 'norm' f) '*.' 'conj' f
  --
  -- See 'Data.Algebra.Property'.
  --
  arecip :: f a -> f a
  arecip f = unit ./. f

  infixl 7 ./.
  -- | Division operator.
  --
  -- >>> (1 :+ 0) ./. (0 :+ 1)
  -- 0.0 :+ (-1.0)
  -- >>> qe ./. qi :: QuatD
  -- Quat 0.0 (V3 (-1.0) 0.0 0.0)
  --
  (./.) :: f a -> f a -> f a
  (./.) x y = x .*. arecip y

  infixl 7 .\.
  -- | Left division operator.
  --
  -- >>> (1 :+ 0) .\. (0 :+ 1)
  -- 0.0 :+ 1.0
  -- >>> qe .\. qi :: QuatD
  -- Quat 0.0 (V3 1.0 0.0 0.0)
  --
  (.\.) :: f a -> f a -> f a
  (.\.) x y = arecip x .*. y




-- | Bilinear form on a free composition algebra.
--
-- 
-- See 'Data.Algebra.Property'.
--
-- >>> V2 1 2 .@. V2 1 2
-- 5.0
-- >>> V2 1 2 .@. V2 2 (-1)
-- 0.0
-- >>> V3 1 1 1 .@. V3 1 1 (-2)
-- 0.0
-- 
-- >>> (1 :+ 2) .@. (2 :+ (-1)) :: Double
-- 0.0
--
-- >>> qi .@. qj :: Double
-- 0.0
-- >>> qj .@. qk :: Double
-- 0.0
-- >>> qk .@. qi :: Double
-- 0.0
-- >>> qk .@. qk :: Double
-- 1.0
--
--foldcomp :: Composition a f => f a -> f a -> a
--foldcomp = symmetric norm


{-


foo x y = x .*. y + y .*. x 
bar x y = (two * x .@. y) *. unit

--prop_cliff x y = x .*. y + y .*. x == (two * x .@. y) *. unit

prop_cliff x = x .*. x == fmap (quad (index x) *) unit

class (Field a, FreeUnital a f) => Clifford a f where

  quad :: f a -> a

instance Clifford C where
instance Clifford (C++C) where


-}



-- https://en.wikipedia.org/wiki/Multivector
class (Ring a, Unital a b) => Clifford a b where

  -- | 
  --
  -- @
  -- x '.*.' x = 'metric' x x '*.' 'unit'
  -- x .*. y + y .*. x = (two * x .@. y) *. unit
  -- @
  --
  --quad :: (b -> a) -> a

  metric :: (b -> b -> a) -> a


--euclidean :: Clifford a b => Eq b => a
--euclidean = metric $ \b1 b2 -> bool zero one (b1 == b2)

symmetric :: Field a => (Additive-Semigroup) b => (b -> a) -> b -> b -> a
symmetric q x y = prod / two where prod = q (x + y) - q x - q y



-- foldc x x = quad $ index x  for basis elements
foldc :: FreeClifford a f => f a -> f a -> a
foldc x y = metric (\i j -> index x i * index y j)







{-
norm x = normWith $ index x

check x y = symmetric quad (index x) (index y) == foldc x y

sym q x y = q (x + y) - q x - q y

check x y = (sym (M.join foldc) x y) *. unit == x .*. y + y .*. x

foo x y = x .*. y + y .*. x

λ> e1 = c 1 0
λ> e2 = c 0 1
λ> foldc e1 e1
1.0
λ> q e1
1.0
λ> foldc e2 e2
-1.0
λ> q e2
1.0
-}
--


-- | A < https://en.wikipedia.org/wiki/Composition_algebra composition algebra >.
--
class FreeClifford a f => Composition a f where

  -- | Conjugation operator.
  --
  -- @ 'conj' a '*' 'conj' b = 'conj' (b '*' a) @
  --
  conj :: f a -> f a

  -- | Norm operator on a composition algebra.
  --
  -- @ 
  -- 'norm' x '*' 'norm' y = 'norm' (x '*' y)
  -- 'norm' x '*' 'norm' x = 'norm' $ x '*' 'conj' x
  -- @
  --
  norm :: f a -> a
  --norm f = quad $ index f


---------------------------------------------------------------------
-- Instances
---------------------------------------------------------------------

{-

type CD = Complex Double

c x y = x :+ y :: Complex Double
x = c 1 0
y = c (-3) 0

x' = c 1 (-2)
y' = c 3 (-4)

x .*. x
foldc x x

λ> y .*. y
(-9.0) :+ 0.0
λ> foldc y y
-9.0
-}

instance Ring r => Algebra r Bool where
  -- x * conj y
  aappend f False = negate $ f False False + f True True
  aappend f True = f False True - f True False

instance Ring r => Unital r Bool where
  aempty x False = x
  aempty _ _ = zero

instance Field a => Clifford a Bool where

  metric f = negate (f False False + f True True)

{-
  quad = normWith where
    --conjugateWith :: Group (Additive p) => (Bool -> p) -> Bool -> p
    conjugateWith f = f' where
      afe = f False
      nfi = negate (f True)
      f' False = afe
      f' True = nfi

    --normWith :: Ring c => (Bool -> c) -> c
    normWith f = flip aappend zero $ \i1 i2 -> f i1 * conjugateWith f i2
-}

instance Real a => Composition a Complex where
  conj (x :+ y) = x :+ negate y
  norm x = flip index False $ x * conj x

instance Real a => Division a Complex where
  arecip f = (recip $ norm f) *. conj f



{-
instance Real a => Clifford a Complex where
  quad (x :+ y) = flip index False $ (x :+ y) * (x :+ (-y))

instance Ring r => Algebra r ComplexBasis where

  aappend f False = f False False + f True True
  aappend f True = f False True - f True False

instance Field a => Clifford a Complex where
  quad = norm --(x :+ y) = x * x - y * y
  (a1 :+ a2) .@. (b1 :+ b2) = (a1*b1 + a2*b2) :+ (a1*b2 - a2*b1)

-}



--instance (Semiring a, Unital a b) => Unital a (a -> r) where
--  aempty = aempty one

--instance (Semiring a, Division a b) => Division r (a -> r) where
--  reciprocalWith = reciprocalWith

-- incoherent
-- instance Unital () a where aempty _ _ = ()
-- instance (Unital a b, Unital a c) => Unital (a -> r) b where aempty f b a = aempty (f a) b
--instance (Unital r a, Unital r b) => Unital (a -> r) b where aempty f b a = aempty (f a) b

--instance (Algebra r b, Algebra r a) => Algebra (b -> r) a where aappend f a b = aappend (\a1 a2 -> f a1 a2 b) a


instance Semiring a => Algebra a () where
  aappend f = f ()

instance Semiring a => Unital a () where
  aempty r () = r

instance (Algebra a b, Algebra a c) => Algebra a (b, c) where
  aappend f (a,b) = aappend (\a1 a2 -> aappend (\b1 b2 -> f (a1,b1) (a2,b2)) b) a

instance (Unital a b, Unital a c) => Unital a (b, c) where
  aempty r (a,b) = aempty r a * aempty r b

instance (Algebra a b, Algebra a c, Algebra a d) => Algebra a (b, c, d) where
  aappend f (a,b,c) = aappend (\a1 a2 -> aappend (\b1 b2 -> aappend (\c1 c2 -> f (a1,b1,c1) (a2,b2,c2)) c) b) a

instance (Unital a b, Unital a c, Unital a d) => Unital a (b, c, d) where
  aempty r (a,b,c) = aempty r a * aempty r b * aempty r c

-- | Tensor algebra
--
-- >>> aappend (<>) [1..3 :: Int]
-- [1,2,3,1,2,3,1,2,3,1,2,3]
--
-- >>> aappend (\f g -> fold (f ++ g)) [1..3] :: Int
-- 24
--
instance Semiring a => Algebra a [a] where
  aappend f = go [] where
    go ls rrs@(r:rs) = f (reverse ls) rrs + go (r:ls) rs
    go ls [] = f (reverse ls) []

instance Semiring a => Unital a [a] where
  aempty a [] = a
  aempty _ _ = zero


-- | The tensor algebra
instance Semiring r => Algebra r (Seq a) where
  aappend f = go Seq.empty where
    go ls s = case viewl s of
       EmptyL -> f ls s
       r :< rs -> f ls s + go (ls |> r) rs

instance (Semiring r) => Unital r (Seq a) where
  aempty r a | Seq.null a = r
             | otherwise = zero

instance (Semiring r, Ord a) => Algebra r (Set.Set a) where
  aappend f = go Set.empty where
    go ls s = case Set.minView s of
       Nothing -> f ls s
       Just (r, rs) -> f ls s + go (Set.insert r ls) rs

instance (Semiring r, Ord a) => Unital r (Set.Set a) where
  aempty r a | Set.null a = r
           | otherwise = zero

instance Semiring r => Algebra r IntSet.IntSet where
  aappend f = go IntSet.empty where
    go ls s = case IntSet.minView s of
       Nothing -> f ls s
       Just (r, rs) -> f ls s + go (IntSet.insert r ls) rs

instance Semiring r => Unital r IntSet.IntSet where
  aempty r a | IntSet.null a = r
           | otherwise = zero