content: {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances, TypeOperators #-}
  module Numeric.Algebra.Class 
    (
    -- * Multiplicative Semigroups
      Multiplicative(..)
    , pow1pIntegral
    , product1
    -- * Semirings
    , Semiring
    -- * Left and Right Modules
    , LeftModule(..)
    , RightModule(..)
    , Module
    -- * Additive Monoids
    , Monoidal(..)
    , sum
    , sinnumIdempotent
    -- * Associative algebras
    , Algebra(..)
    -- * Coassociative coalgebras
    , Coalgebra(..)
    ) where
  
  import Data.Foldable hiding (sum, concat)
  import Data.Int
  import Data.IntMap (IntMap)
  import Data.IntSet (IntSet)
  import Data.Map (Map)
  import Data.Monoid (mappend)
  -- import Data.Semigroup.Foldable
  import Data.Sequence hiding (reverse,index)
  import Data.Semigroup.Foldable
  import Data.Set (Set)
  import Data.Word
  import Numeric.Additive.Class
  import Numeric.Natural
  import Prelude hiding ((*), (+), negate, subtract,(-), recip, (/), foldr, sum, product, replicate, concat)
  import qualified Data.IntMap as IntMap
  import qualified Data.IntSet as IntSet
  import qualified Data.Map as Map
  import qualified Data.Sequence as Seq
  import qualified Data.Set as Set
  import qualified Prelude
  
  infixr 8 `pow1p`
  infixl 7 *, .*, *.
  
  -- | A multiplicative semigroup
  class Multiplicative r where
    (*) :: r -> r -> r 
  
  -- class Multiplicative r => PowerAssociative r where
    -- pow1p x n = pow x (1 + n)
    pow1p :: r -> Natural -> r
    pow1p x0 y0 = f x0 (y0 Prelude.+ 1) where
      f x y 
        | even y = f (x * x) (y `quot` 2)
        | y == 1 = x
        | otherwise = g (x * x) ((y Prelude.- 1) `quot` 2) x
      g x y z 
        | even y = g (x * x) (y `quot` 2) z
        | y == 1 = x * z
        | otherwise = g (x * x) ((y Prelude.- 1) `quot` 2) (x * z)
  
  -- class PowerAssociative r => Assocative r where
    productWith1 :: Foldable1 f => (a -> r) -> f a -> r
    productWith1 f = maybe (error "Numeric.Multiplicative.Semigroup.productWith1: empty structure") id . foldl' mf Nothing
      where 
        mf Nothing y = Just $! f y
        mf (Just x) y = Just $! x * f y
  
  product1 :: (Foldable1 f, Multiplicative r) => f r -> r
  product1 = productWith1 id
  
  pow1pIntegral :: (Integral r, Integral n) => r -> n -> r
  pow1pIntegral r n = r ^ (1 Prelude.+ n)
  
  instance Multiplicative Bool where
    (*) = (&&)
    pow1p m _ = m
  
  instance Multiplicative Natural where
    (*) = (Prelude.*)
    pow1p = pow1pIntegral
  
  instance Multiplicative Integer where
    (*) = (Prelude.*)
    pow1p = pow1pIntegral
  
  instance Multiplicative Int where
    (*) = (Prelude.*)
    pow1p = pow1pIntegral
  
  instance Multiplicative Int8 where
    (*) = (Prelude.*)
    pow1p = pow1pIntegral
  
  instance Multiplicative Int16 where
    (*) = (Prelude.*)
    pow1p = pow1pIntegral
  
  instance Multiplicative Int32 where
    (*) = (Prelude.*)
    pow1p = pow1pIntegral
  
  instance Multiplicative Int64 where
    (*) = (Prelude.*)
    pow1p = pow1pIntegral
  
  instance Multiplicative Word where
    (*) = (Prelude.*)
    pow1p = pow1pIntegral
  
  instance Multiplicative Word8 where
    (*) = (Prelude.*)
    pow1p = pow1pIntegral
  
  instance Multiplicative Word16 where
    (*) = (Prelude.*)
    pow1p = pow1pIntegral
  
  instance Multiplicative Word32 where
    (*) = (Prelude.*)
    pow1p = pow1pIntegral
  
  instance Multiplicative Word64 where
    (*) = (Prelude.*)
    pow1p = pow1pIntegral
  
  instance Multiplicative () where
    _ * _ = ()
    pow1p _ _ = ()
  
  instance (Multiplicative a, Multiplicative b) => Multiplicative (a,b) where
    (a,b) * (c,d) = (a * c, b * d)
  
  instance (Multiplicative a, Multiplicative b, Multiplicative c) => Multiplicative (a,b,c) where
    (a,b,c) * (i,j,k) = (a * i, b * j, c * k)
  
  instance (Multiplicative a, Multiplicative b, Multiplicative c, Multiplicative d) => Multiplicative (a,b,c,d) where
    (a,b,c,d) * (i,j,k,l) = (a * i, b * j, c * k, d * l)
  
  instance (Multiplicative a, Multiplicative b, Multiplicative c, Multiplicative d, Multiplicative e) => Multiplicative (a,b,c,d,e) where
    (a,b,c,d,e) * (i,j,k,l,m) = (a * i, b * j, c * k, d * l, e * m)
  
  instance Algebra r a => Multiplicative (a -> r) where
    f * g = mult $ \a b -> f a * g b
  
  -- | A pair of an additive abelian semigroup, and a multiplicative semigroup, with the distributive laws:
  -- 
  -- > a(b + c) = ab + ac -- left distribution (we are a LeftNearSemiring)
  -- > (a + b)c = ac + bc -- right distribution (we are a [Right]NearSemiring)
  --
  -- Common notation includes the laws for additive and multiplicative identity in semiring.
  --
  -- If you want that, look at 'Rig' instead.
  --
  -- Ideally we'd use the cyclic definition:
  --
  -- > class (LeftModule r r, RightModule r r, Additive r, Abelian r, Multiplicative r) => Semiring r
  --
  -- to enforce that every semiring r is an r-module over itself, but Haskell doesn't like that.
  class (Additive r, Abelian r, Multiplicative r) => Semiring r
  instance Semiring Integer
  instance Semiring Natural
  instance Semiring Bool
  instance Semiring Int
  instance Semiring Int8
  instance Semiring Int16
  instance Semiring Int32
  instance Semiring Int64
  instance Semiring Word
  instance Semiring Word8
  instance Semiring Word16
  instance Semiring Word32
  instance Semiring Word64
  instance Semiring ()
  instance (Semiring a, Semiring b) => Semiring (a, b)
  instance (Semiring a, Semiring b, Semiring c) => Semiring (a, b, c)
  instance (Semiring a, Semiring b, Semiring c, Semiring d) => Semiring (a, b, c, d)
  instance (Semiring a, Semiring b, Semiring c, Semiring d, Semiring e) => Semiring (a, b, c, d, e)
  instance Algebra r a => Semiring (a -> r) 
  
  -- | An associative algebra built with a free module over a semiring
  class Semiring r => Algebra r a where
    mult :: (a -> a -> r) -> a -> r
  
  instance Algebra () a where
    mult _ _ = ()
  
  -- | The tensor algebra
  instance Semiring r => Algebra r [a] where
    mult f = go [] where
      go ls rrs@(r:rs) = f (reverse ls) rrs + go (r:ls) rs
      go ls [] = f (reverse ls) []
  
  -- | The tensor algebra
  instance Semiring r => Algebra r (Seq a) where
    mult 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 => Algebra r () where
    mult f = f ()
  
  instance (Semiring r, Ord a) => Algebra r (Set a) where
    mult 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 => Algebra r IntSet where
    mult 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, Monoidal r, Ord a, Partitionable b) => Algebra r (Map a b) -- where
  --  mult f xs = case minViewWithKey xs of
  --    Nothing -> zero 
  --    Just ((k, r), rs) -> ...
  -- instance (Semiring r, Monoidal r, Partitionable a) => Algebra r (IntMap a)
  
  instance (Algebra r a, Algebra r b) => Algebra r (a,b) where
    mult f (a,b) = mult (\a1 a2 -> mult (\b1 b2 -> f (a1,b1) (a2,b2)) b) a
  
  instance (Algebra r a, Algebra r b, Algebra r c) => Algebra r (a,b,c) where
    mult f (a,b,c) = mult (\a1 a2 -> mult (\b1 b2 -> mult (\c1 c2 -> f (a1,b1,c1) (a2,b2,c2)) c) b) a
  
  instance (Algebra r a, Algebra r b, Algebra r c, Algebra r d) => Algebra r (a,b,c,d) where
    mult f (a,b,c,d) = mult (\a1 a2 -> mult (\b1 b2 -> mult (\c1 c2 -> mult (\d1 d2 -> f (a1,b1,c1,d1) (a2,b2,c2,d2)) d) c) b) a
  
  instance (Algebra r a, Algebra r b, Algebra r c, Algebra r d, Algebra r e) => Algebra r (a,b,c,d,e) where
    mult f (a,b,c,d,e) = mult (\a1 a2 -> mult (\b1 b2 -> mult (\c1 c2 -> mult (\d1 d2 -> mult (\e1 e2 -> f (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2)) e) d) c) b) a
  
  -- incoherent
  -- instance (Algebra r b, Algebra r a) => Algebra (b -> r) a where mult f a b = mult (\a1 a2 -> f a1 a2 b) a
  
  -- A coassociative coalgebra over a semiring using
  class Semiring r => Coalgebra r c where
    comult :: (c -> r) -> c -> c -> r
  
  -- | Every coalgebra gives rise to an algebra by vector space duality classically.
  -- Sadly, it requires vector space duality, which we cannot use constructively.
  -- The dual argument only relies in the fact that any constructive coalgebra can only inspect a finite number of coefficients, 
  -- which we CAN exploit.
  instance Algebra r m => Coalgebra r (m -> r) where
    comult k f g = k (f * g)
  
  -- instance Coalgebra () c where comult _ _ _ = ()
  -- instance (Algebra r b, Coalgebra r c) => Coalgebra (b -> r) c where comult f c1 c2 b = comult (`f` b) c1 c2 
  
  instance Semiring r => Coalgebra r () where
    comult = const
  
  instance (Coalgebra r a, Coalgebra r b) => Coalgebra r (a, b) where
    comult f (a1,b1) (a2,b2) = comult (\a -> comult (\b -> f (a,b)) b1 b2) a1 a2
  
  instance (Coalgebra r a, Coalgebra r b, Coalgebra r c) => Coalgebra r (a, b, c) where
    comult f (a1,b1,c1) (a2,b2,c2) = comult (\a -> comult (\b -> comult (\c -> f (a,b,c)) c1 c2) b1 b2) a1 a2
  
  instance (Coalgebra r a, Coalgebra r b, Coalgebra r c, Coalgebra r d) => Coalgebra r (a, b, c, d) where
    comult f (a1,b1,c1,d1) (a2,b2,c2,d2) = comult (\a -> comult (\b -> comult (\c -> comult (\d -> f (a,b,c,d)) d1 d2) c1 c2) b1 b2) a1 a2
  
  instance (Coalgebra r a, Coalgebra r b, Coalgebra r c, Coalgebra r d, Coalgebra r e) => Coalgebra r (a, b, c, d, e) where
    comult f (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) = comult (\a -> comult (\b -> comult (\c -> comult (\d -> comult (\e -> f (a,b,c,d,e)) e1 e2) d1 d2) c1 c2) b1 b2) a1 a2
  
  -- | The tensor Hopf algebra
  instance Semiring r => Coalgebra r [a] where
    comult f as bs = f (mappend as bs)
  
  -- | The tensor Hopf algebra
  instance Semiring r => Coalgebra r (Seq a) where
    comult f as bs = f (mappend as bs)
  
  -- | the free commutative band coalgebra
  instance (Semiring r, Ord a) => Coalgebra r (Set a) where
    comult f as bs = f (Set.union as bs)
  
  -- | the free commutative band coalgebra over Int
  instance Semiring r => Coalgebra r IntSet where
    comult f as bs = f (IntSet.union as bs)
  
  -- | the free commutative coalgebra over a set and a given semigroup
  instance (Semiring r, Ord a, Additive b) => Coalgebra r (Map a b) where
    comult f as bs = f (Map.unionWith (+) as bs)
  
  -- | the free commutative coalgebra over a set and Int
  instance (Semiring r, Additive b) => Coalgebra r (IntMap b) where
    comult f as bs = f (IntMap.unionWith (+) as bs)
  
  class (Semiring r, Additive m) => LeftModule r m where
    (.*) :: r -> m -> m
  
  instance LeftModule Natural Bool where 
    0 .* _ = False
    _ .* a = a
  
  instance LeftModule Natural Natural where 
    (.*) = (*)
  
  instance LeftModule Natural Integer where 
    n .* m = toInteger n * m
  
  instance LeftModule Integer Integer where 
    (.*) = (*) 
  
  instance LeftModule Natural Int where
    (.*) = (*) . fromIntegral
  
  instance LeftModule Integer Int where
    (.*) = (*) . fromInteger
  
  instance LeftModule Natural Int8 where
    (.*) = (*) . fromIntegral
  
  instance LeftModule Integer Int8 where
    (.*) = (*) . fromInteger
  
  instance LeftModule Natural Int16 where
    (.*) = (*) . fromIntegral
  
  instance LeftModule Integer Int16 where
    (.*) = (*) . fromInteger
  
  instance LeftModule Natural Int32 where
    (.*) = (*) . fromIntegral
  
  instance LeftModule Integer Int32 where
    (.*) = (*) . fromInteger
  
  instance LeftModule Natural Int64 where
    (.*) = (*) . fromIntegral
  
  instance LeftModule Integer Int64 where
    (.*) = (*) . fromInteger
  
  instance LeftModule Natural Word where
    (.*) = (*) . fromIntegral
  
  instance LeftModule Integer Word where
    (.*) = (*) . fromInteger
  
  instance LeftModule Natural Word8 where
    (.*) = (*) . fromIntegral
  
  instance LeftModule Integer Word8 where
    (.*) = (*) . fromInteger
  
  instance LeftModule Natural Word16 where
    (.*) = (*) . fromIntegral
  
  instance LeftModule Integer Word16 where
    (.*) = (*) . fromInteger
  
  instance LeftModule Natural Word32 where
    (.*) = (*) . fromIntegral
  
  instance LeftModule Integer Word32 where
    (.*) = (*) . fromInteger
  
  instance LeftModule Natural Word64 where
    (.*) = (*) . fromIntegral
  
  instance LeftModule Integer Word64 where
    (.*) = (*) . fromInteger
  
  instance Semiring r => LeftModule r () where 
    _ .* _ = ()
  
  instance LeftModule r m => LeftModule r (e -> m) where 
    (.*) m f e = m .* f e
  
  instance Additive m => LeftModule () m where 
    _ .* a = a
  
  instance (LeftModule r a, LeftModule r b) => LeftModule r (a, b) where
    n .* (a, b) = (n .* a, n .* b)
  
  instance (LeftModule r a, LeftModule r b, LeftModule r c) => LeftModule r (a, b, c) where
    n .* (a, b, c) = (n .* a, n .* b, n .* c)
  
  instance (LeftModule r a, LeftModule r b, LeftModule r c, LeftModule r d) => LeftModule r (a, b, c, d) where
    n .* (a, b, c, d) = (n .* a, n .* b, n .* c, n .* d)
  
  instance (LeftModule r a, LeftModule r b, LeftModule r c, LeftModule r d, LeftModule r e) => LeftModule r (a, b, c, d, e) where
    n .* (a, b, c, d, e) = (n .* a, n .* b, n .* c, n .* d, n .* e)
  
  
  
  class (Semiring r, Additive m) => RightModule r m where
    (*.) :: m -> r -> m
  
  instance RightModule Natural Bool where 
    _ *. 0 = False
    a *. _ = a
  
  instance RightModule Natural Natural where (*.) = (*)
  
  instance RightModule Natural Integer where n *. m = n * fromIntegral m
  
  instance RightModule Integer Integer where (*.) = (*) 
  
  instance RightModule Natural Int where m *. n = m * fromIntegral n
  
  instance RightModule Integer Int where m *. n = m * fromInteger n
  
  instance RightModule Natural Int8 where m *. n = m * fromIntegral n
  
  instance RightModule Integer Int8 where m *. n = m * fromInteger n
  
  instance RightModule Natural Int16 where m *. n = m * fromIntegral n
  
  instance RightModule Integer Int16 where m *. n = m * fromInteger n
  
  instance RightModule Natural Int32 where m *. n = m * fromIntegral n
  
  instance RightModule Integer Int32 where m *. n = m * fromInteger n
  
  instance RightModule Natural Int64 where m *. n = m * fromIntegral n
  
  instance RightModule Integer Int64 where m *. n = m * fromInteger n
  
  instance RightModule Natural Word where m *. n = m * fromIntegral n
  
  instance RightModule Integer Word where m *. n = m * fromInteger n
  
  instance RightModule Natural Word8 where m *. n = m * fromIntegral n
  
  instance RightModule Integer Word8 where m *. n = m * fromInteger n
  
  instance RightModule Natural Word16 where m *. n = m * fromIntegral n
  
  instance RightModule Integer Word16 where m *. n = m * fromInteger n
  
  instance RightModule Natural Word32 where m *. n = m * fromIntegral n
  
  instance RightModule Integer Word32 where m *. n = m * fromInteger n
  
  instance RightModule Natural Word64 where m *. n = m * fromIntegral n
  
  instance RightModule Integer Word64 where m *. n = m * fromInteger n
  
  instance Semiring r => RightModule r () where 
    _ *. _ = ()
  
  instance RightModule r m => RightModule r (e -> m) where 
    (*.) f m e = f e *. m
  
  instance Additive m => RightModule () m where 
    (*.) = const
  
  instance (RightModule r a, RightModule r b) => RightModule r (a, b) where
    (a, b) *. n = (a *. n, b *. n)
  
  instance (RightModule r a, RightModule r b, RightModule r c) => RightModule r (a, b, c) where
    (a, b, c) *. n = (a *. n, b *. n, c *. n)
  
  instance (RightModule r a, RightModule r b, RightModule r c, RightModule r d) => RightModule r (a, b, c, d) where
    (a, b, c, d) *. n = (a *. n, b *. n, c *. n, d *. n)
  
  instance (RightModule r a, RightModule r b, RightModule r c, RightModule r d, RightModule r e) => RightModule r (a, b, c, d, e) where
    (a, b, c, d, e) *. n = (a *. n, b *. n, c *. n, d *. n, e *. n)
  
  
  
  class (LeftModule r m, RightModule r m) => Module r m
  instance (LeftModule r m, RightModule r m) => Module r m
  
  
  
  -- | An additive monoid
  --
  -- > zero + a = a = a + zero
  class (LeftModule Natural m, RightModule Natural m) => Monoidal m where
    zero :: m
  
    sinnum :: Natural -> m -> m
    sinnum 0 _  = zero
    sinnum n x0 = f x0 n
      where
        f x y
          | even y = f (x + x) (y `quot` 2)
          | y == 1 = x
          | otherwise = g (x + x) (pred y `quot` 2) x
        g x y z
          | even y = g (x + x) (y `quot` 2) z
          | y == 1 = x + z
          | otherwise = g (x + x) (pred y `quot` 2) (x + z)
  
    sumWith :: Foldable f => (a -> m) -> f a -> m
    sumWith f = foldl' (\b a -> b + f a) zero
  
  sum :: (Foldable f, Monoidal m) => f m -> m
  sum = sumWith id
  
  sinnumIdempotent :: (Integral n, Idempotent r, Monoidal r) => n -> r -> r
  sinnumIdempotent 0 _ = zero
  sinnumIdempotent _ x = x
  
  instance Monoidal Bool where 
    zero = False
    sinnum 0 _ = False
    sinnum _ r = r
  
  instance Monoidal Natural where
    zero = 0
    sinnum n r = fromIntegral n * r
  
  instance Monoidal Integer where 
    zero = 0
    sinnum n r = toInteger n * r
  
  instance Monoidal Int where 
    zero = 0
    sinnum n r = fromIntegral n * r
  
  instance Monoidal Int8 where 
    zero = 0
    sinnum n r = fromIntegral n * r
  
  instance Monoidal Int16 where 
    zero = 0
    sinnum n r = fromIntegral n * r
  
  instance Monoidal Int32 where 
    zero = 0
    sinnum n r = fromIntegral n * r
  
  instance Monoidal Int64 where 
    zero = 0
    sinnum n r = fromIntegral n * r
  
  instance Monoidal Word where 
    zero = 0
    sinnum n r = fromIntegral n * r
  
  instance Monoidal Word8 where 
    zero = 0
    sinnum n r = fromIntegral n * r
  
  instance Monoidal Word16 where 
    zero = 0
    sinnum n r = fromIntegral n * r
  
  instance Monoidal Word32 where 
    zero = 0
    sinnum n r = fromIntegral n * r
  
  instance Monoidal Word64 where 
    zero = 0
    sinnum n r = fromIntegral n * r
  
  instance Monoidal r => Monoidal (e -> r) where
    zero = const zero
    sumWith f xs e = sumWith (`f` e) xs
    sinnum n r e = sinnum n (r e)
  
  instance Monoidal () where 
    zero = ()
    sinnum _ () = ()
    sumWith _ _ = ()
  
  instance (Monoidal a, Monoidal b) => Monoidal (a,b) where
    zero = (zero,zero)
    sinnum n (a,b) = (sinnum n a, sinnum n b)
  
  instance (Monoidal a, Monoidal b, Monoidal c) => Monoidal (a,b,c) where
    zero = (zero,zero,zero)
    sinnum n (a,b,c) = (sinnum n a, sinnum n b, sinnum n c)
  
  instance (Monoidal a, Monoidal b, Monoidal c, Monoidal d) => Monoidal (a,b,c,d) where
    zero = (zero,zero,zero,zero)
    sinnum n (a,b,c,d) = (sinnum n a, sinnum n b, sinnum n c, sinnum n d)
  
  instance (Monoidal a, Monoidal b, Monoidal c, Monoidal d, Monoidal e) => Monoidal (a,b,c,d,e) where
    zero = (zero,zero,zero,zero,zero)
    sinnum n (a,b,c,d,e) = (sinnum n a, sinnum n b, sinnum n c, sinnum n d, sinnum n e)
  
  