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

{-# LANGUAGE NoMonomorphismRestriction, TupleSections #-}


module Math.Combinatorics.Poset where

import Math.Common.ListSet as LS -- set operations on strictly ascending lists
import Math.Algebra.Field.Base
import Math.Combinatorics.FiniteGeometry
import Math.Algebra.LinearAlgebra

import Math.Combinatorics.Digraph

import Data.List as L
import qualified Data.Map as M
-- import qualified Data.Set as S


-- |A poset is represented as a pair (set,po), where set is the underlying set of the poset, and po is the partial order relation
newtype Poset t = Poset ([t], t -> t -> Bool)

instance Eq t => Eq (Poset t) where
    Poset (set,po) == Poset (set',po') =
        set == set' && and [po x y == po' x y | x <- set, y <- set]
-- There may be ways to avoid comparing every pair
-- If we could calculate the coverGraph without comparing every pair,
-- then it would be sufficient to test whether their cover graphs are equal

instance Show t => Show (Poset t) where
    show (Poset (set,po)) = "Poset " ++ show set

implies p q = q || not p

isReflexive (set,po) = and [x `po` x | x <- set]
isAntisymmetric (set,po) = and [((x `po` y) && (y `po` x)) `implies` (x == y) | x <- set, y <- set]
isTransitive (set,po) = and [((x `po` y) && (y `po` z)) `implies` (x `po` z) | x <- set, y <- set, z <- set]

isPoset poset = isReflexive poset && isAntisymmetric poset && isTransitive poset
    
poset (set,po)
    | isPoset (set,po) = Poset (set,po)
    | otherwise = error "poset: Not a partial order"


-- Most of the posets we will deal with are in fact lattices, meaning that any two elements
-- have a meet (greatest lower bound) and join (least upper bound)

intervals (Poset (set,po)) = [(a,b) | a <- set, b <- set, a `po` b]

interval (Poset (set,po)) (x,z) = [y | y <- set, x `po` y, y `po` z]


-- LINEAR ORDER POSET
-- This is of course a lattice, with meet = min, join = max

-- |A chain is a poset in which every pair of elements is comparable (ie either x <= y or y <= x).
-- It is therefore a linear or total order.
-- chainN n is the poset consisting of the numbers [1..n] ordered by (<=)
chainN :: Int -> Poset Int
chainN n = Poset ( [1..n], (<=) )

-- hasseN n = DG [1..n] [(i,i+1) | i <- [1..n-1]]


-- |An antichain is a poset in which distinct elements are incomparable.
-- antichainN n is the poset consisting of [1..n], with x <= y only when x == y.
antichainN :: Int -> Poset Int
antichainN n = Poset ( [1..n], (==) )


-- LATTICE OF (POSITIVE) DIVISORS OF N

divides a b = b `mod` a == 0

divisors n | n >= 1 = [a | a <- [1..n], a `divides` n]

-- |posetD n is the lattice of (positive) divisors of n
posetD :: Int -> Poset Int
posetD n | n >= 1 = Poset ( divisors n, divides )


-- LATTICE OF SUBSETS OF [1..N] ORDERED BY INCLUSION
-- (Boolean lattice)

powerset [] = [[]]
powerset (x:xs) = let p = powerset xs in p ++ map (x:) p

{-
-- subset test for sorted lists
isSubset (x:xs) (y:ys) =
    case compare x y of
    LT -> False
    EQ -> isSubset xs ys
    GT -> isSubset (x:xs) ys
isSubset [] _ = True
isSubset _ [] = False
-}

-- |posetB n is the lattice of subsets of [1..n] ordered by inclusion
posetB :: Int -> Poset [Int]
posetB n = Poset ( powerset [1..n], LS.isSubset )


-- LATTICE OF PARTITIONS OF [1..N] ORDERED BY REFINEMENT

partitions [] = [[]]
partitions [x] = [[[x]]]
partitions (x:xs) = let ps = partitions xs in
    map ([x]:) ps ++ [ (x:cell):(L.delete cell p) | p <- ps, cell <- p]
-- if the input is sorted, then so is the output

isRefinement a b = and [or [acell `isSubset` bcell | bcell <- b] | acell <- a]
-- if we know that a and b are appropriately sorted, then this can probably be done more efficiently

-- |posetP n is the lattice of partitions of [1..n] ordered by refinement
posetP :: Int -> Poset [[Int]]
posetP n = Poset ( partitions [1..n], isRefinement )

-- muP n = ...
-- see van Lint and Wilson p336


-- LATTICE OF INTERVAL PARTITIONS OF [1..N] ORDERED BY REFINEMENT

intervalPartitions xs = filter (all isInterval) (partitions xs)

isInterval (x1:x2:xs) = x1+1 == x2 && isInterval (x2:xs)
isInterval _ = True

intervalPartitions2 [] = [[]]
intervalPartitions2 [x] = [[[x]]]
intervalPartitions2 (x:xs) = let ips = intervalPartitions xs in
    map ([x]:) ips ++ [ (x:head):tail | (head:tail) <- ips]
-- we're guaranteed that x+1 is at the head of the head


-- LATTICE OF SUBSPACES OF Fq^n

subspaces fq n = [] : concatMap (flatsPG (n-1) fq) [0..n-1]
-- note that flatsPG returns the subspaces as a matrix of row vectors in reduced row echelon form

-- inSpanRE m v returns whether the vector v is in the span of the matrix m, where m is required to be in row echelon form
isSubspace s1 s2 = all (inSpanRE s2) s1

-- This is the projective geometry PG(n,q)
-- |posetL n fq is the lattice of subspaces of the vector space Fq^n, ordered by inclusion.
-- Subspaces are represented by their reduced row echelon form.
posetL :: FiniteField fq => Int -> [fq] -> Poset [[fq]]
posetL n fq = Poset ( subspaces fq n, isSubspace ) 


-- choose n k = product [n-k+1..n] `div` product [1..k]


-- NEW FROM OLD CONSTRUCTIONS


-- |The subposet of a poset satisfying a predicate
subposet :: Poset a -> (a -> Bool) -> Poset a
subposet (Poset (set,po)) p = Poset (filter p set, po)

-- |The direct sum of two posets
dsum :: Poset a -> Poset b -> Poset (Either a b)
dsum (Poset (setA,poA)) (Poset (setB,poB)) = Poset (set,po)
    where set = map Left setA ++ map Right setB
          po (Left a1) (Left a2) = poA a1 a2
          po (Right b1) (Right b2) = poB b1 b2
          po _ _ = False

-- |The direct product of two posets
dprod :: Poset a -> Poset b -> Poset (a,b)
dprod (Poset (setA,poA)) (Poset (setB,poB)) =
    Poset ( [(a,b) | a <- setA, b <- setB], \(a1,b1) (a2,b2) -> (a1 `poA` a2) && (b1 `poB` b2) )

-- |The dual of a poset
dual :: Poset a -> Poset a
dual (Poset (set, po)) = Poset (set, po')
    where po' x y = po y x


-- ANALYSIS OF POSETS

-- |Given a poset (X,<=), we say that y covers x, written x -< y, if x < y and there is no z in X with x < z < y.
-- The Hasse digraph of a poset is the digraph whose vertices are the elements of the poset,
-- with an edge between every pair (x,y) with x -< y.
-- The Hasse digraph can be represented diagrammatically as a Hasse diagram, by drawing x below y whenever x -< y.
hasseDigraph :: (Eq a) => Poset a -> Digraph a
hasseDigraph (Poset (set,po)) = DG set [(x,y) | x <- set, y <- set, x -< y]
    where x -< y = x /= y && x `po` y && null [z | z <- set, x `po` z, x /= z, z `po` y, z /= y]
-- The partial order can be recovered as the transitive closure of the covers relation
-- !! Can we construct the cover graph without having to compare every pair ??

-- If we know in advance the poset we're interested in,
-- then we're probably better off constructing the Hasse digraph directly

-- (In effect, the transitive closure of the edge relation)
-- |Given a DAG (directed acyclic graph), return the poset consisting of the vertices of the DAG, ordered by reachability.
-- This can be used to recover a poset from its Hasse digraph.
reachabilityPoset :: (Ord a) => Digraph a -> Poset a
reachabilityPoset (DG vs es) = Poset (vs,tc') -- \u v -> tc M.! (u,v)
    where tc = M.fromList [ ((u,v), tc' u v) | u <- vs, v <- vs]
          tc' u v | u == v = True
                  | otherwise = or [tc M.! (w,v) | w <- successors u]
          successors u = [v | (u',v) <- es, u' == u]
-- !! looks like we could memoise more than we are doing


{-
-- For example:
> let poset = posetB 3 in poset == reachabilityPoset (hasseDigraph poset)
True
-}


isOrderPreserving :: (a -> b) -> Poset a -> Poset b -> Bool
isOrderPreserving f (Poset (seta,poa)) (Poset (setb,pob)) =
    and [ x `poa` y == f x `pob` f y | x <- seta, y <- seta ]

-- Find all order isomorphisms between two posets
-- This algorithm is faster to find out whether or not there are any
orderIsos01 (Poset (seta,poa)) (Poset (setb,pob))
    | length seta /= length setb = []
    | otherwise = orderIsos' [] seta setb
    where orderIsos' xys [] [] = [xys]
          orderIsos' xys (x:xs) ys =
              concat [ orderIsos' ((x,y):xys) xs (L.delete y ys)
                     | y <- ys, and [ (x `poa` x', x' `poa` x) == (y `pob` y', y' `pob` y) | (x',y') <- xys ] ]

-- |Are the two posets order-isomorphic?
isOrderIso :: (Eq a, Eq b) => Poset a -> Poset b -> Bool
isOrderIso poseta posetb = (not . null) (orderIsos01 poseta posetb)

-- Find all order isomorphisms between two posets
-- This algorithm is faster to find all isomorphisms, if there are many
-- (It may be that it is faster to find any, for large posets, but the break-even point seems to be quite big)
orderIsos posetA@(Poset (_,poa)) posetB@(Poset (_,pob))
    | map length heightPartA /= map length heightPartB = []
    | otherwise = dfs [] heightPartA heightPartB
    where heightPartA = heightPartitionDAG (hasseDigraph posetA)
          heightPartB = heightPartitionDAG (hasseDigraph posetB)
          dfs xys [] [] = [xys]
          dfs xys ([]:las) ([]:lbs) = dfs xys las lbs
          dfs xys ((x:xs):las) (ys:lbs) =
              concat [ dfs ((x,y):xys) (xs:las) (L.delete y ys : lbs)
                     | y <- ys, and [ (x `poa` x', x' `poa` x) == (y `pob` y', y' `pob` y) | (x',y') <- xys ] ]
-- A variant on this algorithm would use the Hasse digraph rather than the partial order in the test on the last line
-- This might be faster, depending how expensive the partial order comparison function is
-- In effect though, it would then be a DAG isomorphism function

-- The order automorphisms of a poset
orderAuts1 poset = orderIsos poset poset
-- This returns all automorphisms
-- What we really want is to return generators of the permutation group





pairs (x:xs) = map (x,) xs ++ pairs xs -- TupleSections
pairs [] = []

-- |A linear extension of a poset is a linear ordering of the elements which extends the partial order.
-- Equivalently, it is an ordering [x1..xn] of the underlying set, such that if xi <= xj then i <= j.
isLinext (Poset (set,po)) set' = all (\(x,y) -> not (y `po` x)) (pairs set')


-- |Linear extensions of a poset
linexts (Poset (set,po)) = linexts' [[]] set
    where linexts' lss (r:rs) =
              let lss' = [ lts ++ [r] ++ gts
                         | ls <- lss,
                           let ls' = takeWhile (not . (r `po`)) ls,
                           (lts,gts) <- zip (inits ls') (tails ls),
                           all (not . (`po` r)) gts ]
              in linexts' lss' rs
          linexts' lss [] = lss