{-# 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 #-}
{-# LANGUAGE RankNTypes #-}
module Data.Algebra (
type FreeAlgebra
, Algebra(..)
, (.*.)
, type FreeUnital
, Unital(..)
, unital
, unit
, type FreeCoalgebra
, Coalgebra(..)
, type FreeCounital
, Counital(..)
, counital
, type FreeBialgebra
, Bialgebra
) where
import safe Data.Bool
import safe Data.Functor.Rep
import safe Data.Semimodule
import safe Data.Semiring
import safe Prelude (Ord, reverse)
import safe qualified Data.IntSet as IntSet
import safe qualified Data.Set as Set
import safe qualified Data.Sequence as Seq
import safe Data.Sequence hiding (reverse,index)
import safe Prelude hiding (Num(..), Fractional(..), negate, sum, product)
type FreeAlgebra a f = (FreeSemimodule a f, Algebra a (Rep f))
class Semiring a => Algebra a b where
append :: (b -> b -> a) -> b -> a
infixl 7 .*.
(.*.) :: FreeAlgebra a f => f a -> f a -> f a
(.*.) x y = tabulate $ append (\i j -> index x i * index y j)
type FreeUnital a f = (FreeAlgebra a f, Unital a (Rep f))
class Algebra a b => Unital a b where
aempty :: a -> b -> a
unital :: FreeUnital a f => a -> f a
unital = tabulate . aempty
unit :: FreeUnital a f => f a
unit = unital one
type FreeCoalgebra a f = (FreeSemimodule a f, Coalgebra a (Rep f))
class Semiring a => Coalgebra a c where
coappend :: (c -> a) -> c -> c -> a
type FreeCounital a f = (FreeCoalgebra a f, Counital a (Rep f))
class Coalgebra a c => Counital a c where
coempty :: (c -> a) -> a
counital :: FreeCounital a f => f a -> a
counital = coempty . index
type FreeBialgebra a f = (FreeAlgebra a f, FreeCoalgebra a f, Bialgebra a (Rep f))
class (Unital a b, Counital a b) => Bialgebra a b
instance Semiring a => Algebra a () where
append f = f ()
instance Semiring a => Unital a () where
aempty r () = r
instance (Algebra a b, Algebra a c) => Algebra a (b, c) where
append f (a,b) = append (\a1 a2 -> append (\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
append f (a,b,c) = append (\a1 a2 -> append (\b1 b2 -> append (\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
instance Semiring a => Algebra a [a] where
append 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
instance Semiring r => Algebra r (Seq a) where
append 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
append 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
append 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
instance Semiring r => Coalgebra r () where
coappend = const
instance Semiring r => Counital r () where
coempty f = f ()
instance (Coalgebra r a, Coalgebra r b) => Coalgebra r (a, b) where
coappend f (a1,b1) (a2,b2) = coappend (\a -> coappend (\b -> f (a,b)) b1 b2) a1 a2
instance (Counital r a, Counital r b) => Counital r (a, b) where
coempty k = coempty $ \a -> coempty $ \b -> k (a,b)
instance (Coalgebra r a, Coalgebra r b, Coalgebra r c) => Coalgebra r (a, b, c) where
coappend f (a1,b1,c1) (a2,b2,c2) = coappend (\a -> coappend (\b -> coappend (\c -> f (a,b,c)) c1 c2) b1 b2) a1 a2
instance (Counital r a, Counital r b, Counital r c) => Counital r (a, b, c) where
coempty k = coempty $ \a -> coempty $ \b -> coempty $ \c -> k (a,b,c)
instance (Algebra r a) => Coalgebra r (a -> r) where
coappend k f g = k (f * g)
instance (Algebra r a) => Counital r (a -> r) where
coempty k = k one
instance Semiring r => Coalgebra r [a] where
coappend f as bs = f (mappend as bs)
instance Semiring r => Counital r [a] where
coempty k = k []
instance Semiring r => Coalgebra r (Seq a) where
coappend f as bs = f (mappend as bs)
instance Semiring r => Counital r (Seq a) where
coempty k = k (Seq.empty)
instance (Semiring r, Ord a) => Coalgebra r (Set.Set a) where
coappend f as bs = f (Set.union as bs)
instance (Semiring r, Ord a) => Counital r (Set.Set a) where
coempty k = k (Set.empty)
instance Semiring r => Coalgebra r IntSet.IntSet where
coappend f as bs = f (IntSet.union as bs)
instance Semiring r => Counital r IntSet.IntSet where
coempty k = k (IntSet.empty)