module Math.Combinatorics.Poset where
import Math.Common.ListSet as LS
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 = intervalPartitions xs in
map ([x]:) ips ++ [ (x:head):tail | (head:tail) <- ips]
subspaces fq n = [] : concatMap (flatsPG (n1) fq) [0..n1]
isSubspace s1 s2 = all (inSpanRE s2) s1
posetL :: 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
pairs (x:xs) = map (x,) xs ++ pairs xs
pairs [] = []
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