{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, NoMonomorphismRestriction #-}
module Math.Combinatorics.IncidenceAlgebra where
import Prelude hiding ( (*>) )
import Math.Core.Utils
import Math.Combinatorics.Digraph
import Math.Combinatorics.Poset
import Math.Algebra.Field.Base
import Math.Algebras.VectorSpace
import Math.Algebras.TensorProduct
import Math.Algebras.Structures
import Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
data Interval a = Iv (Poset a) (a,a)
instance Eq a => Eq (Interval a) where
Iv _ (a :: a
a,b :: a
b) == :: Interval a -> Interval a -> Bool
== Iv _ (a' :: a
a',b' :: a
b') = (a
a,a
b) (a, a) -> (a, a) -> Bool
forall a. Eq a => a -> a -> Bool
== (a
a',a
b')
instance Ord a => Ord (Interval a) where
compare :: Interval a -> Interval a -> Ordering
compare (Iv _ (a :: a
a,b :: a
b)) (Iv _ (a' :: a
a',b' :: a
b')) = (a, a) -> (a, a) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a
a,a
b) (a
a',a
b')
instance Show a => Show (Interval a) where
show :: Interval a -> String
show (Iv _ (a :: a
a,b :: a
b)) = "Iv (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ "," String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
b String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")"
ivPoset :: Interval t -> Poset t
ivPoset (Iv poset :: Poset t
poset@(Poset (_,po :: t -> t -> Bool
po)) (x :: t
x,y :: t
y)) = ([t], t -> t -> Bool) -> Poset t
forall t. ([t], t -> t -> Bool) -> Poset t
Poset (Poset t -> (t, t) -> [t]
forall a. Poset a -> (a, a) -> [a]
interval Poset t
poset (t
x,t
y), t -> t -> Bool
po)
intervalIsos :: Interval a -> Interval b -> [[(a, b)]]
intervalIsos iv1 :: Interval a
iv1 iv2 :: Interval b
iv2 = Poset a -> Poset b -> [[(a, b)]]
forall a b. (Ord a, Ord b) => Poset a -> Poset b -> [[(a, b)]]
orderIsos (Interval a -> Poset a
forall t. Interval t -> Poset t
ivPoset Interval a
iv1) (Interval b -> Poset b
forall t. Interval t -> Poset t
ivPoset Interval b
iv2)
isIntervalIso :: Interval a -> Interval b -> Bool
isIntervalIso iv1 :: Interval a
iv1 iv2 :: Interval b
iv2 = Poset a -> Poset b -> Bool
forall a b. (Ord a, Ord b) => Poset a -> Poset b -> Bool
isOrderIso (Interval a -> Poset a
forall t. Interval t -> Poset t
ivPoset Interval a
iv1) (Interval b -> Poset b
forall t. Interval t -> Poset t
ivPoset Interval b
iv2)
intervalIsoMap :: Poset a -> Map (Interval a) (Maybe (Interval a))
intervalIsoMap poset :: Poset a
poset = Map (Interval a) (Maybe (Interval a))
isoMap
where ivs :: [Interval a]
ivs = [Poset a -> (a, a) -> Interval a
forall a. Poset a -> (a, a) -> Interval a
Iv Poset a
poset (a, a)
xy | (a, a)
xy <- Poset a -> [(a, a)]
forall b. Poset b -> [(b, b)]
intervals Poset a
poset]
isoMap :: Map (Interval a) (Maybe (Interval a))
isoMap = [(Interval a, Maybe (Interval a))]
-> Map (Interval a) (Maybe (Interval a))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Interval a
iv, Interval a -> Maybe (Interval a)
isoMap' Interval a
iv) | Interval a
iv <- [Interval a]
ivs]
isoMap' :: Interval a -> Maybe (Interval a)
isoMap' iv :: Interval a
iv = let reps :: [Interval a]
reps = [Interval a
iv' | Interval a
iv' <- [Interval a]
ivs, Interval a
iv' Interval a -> Interval a -> Bool
forall a. Ord a => a -> a -> Bool
< Interval a
iv, Map (Interval a) (Maybe (Interval a))
isoMap Map (Interval a) (Maybe (Interval a))
-> Interval a -> Maybe (Interval a)
forall k a. Ord k => Map k a -> k -> a
M.! Interval a
iv' Maybe (Interval a) -> Maybe (Interval a) -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe (Interval a)
forall a. Maybe a
Nothing, Interval a
iv Interval a -> Interval a -> Bool
forall a b. (Ord a, Ord b) => Interval a -> Interval b -> Bool
`isIntervalIso` Interval a
iv']
in if [Interval a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Interval a]
reps then Maybe (Interval a)
forall a. Maybe a
Nothing else let [rep :: Interval a
rep] = [Interval a]
reps in Interval a -> Maybe (Interval a)
forall a. a -> Maybe a
Just Interval a
rep
intervalIsoClasses :: (Ord a) => Poset a -> [Interval a]
intervalIsoClasses :: Poset a -> [Interval a]
intervalIsoClasses poset :: Poset a
poset = [Interval a
iv | Interval a
iv <- Map (Interval a) (Maybe (Interval a)) -> [Interval a]
forall k a. Map k a -> [k]
M.keys Map (Interval a) (Maybe (Interval a))
isoMap, Map (Interval a) (Maybe (Interval a))
isoMap Map (Interval a) (Maybe (Interval a))
-> Interval a -> Maybe (Interval a)
forall k a. Ord k => Map k a -> k -> a
M.! Interval a
iv Maybe (Interval a) -> Maybe (Interval a) -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe (Interval a)
forall a. Maybe a
Nothing]
where isoMap :: Map (Interval a) (Maybe (Interval a))
isoMap = Poset a -> Map (Interval a) (Maybe (Interval a))
forall a. Ord a => Poset a -> Map (Interval a) (Maybe (Interval a))
intervalIsoMap Poset a
poset
instance (Eq k, Num k, Ord a) => Algebra k (Interval a) where
unit :: k -> Vect k (Interval a)
unit 0 = Vect k (Interval a)
forall k b. Vect k b
zerov
mult :: Vect k (Tensor (Interval a) (Interval a)) -> Vect k (Interval a)
mult = (Tensor (Interval a) (Interval a) -> Vect k (Interval a))
-> Vect k (Tensor (Interval a) (Interval a)) -> Vect k (Interval a)
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear Tensor (Interval a) (Interval a) -> Vect k (Interval a)
forall a k.
(Eq a, Num k) =>
(Interval a, Interval a) -> Vect k (Interval a)
mult'
where mult' :: (Interval a, Interval a) -> Vect k (Interval a)
mult' (Iv poset :: Poset a
poset (a :: a
a,b :: a
b), Iv _ (c :: a
c,d :: a
d)) = if a
b a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
c then Interval a -> Vect k (Interval a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Poset a -> (a, a) -> Interval a
forall a. Poset a -> (a, a) -> Interval a
Iv Poset a
poset (a
a,a
d)) else Vect k (Interval a)
forall k b. Vect k b
zerov
unitIA :: (Eq k, Num k, Ord a) => Poset a -> Vect k (Interval a)
unitIA :: Poset a -> Vect k (Interval a)
unitIA poset :: Poset a
poset@(Poset (set :: [a]
set,_)) = [Vect k (Interval a)] -> Vect k (Interval a)
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [Interval a -> Vect k (Interval a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Poset a -> (a, a) -> Interval a
forall a. Poset a -> (a, a) -> Interval a
Iv Poset a
poset (a
x,a
x)) | a
x <- [a]
set]
basisIA :: Num k => Poset a -> [Vect k (Interval a)]
basisIA :: Poset a -> [Vect k (Interval a)]
basisIA poset :: Poset a
poset = [Interval a -> Vect k (Interval a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Poset a -> (a, a) -> Interval a
forall a. Poset a -> (a, a) -> Interval a
Iv Poset a
poset (a, a)
xy) | (a, a)
xy <- Poset a -> [(a, a)]
forall b. Poset b -> [(b, b)]
intervals Poset a
poset]
zetaIA :: (Eq k, Num k, Ord a) => Poset a -> Vect k (Interval a)
zetaIA :: Poset a -> Vect k (Interval a)
zetaIA poset :: Poset a
poset = [Vect k (Interval a)] -> Vect k (Interval a)
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv ([Vect k (Interval a)] -> Vect k (Interval a))
-> [Vect k (Interval a)] -> Vect k (Interval a)
forall a b. (a -> b) -> a -> b
$ Poset a -> [Vect k (Interval a)]
forall k a. Num k => Poset a -> [Vect k (Interval a)]
basisIA Poset a
poset
muIA1 :: Poset a -> Vect k (Interval a)
muIA1 poset :: Poset a
poset@(Poset (set :: [a]
set,po :: a -> a -> Bool
po)) = [Vect k (Interval a)] -> Vect k (Interval a)
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [(a, a) -> k
forall p. Num p => (a, a) -> p
mu (a
x,a
y) k -> Vect k (Interval a) -> Vect k (Interval a)
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> Interval a -> Vect k (Interval a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Poset a -> (a, a) -> Interval a
forall a. Poset a -> (a, a) -> Interval a
Iv Poset a
poset (a
x,a
y)) | a
x <- [a]
set, a
y <- [a]
set]
where mu :: (a, a) -> p
mu (x :: a
x,y :: a
y) | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y = 1
| a -> a -> Bool
po a
x a
y = p -> p
forall a. Num a => a -> a
negate (p -> p) -> p -> p
forall a b. (a -> b) -> a -> b
$ [p] -> p
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [(a, a) -> p
mu (a
x,a
z) | a
z <- [a]
set, a -> a -> Bool
po a
x a
z, a -> a -> Bool
po a
z a
y, a
z a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
y]
| Bool
otherwise = 0
muIA :: (Eq k, Num k, Ord a) => Poset a -> Vect k (Interval a)
muIA :: Poset a -> Vect k (Interval a)
muIA poset :: Poset a
poset@(Poset (set :: [a]
set,po :: a -> a -> Bool
po)) = [Vect k (Interval a)] -> Vect k (Interval a)
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [Map (a, a) k
forall a. Num a => Map (a, a) a
mus Map (a, a) k -> (a, a) -> k
forall k a. Ord k => Map k a -> k -> a
M.! (a
x,a
y) k -> Vect k (Interval a) -> Vect k (Interval a)
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> Interval a -> Vect k (Interval a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Poset a -> (a, a) -> Interval a
forall a. Poset a -> (a, a) -> Interval a
Iv Poset a
poset (a
x,a
y)) | a
x <- [a]
set, a
y <- [a]
set]
where mu :: (a, a) -> a
mu (x :: a
x,y :: a
y) | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y = 1
| a -> a -> Bool
po a
x a
y = a -> a
forall a. Num a => a -> a
negate (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Map (a, a) a
mus Map (a, a) a -> (a, a) -> a
forall k a. Ord k => Map k a -> k -> a
M.! (a
x,a
z) | a
z <- [a]
set, a -> a -> Bool
po a
x a
z, a -> a -> Bool
po a
z a
y, a
z a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
y]
| Bool
otherwise = 0
mus :: Map (a, a) a
mus = [((a, a), a)] -> Map (a, a) a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [((a
x,a
y), (a, a) -> a
mu (a
x,a
y)) | a
x <- [a]
set, a
y <- [a]
set]
invIA1 :: Vect a (Interval t) -> Vect a (Interval t)
invIA1 f :: Vect a (Interval t)
f | Vect a (Interval t)
f Vect a (Interval t) -> Vect a (Interval t) -> Bool
forall a. Eq a => a -> a -> Bool
== Vect a (Interval t)
forall k b. Vect k b
zerov = String -> Vect a (Interval t)
forall a. HasCallStack => String -> a
error "invIA 0"
| (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==0) [(t, t) -> a
f' (t
x,t
x) | t
x <- [t]
set] = String -> Vect a (Interval t)
forall a. HasCallStack => String -> a
error "invIA: not invertible"
| Bool
otherwise = Vect a (Interval t)
g
where (Iv poset :: Poset t
poset@(Poset (set :: [t]
set,po :: t -> t -> Bool
po)) _,_) = [(Interval t, a)] -> (Interval t, a)
forall a. [a] -> a
head ([(Interval t, a)] -> (Interval t, a))
-> [(Interval t, a)] -> (Interval t, a)
forall a b. (a -> b) -> a -> b
$ Vect a (Interval t) -> [(Interval t, a)]
forall k b. Vect k b -> [(b, k)]
terms Vect a (Interval t)
f
f' :: (t, t) -> a
f' (x :: t
x,y :: t
y) = Interval t -> Vect a (Interval t) -> a
forall k b. (Num k, Eq b) => b -> Vect k b -> k
coeff (Poset t -> (t, t) -> Interval t
forall a. Poset a -> (a, a) -> Interval a
Iv Poset t
poset (t
x,t
y)) Vect a (Interval t)
f
g :: Vect a (Interval t)
g = [Vect a (Interval t)] -> Vect a (Interval t)
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [(t, t) -> a
g' (t, t)
xy a -> Vect a (Interval t) -> Vect a (Interval t)
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> Interval t -> Vect a (Interval t)
forall (m :: * -> *) a. Monad m => a -> m a
return (Poset t -> (t, t) -> Interval t
forall a. Poset a -> (a, a) -> Interval a
Iv Poset t
poset (t, t)
xy) | (t, t)
xy <- Poset t -> [(t, t)]
forall b. Poset b -> [(b, b)]
intervals Poset t
poset]
g' :: (t, t) -> a
g' (x :: t
x,y :: t
y) | t
x t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
y = 1 a -> a -> a
forall a. Fractional a => a -> a -> a
/ (t, t) -> a
f' (t
x,t
x)
| Bool
otherwise = (-1 a -> a -> a
forall a. Fractional a => a -> a -> a
/ (t, t) -> a
f' (t
x,t
x)) a -> a -> a
forall a. Num a => a -> a -> a
* [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [(t, t) -> a
f' (t
x,t
z) a -> a -> a
forall a. Num a => a -> a -> a
* (t, t) -> a
g' (t
z,t
y) | t
z <- Poset t -> (t, t) -> [t]
forall a. Poset a -> (a, a) -> [a]
interval Poset t
poset (t
x,t
y), t
x t -> t -> Bool
forall a. Eq a => a -> a -> Bool
/= t
z]
invIA :: (Eq k, Fractional k, Ord a) => Vect k (Interval a) -> Maybe (Vect k (Interval a))
invIA :: Vect k (Interval a) -> Maybe (Vect k (Interval a))
invIA f :: Vect k (Interval a)
f | Vect k (Interval a)
f Vect k (Interval a) -> Vect k (Interval a) -> Bool
forall a. Eq a => a -> a -> Bool
== Vect k (Interval a)
forall k b. Vect k b
zerov = Maybe (Vect k (Interval a))
forall a. Maybe a
Nothing
| (k -> Bool) -> [k] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (k -> k -> Bool
forall a. Eq a => a -> a -> Bool
==0) [(a, a) -> k
f' (a
x,a
x) | a
x <- [a]
set] = Maybe (Vect k (Interval a))
forall a. Maybe a
Nothing
| Bool
otherwise = Vect k (Interval a) -> Maybe (Vect k (Interval a))
forall a. a -> Maybe a
Just Vect k (Interval a)
g
where (Iv poset :: Poset a
poset@(Poset (set :: [a]
set,po :: a -> a -> Bool
po)) _,_) = [(Interval a, k)] -> (Interval a, k)
forall a. [a] -> a
head ([(Interval a, k)] -> (Interval a, k))
-> [(Interval a, k)] -> (Interval a, k)
forall a b. (a -> b) -> a -> b
$ Vect k (Interval a) -> [(Interval a, k)]
forall k b. Vect k b -> [(b, k)]
terms Vect k (Interval a)
f
f' :: (a, a) -> k
f' (x :: a
x,y :: a
y) = Interval a -> Vect k (Interval a) -> k
forall k b. (Num k, Eq b) => b -> Vect k b -> k
coeff (Poset a -> (a, a) -> Interval a
forall a. Poset a -> (a, a) -> Interval a
Iv Poset a
poset (a
x,a
y)) Vect k (Interval a)
f
g :: Vect k (Interval a)
g = [Vect k (Interval a)] -> Vect k (Interval a)
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [(a, a) -> k
g' (a, a)
xy k -> Vect k (Interval a) -> Vect k (Interval a)
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> Interval a -> Vect k (Interval a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Poset a -> (a, a) -> Interval a
forall a. Poset a -> (a, a) -> Interval a
Iv Poset a
poset (a, a)
xy) | (a, a)
xy <- Poset a -> [(a, a)]
forall b. Poset b -> [(b, b)]
intervals Poset a
poset]
g' :: (a, a) -> k
g' (x :: a
x,y :: a
y) | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y = 1 k -> k -> k
forall a. Fractional a => a -> a -> a
/ (a, a) -> k
f' (a
x,a
x)
| Bool
otherwise = (-1 k -> k -> k
forall a. Fractional a => a -> a -> a
/ (a, a) -> k
f' (a
x,a
x)) k -> k -> k
forall a. Num a => a -> a -> a
* [k] -> k
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [(a, a) -> k
f' (a
x,a
z) k -> k -> k
forall a. Num a => a -> a -> a
* (Map (a, a) k
g's Map (a, a) k -> (a, a) -> k
forall k a. Ord k => Map k a -> k -> a
M.! (a
z,a
y)) | a
z <- Poset a -> (a, a) -> [a]
forall a. Poset a -> (a, a) -> [a]
interval Poset a
poset (a
x,a
y), a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
z]
g's :: Map (a, a) k
g's = [((a, a), k)] -> Map (a, a) k
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [((a, a)
xy, (a, a) -> k
g' (a, a)
xy) | (a, a)
xy <- Poset a -> [(a, a)]
forall b. Poset b -> [(b, b)]
intervals Poset a
poset]
instance (Eq k, Fractional k, Ord a, Show a) => HasInverses (Vect k (Interval a)) where
inverse :: Vect k (Interval a) -> Vect k (Interval a)
inverse f :: Vect k (Interval a)
f = case Vect k (Interval a) -> Maybe (Vect k (Interval a))
forall k a.
(Eq k, Fractional k, Ord a) =>
Vect k (Interval a) -> Maybe (Vect k (Interval a))
invIA Vect k (Interval a)
f of
Just g :: Vect k (Interval a)
g -> Vect k (Interval a)
g
Nothing -> String -> Vect k (Interval a)
forall a. HasCallStack => String -> a
error "IncidenceAlgebra.inverse: not invertible"
numChainsIA :: (Ord a, Show a) => Poset a -> Vect Q (Interval a)
numChainsIA :: Poset a -> Vect Q (Interval a)
numChainsIA poset :: Poset a
poset = (2 Q -> Vect Q (Interval a) -> Vect Q (Interval a)
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> Poset a -> Vect Q (Interval a)
forall k a. (Eq k, Num k, Ord a) => Poset a -> Vect k (Interval a)
unitIA Poset a
poset Vect Q (Interval a) -> Vect Q (Interval a) -> Vect Q (Interval a)
forall k b.
(Eq k, Num k, Ord b) =>
Vect k b -> Vect k b -> Vect k b
<-> Poset a -> Vect Q (Interval a)
forall k a. (Eq k, Num k, Ord a) => Poset a -> Vect k (Interval a)
zetaIA Poset a
poset)Vect Q (Interval a) -> Integer -> Vect Q (Interval a)
forall a b. (Num a, HasInverses a, Integral b) => a -> b -> a
^-1
etaIA :: Poset a -> Vect k (Interval a)
etaIA poset :: Poset a
poset = let DG vs :: [a]
vs es :: [(a, a)]
es = Poset a -> Digraph a
forall a. Eq a => Poset a -> Digraph a
hasseDigraph Poset a
poset
in [Vect k (Interval a)] -> Vect k (Interval a)
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [Interval a -> Vect k (Interval a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Poset a -> (a, a) -> Interval a
forall a. Poset a -> (a, a) -> Interval a
Iv Poset a
poset (a
x,a
y)) | (x :: a
x,y :: a
y) <- [(a, a)]
es]
numMaximalChainsIA :: (Ord a, Show a) => Poset a -> Vect Q (Interval a)
numMaximalChainsIA :: Poset a -> Vect Q (Interval a)
numMaximalChainsIA poset :: Poset a
poset = (Poset a -> Vect Q (Interval a)
forall k a. (Eq k, Num k, Ord a) => Poset a -> Vect k (Interval a)
unitIA Poset a
poset Vect Q (Interval a) -> Vect Q (Interval a) -> Vect Q (Interval a)
forall k b.
(Eq k, Num k, Ord b) =>
Vect k b -> Vect k b -> Vect k b
<-> Poset a -> Vect Q (Interval a)
forall k a. (Num k, Ord a, Eq k) => Poset a -> Vect k (Interval a)
etaIA Poset a
poset)Vect Q (Interval a) -> Integer -> Vect Q (Interval a)
forall a b. (Num a, HasInverses a, Integral b) => a -> b -> a
^-1
muC :: Int -> Vect k (Interval Int)
muC n :: Int
n = [Vect k (Interval Int)] -> Vect k (Interval Int)
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [(Int, Int) -> k
forall a p. (Eq a, Num p, Num a) => (a, a) -> p
mu' (Int
a,Int
b) k -> Vect k (Interval Int) -> Vect k (Interval Int)
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> Interval Int -> Vect k (Interval Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Poset Int -> (Int, Int) -> Interval Int
forall a. Poset a -> (a, a) -> Interval a
Iv Poset Int
poset (Int
a,Int
b)) | (a :: Int
a,b :: Int
b) <- Poset Int -> [(Int, Int)]
forall b. Poset b -> [(b, b)]
intervals Poset Int
poset]
where mu' :: (a, a) -> p
mu' (a :: a
a,b :: a
b) | a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b = 1
| a
aa -> a -> a
forall a. Num a => a -> a -> a
+1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b = -1
| Bool
otherwise = 0
poset :: Poset Int
poset = Int -> Poset Int
chainN Int
n
muB :: Int -> Vect k (Interval [Int])
muB n :: Int
n = [Vect k (Interval [Int])] -> Vect k (Interval [Int])
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [(-1)k -> Int -> k
forall a b. (Num a, Integral b) => a -> b -> a
^([Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
a) k -> Vect k (Interval [Int]) -> Vect k (Interval [Int])
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> Interval [Int] -> Vect k (Interval [Int])
forall (m :: * -> *) a. Monad m => a -> m a
return (Poset [Int] -> ([Int], [Int]) -> Interval [Int]
forall a. Poset a -> (a, a) -> Interval a
Iv Poset [Int]
poset ([Int]
a,[Int]
b)) | (a :: [Int]
a,b :: [Int]
b) <- Poset [Int] -> [([Int], [Int])]
forall b. Poset b -> [(b, b)]
intervals Poset [Int]
poset]
where poset :: Poset [Int]
poset = Int -> Poset [Int]
posetB Int
n
muL :: Int -> [a] -> Vect Int (Interval [[a]])
muL n :: Int
n fq :: [a]
fq = [Vect Int (Interval [[a]])] -> Vect Int (Interval [[a]])
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [ ( (-1)Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
qInt -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
*(Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2) ) Int -> Vect Int (Interval [[a]]) -> Vect Int (Interval [[a]])
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> Interval [[a]] -> Vect Int (Interval [[a]])
forall (m :: * -> *) a. Monad m => a -> m a
return (Poset [[a]] -> ([[a]], [[a]]) -> Interval [[a]]
forall a. Poset a -> (a, a) -> Interval a
Iv Poset [[a]]
poset ([[a]]
a,[[a]]
b)) |
(a :: [[a]]
a,b :: [[a]]
b) <- Poset [[a]] -> [([[a]], [[a]])]
forall b. Poset b -> [(b, b)]
intervals Poset [[a]]
poset,
let k :: Int
k = [[a]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]]
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- [[a]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]]
a ]
where q :: Int
q = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
fq
poset :: Poset [[a]]
poset = Int -> [a] -> Poset [[a]]
forall fq. (Eq fq, Num fq) => Int -> [fq] -> Poset [[fq]]
posetL Int
n [a]
fq
instance (Eq k, Num k, Ord a) => Coalgebra k (Interval a) where
counit :: Vect k (Interval a) -> k
counit = Vect k () -> k
forall k. Num k => Vect k () -> k
unwrap (Vect k () -> k)
-> (Vect k (Interval a) -> Vect k ()) -> Vect k (Interval a) -> k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Interval a -> Vect k ()) -> Vect k (Interval a) -> Vect k ()
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear Interval a -> Vect k ()
forall k a. (Num k, Eq k, Eq a) => Interval a -> Vect k ()
counit'
where counit' :: Interval a -> Vect k ()
counit' (Iv _ (x :: a
x,y :: a
y)) = (if a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y then 1 else 0) k -> Vect k () -> Vect k ()
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> () -> Vect k ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
comult :: Vect k (Interval a) -> Vect k (Tensor (Interval a) (Interval a))
comult = (Interval a -> Vect k (Tensor (Interval a) (Interval a)))
-> Vect k (Interval a) -> Vect k (Tensor (Interval a) (Interval a))
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear Interval a -> Vect k (Tensor (Interval a) (Interval a))
forall k a.
(Num k, Ord a, Eq k) =>
Interval a -> Vect k (Interval a, Interval a)
comult'
where comult' :: Interval a -> Vect k (Interval a, Interval a)
comult' (Iv poset :: Poset a
poset (x :: a
x,z :: a
z)) = [Vect k (Interval a, Interval a)]
-> Vect k (Interval a, Interval a)
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [(Interval a, Interval a) -> Vect k (Interval a, Interval a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Poset a -> (a, a) -> Interval a
forall a. Poset a -> (a, a) -> Interval a
Iv Poset a
poset (a
x,a
y), Poset a -> (a, a) -> Interval a
forall a. Poset a -> (a, a) -> Interval a
Iv Poset a
poset (a
y,a
z)) | a
y <- Poset a -> (a, a) -> [a]
forall a. Poset a -> (a, a) -> [a]
interval Poset a
poset (a
x,a
z)]
toIsoClasses :: (Eq k, Num k, Ord a) => Vect k (Interval a) -> Vect k (Interval a)
toIsoClasses :: Vect k (Interval a) -> Vect k (Interval a)
toIsoClasses v :: Vect k (Interval a)
v
| Vect k (Interval a)
v Vect k (Interval a) -> Vect k (Interval a) -> Bool
forall a. Eq a => a -> a -> Bool
== Vect k (Interval a)
forall k b. Vect k b
zerov = Vect k (Interval a)
forall k b. Vect k b
zerov
| Bool
otherwise = Poset a -> Vect k (Interval a) -> Vect k (Interval a)
forall k a.
(Eq k, Num k, Ord a) =>
Poset a -> Vect k (Interval a) -> Vect k (Interval a)
toIsoClasses' Poset a
poset Vect k (Interval a)
v
where (Iv poset :: Poset a
poset _, _) = [(Interval a, k)] -> (Interval a, k)
forall a. [a] -> a
head ([(Interval a, k)] -> (Interval a, k))
-> [(Interval a, k)] -> (Interval a, k)
forall a b. (a -> b) -> a -> b
$ Vect k (Interval a) -> [(Interval a, k)]
forall k b. Vect k b -> [(b, k)]
terms Vect k (Interval a)
v
toIsoClasses' :: (Eq k, Num k, Ord a) => Poset a -> Vect k (Interval a) -> Vect k (Interval a)
toIsoClasses' :: Poset a -> Vect k (Interval a) -> Vect k (Interval a)
toIsoClasses' poset :: Poset a
poset = (Interval a -> Vect k (Interval a))
-> Vect k (Interval a) -> Vect k (Interval a)
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear Interval a -> Vect k (Interval a)
forall (m :: * -> *). Monad m => Interval a -> m (Interval a)
isoRep
where isoRep :: Interval a -> m (Interval a)
isoRep iv :: Interval a
iv = case Map (Interval a) (Maybe (Interval a))
isoMap Map (Interval a) (Maybe (Interval a))
-> Interval a -> Maybe (Interval a)
forall k a. Ord k => Map k a -> k -> a
M.! Interval a
iv of
Nothing -> Interval a -> m (Interval a)
forall (m :: * -> *) a. Monad m => a -> m a
return Interval a
iv
Just iv' :: Interval a
iv' -> Interval a -> m (Interval a)
forall (m :: * -> *) a. Monad m => a -> m a
return Interval a
iv'
isoMap :: Map (Interval a) (Maybe (Interval a))
isoMap = Poset a -> Map (Interval a) (Maybe (Interval a))
forall a. Ord a => Poset a -> Map (Interval a) (Maybe (Interval a))
intervalIsoMap Poset a
poset