module Math.Combinatorics.Poset where
import Math.Common.ListSet as LS
import Math.Core.Utils
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
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]
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"
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]
chainN :: Int -> Poset Int
chainN n = Poset ( [1..n], (<=) )
antichainN :: Int -> Poset Int
antichainN n = Poset ( [1..n], (==) )
divides a b = b `mod` a == 0
divisors n | n >= 1 = [a | a <- [1..n], a `divides` n]
posetD :: Int -> Poset Int
posetD n | n >= 1 = Poset ( divisors n, divides )
powerset [] = [[]]
powerset (x:xs) = let p = powerset xs in p ++ map (x:) p
posetB :: Int -> Poset [Int]
posetB n = Poset ( powerset [1..n], LS.isSubset )
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]
isRefinement a b = and [or [acell `isSubset` bcell | bcell <- b] | acell <- a]
posetP :: Int -> Poset [[Int]]
posetP n = Poset ( partitions [1..n], isRefinement )
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 = intervalPartitions2 xs in
map ([x]:) ips ++ [ (x:head):tail | (head:tail) <- ips]
integerPartitions1 n = ips (reverse [1..n]) n
where ips [] 0 = [[]]
ips [] _ = []
ips (x:xs) n | x > n = ips xs n
| otherwise = map (x:) (ips (x:xs) (nx)) ++ ips xs n
integerPartitions n = dfs ([],n,n)
where dfs (xs, 0, _) = [reverse xs]
dfs (xs, r, i) = concatMap dfs [ (i':xs, ri', i') | i' <- reverse [1..min r i] ]
isIPRefinement ys xs = dfs xs ys
where dfs (x:xs) (y:ys) | x < y = False
| x == y = dfs xs ys
| otherwise = or [dfs xs' ys' | y' <- y:ys, let ys' = L.delete y' (y:ys),
let xs' = insertDesc (xy') xs]
dfs [] [] = True
insertDesc = L.insertBy (flip compare)
posetIP :: Int -> Poset [Int]
posetIP n = Poset (integerPartitions n, isIPRefinement)
subspaces fq n = [] : concatMap (flatsPG (n1) fq) [0..n1]
isSubspace s1 s2 = all (inSpanRE s2) s1
posetL :: (Eq fq, FiniteField fq) => Int -> [fq] -> Poset [[fq]]
posetL n fq = Poset ( subspaces fq n, isSubspace )
subposet :: Poset a -> (a -> Bool) -> Poset a
subposet (Poset (set,po)) p = Poset (filter p set, po)
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
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) )
dual :: Poset a -> Poset a
dual (Poset (set, po)) = Poset (set, po')
where po' x y = po y x
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]
reachabilityPoset :: (Ord a) => Digraph a -> Poset a
reachabilityPoset (DG vs es) = Poset (vs,tc')
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]
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 ]
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 ] ]
isOrderIso :: (Eq a, Eq b) => Poset a -> Poset b -> Bool
isOrderIso poseta posetb = (not . null) (orderIsos01 poseta posetb)
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 ] ]
orderAuts1 poset = orderIsos poset poset
isLinext (Poset (set,po)) set' = all (\(x,y) -> not (y `po` x)) (pairs set')
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