-- Copyright (c) 2011-2015, David Amos. All rights reserved.

{-# 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


-- INTERVALS IN A POSET

-- |A type to represent an interval in a poset. The (closed) interval [x,y] is the set {z | x <= z <= y} within the poset.
-- Note that the \"empty interval\" is not an interval - that is, the interval [x,y] is only defined for x <= y.
-- The (closed) intervals within a poset form a basis for the incidence algebra as a k-vector space.
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')
-- we don't bother to check that they are from the same poset

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]
++ ")"

{-
-- !! This should probably be called heightPartition not rank
-- rank is only well-defined if we don't have cover edges jumping levels
rankPartition (Iv poset@(Poset (set,po)) (a,b)) = rankPartition' S.empty [a] (L.delete a iv)
    where rankPartition' _ level [] = [level]
          rankPartition' interior boundary exterior =
              let interior' = S.union interior (S.fromList boundary)
                  boundary' = toSet [v | (u,v) <- es, u `elem` boundary, all (`S.member` interior') (predecessors es v)]
                  exterior' = exterior \\ boundary'
              in boundary : rankPartition' interior' boundary' exterior'
          iv = interval poset (a,b)
          (_,es) = coverGraph (Poset (iv,po))
          predecessors es v = [u | (u,v') <- es, v' == v]
-- !! Can be written more efficiently, eg by memoising predecessors and successors, culling covers as we use them, etc.

-- The point of rankPartition function is to enable a slightly faster isomorphism test
-- Could do even better by refining with (indegree, outdegree)
-}

-- The sub-poset defined by an interval
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)
-- we're only really interested in comparing intervals in the same poset

{-
intervalIsoMap1 poset = intervalIsoMap' M.empty [Iv poset xy | xy <- L.sort (intervals poset)]
    where intervalIsoMap' m (iv:ivs) =
              let reps = [iv' | iv' <- M.keys m, m M.! iv' == Nothing, iv `isIntervalIso` iv']
              in if null reps
                 then intervalIsoMap' (M.insert iv Nothing m) ivs
                 else let [iv'] = reps in intervalIsoMap' (M.insert iv (Just iv') m) ivs
          intervalIsoMap' m [] = m
-}

-- A poset on n vertices has at most n(n+1)/2 intervals
-- In the worst case, we might have to compare each interval to all earlier intervals
-- Hence this is O(n^4)
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
-- Once an interval is identified as a representative, it is likely to take part in many isomorphism tests
-- Whereas most intervals take part in only one
-- So perhaps we could make this more efficient by having an isomorphism test which uses a height partition
-- for the LHS but not for the RHS?

-- |List representatives of the order isomorphism classes of intervals in a poset
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 


-- INCIDENCE ALGEBRA

-- |The incidence algebra of a poset is the free k-vector space having as its basis the set of intervals in the poset,
-- with multiplication defined by concatenation of intervals.
-- The incidence algebra can also be thought of as the vector space of functions from intervals to k, with multiplication
-- defined by the convolution (f*g)(x,y) = sum [ f(x,z) g(z,y) | x <= z <= y ].
instance (Eq k, Num k, Ord a) => Algebra k (Interval a) where
    -- |Note that we are not able to give a generic definition of unit for the incidence algebra,
    -- because it depends on which poset we are working in,
    -- and that information is encoded at the value level rather than the type level. See unitIA.
    unit :: k -> Vect k (Interval a)
unit 0 = Vect k (Interval a)
forall k b. Vect k b
zerov -- so that sum works
    -- unit x = x *> sumv [return (Iv (a,a)) | a <- poset] -- the delta function
    -- but we can't know from the types alone which poset we are working in
    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

-- So multiplication in the incidence algebra is about composition of intervals


-- |The unit of the incidence algebra of a poset
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]

-- |The zeta function of 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

-- Then for example, zeta^2 counts the number of points in each interval
-- See Stanley, Enumerative Combinatorics I, p115ff, for more similar

-- calculate the mobius function of a poset: naive implementation
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

-- calculate the mobius function of a poset, with memoization
-- |The Mobius function of a poset
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] 

-- calculate the inverse of a function in the incidence algebra: naive implementation
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]

-- Stanley, Enumerative Combinatorics I, p144
-- |The inverse of an element in the incidence algebra of a poset.
-- This is only defined for elements which are non-zero on all intervals (x,x)
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 -- error "invIA 0"
        | (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 -- error "invIA: not invertible"
        | 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"

-- Then for example we can count multichains or chains using the incidence algebra - see Stanley

-- |A function (ie element of the incidence algebra) that counts the total number of chains in each interval
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

-- The eta function on intervals (x,y) is 1 if x -< y (y covers x), 0 otherwise
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]

-- |A function (ie element of the incidence algebra) that counts the number of maximal chains in each interval
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


-- In order to quickCheck this, we would need
-- (i) Custom Arbitrary instance - which uses only valid intervals for the poset (ie elts of the basis)
-- (ii) Custom quickCheck property, which uses the correct unit


-- SOME KNOWN MOBIUS FUNCTIONS

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
-- van Lint & Wilson p335

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 ] -- the difference in dimensions
    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
-- van Lint & Wilson p335


-- INCIDENCE COALGEBRA
-- Schmitt, Incidence Hopf Algebras

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)]

-- So comultiplication in the incidence coalgebra is about decomposition of intervals into subintervals


-- But for incidence Hopf algebras, Schmitt wants the basis elts to be isomorphism classes of intervals, not intervals themselves
-- (ie unlabelled intervals)

-- |@toIsoClasses@ is the linear map from the incidence Hopf algebra of a poset to itself,
-- in which each interval is mapped to (the minimal representative of) its isomorphism class.
-- Thus the result can be considered as a linear combination of isomorphism classes of intervals,
-- rather than of intervals themselves.
-- Note that if this operation is to be performed repeatedly for the same poset,
-- then it is more efficient to use @toIsoClasses' poset@, which memoizes the isomorphism class lookup table.
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

-- |Given a poset, @toIsoClasses' poset@ is the linear map from the incidence Hopf algebra of the poset to itself,
-- in which each interval is mapped to (the minimal representative of) its isomorphism class.
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


{-
-- for example:

> toIsoClasses $ zetaIA $ posetP 4
15Iv ([[1],[2],[3],[4]],[[1],[2],[3],[4]])+31Iv ([[1],[2],[3],[4]],[[1],[2],[3,4]])+10Iv ([[1],[2],[3],[4]],[[1],[2,3,4]])+3Iv ([[1],[2],[3],[4]],[[1,2],[3,4]])+Iv ([[1],[2],[3],[4]],[[1,2,3,4]])

-- Can we use this to solve "counting squares" problems

> let b3 = comult $ return $ Iv (posetB 3) ([],[1,2,3])
> let isoB3 = toIsoClasses' $ posetB 3
> (isoB3 `tf` isoB3) b3
(Iv ([],[]),Iv ([],[1,2,3]))+3(Iv ([],[1]),Iv ([],[1,2]))+3(Iv ([],[1,2]),Iv ([],[1]))+(Iv ([],[1,2,3]),Iv ([],[]))

-- The incidence coalgebra of the binomial poset is isomorphic to the binomial coalgebra

-- if we just want to get the coefficients, we don't need to use comult:

> let poset@(Poset (set,po)) = posetB 3 in toIsoClasses $ sumv [return (Iv poset ([],x)) | x <- set]
Iv ([],[])+3Iv ([],[1])+3Iv ([],[1,2])+Iv ([],[1,2,3])

> let n = 4; p  = comult $ return $ Iv (posetP n) ([[i] | i<- [1..n]],[[1..n]]); iso = toIsoClasses' (posetP n) in (iso `tf` iso) p
(Iv ([[1],[2],[3],[4]],[[1],[2],[3],[4]]),Iv ([[1],[2],[3],[4]],[[1,2,3,4]]))+
6(Iv ([[1],[2],[3],[4]],[[1],[2],[3,4]]),Iv ([[1],[2],[3],[4]],[[1],[2,3,4]]))+
4(Iv ([[1],[2],[3],[4]],[[1],[2,3,4]]),Iv ([[1],[2],[3],[4]],[[1],[2],[3,4]]))+
3(Iv ([[1],[2],[3],[4]],[[1,2],[3,4]]),Iv ([[1],[2],[3],[4]],[[1],[2],[3,4]]))+
(Iv ([[1],[2],[3],[4]],[[1,2,3,4]]),Iv ([[1],[2],[3],[4]],[[1],[2],[3],[4]]))

-- These are multinomial coefficients, OEIS A178867: 1; 1,1; 1,3,1; 1,6,4,3,1; 1,10,10,15,5,10,1; ...
-- Although A036040, which is the same up to ordering, seems a better match. (Our order is fairly arbitrary)

> let n = 4; p  = comult $ return $ Iv (posetL n f2) ([],[[1 :: F2,0,0,0],[0,1,0,0],[0,0,1,0],[0,0,0,1]]); iso = toIsoClasses' (posetL n f2) in (iso `tf` iso) p
(Iv ([],[]),Iv ([],[[1,0,0,0],[0,1,0,0],[0,0,1,0],[0,0,0,1]]))+
15(Iv ([],[[0,0,0,1]]),Iv ([],[[0,1,0,0],[0,0,1,0],[0,0,0,1]]))+
35(Iv ([],[[0,0,1,0],[0,0,0,1]]),Iv ([],[[0,0,1,0],[0,0,0,1]]))+
15(Iv ([],[[0,1,0,0],[0,0,1,0],[0,0,0,1]]),Iv ([],[[0,0,0,1]]))+
(Iv ([],[[1,0,0,0],[0,1,0,0],[0,0,1,0],[0,0,0,1]]),Iv ([],[]))

-- With L n fq, we get the q-binomial coefficients, eg OEIS A022166:
1; 1, 1; 1, 3, 1; 1, 7, 7, 1; 1, 15, 35, 15, 1
-}


-- This still isn't quite what Schmitt wants
-- Schmitt, IHA, p6
-- The incidence Hopf algebra should have as its basis isomorphism classes of intervals, not intervals
-- The mult is defined as direct product of posets