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