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


-- |A module defining a type for hypergraphs.

module Math.Combinatorics.Hypergraph where

import qualified Data.List as L
import Math.Common.ListSet
import Math.Core.Utils (combinationsOf)
import Math.Combinatorics.Graph hiding (incidenceMatrix)
import Math.Algebra.Group.PermutationGroup (orbitB, p) -- needed for construction of Coxeter group


-- not used in this module, only in GHCi

import Math.Algebra.Field.Base
import Math.Algebra.Field.Extension
import Math.Combinatorics.Design hiding (incidenceMatrix, incidenceGraph, dual, isSubset, fanoPlane)


-- set system or hypergraph

data Hypergraph a = H [a] [[a]] deriving (Hypergraph a -> Hypergraph a -> Bool
(Hypergraph a -> Hypergraph a -> Bool)
-> (Hypergraph a -> Hypergraph a -> Bool) -> Eq (Hypergraph a)
forall a. Eq a => Hypergraph a -> Hypergraph a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Hypergraph a -> Hypergraph a -> Bool
$c/= :: forall a. Eq a => Hypergraph a -> Hypergraph a -> Bool
== :: Hypergraph a -> Hypergraph a -> Bool
$c== :: forall a. Eq a => Hypergraph a -> Hypergraph a -> Bool
Eq,Eq (Hypergraph a)
Eq (Hypergraph a) =>
(Hypergraph a -> Hypergraph a -> Ordering)
-> (Hypergraph a -> Hypergraph a -> Bool)
-> (Hypergraph a -> Hypergraph a -> Bool)
-> (Hypergraph a -> Hypergraph a -> Bool)
-> (Hypergraph a -> Hypergraph a -> Bool)
-> (Hypergraph a -> Hypergraph a -> Hypergraph a)
-> (Hypergraph a -> Hypergraph a -> Hypergraph a)
-> Ord (Hypergraph a)
Hypergraph a -> Hypergraph a -> Bool
Hypergraph a -> Hypergraph a -> Ordering
Hypergraph a -> Hypergraph a -> Hypergraph a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Hypergraph a)
forall a. Ord a => Hypergraph a -> Hypergraph a -> Bool
forall a. Ord a => Hypergraph a -> Hypergraph a -> Ordering
forall a. Ord a => Hypergraph a -> Hypergraph a -> Hypergraph a
min :: Hypergraph a -> Hypergraph a -> Hypergraph a
$cmin :: forall a. Ord a => Hypergraph a -> Hypergraph a -> Hypergraph a
max :: Hypergraph a -> Hypergraph a -> Hypergraph a
$cmax :: forall a. Ord a => Hypergraph a -> Hypergraph a -> Hypergraph a
>= :: Hypergraph a -> Hypergraph a -> Bool
$c>= :: forall a. Ord a => Hypergraph a -> Hypergraph a -> Bool
> :: Hypergraph a -> Hypergraph a -> Bool
$c> :: forall a. Ord a => Hypergraph a -> Hypergraph a -> Bool
<= :: Hypergraph a -> Hypergraph a -> Bool
$c<= :: forall a. Ord a => Hypergraph a -> Hypergraph a -> Bool
< :: Hypergraph a -> Hypergraph a -> Bool
$c< :: forall a. Ord a => Hypergraph a -> Hypergraph a -> Bool
compare :: Hypergraph a -> Hypergraph a -> Ordering
$ccompare :: forall a. Ord a => Hypergraph a -> Hypergraph a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Hypergraph a)
Ord,Int -> Hypergraph a -> ShowS
[Hypergraph a] -> ShowS
Hypergraph a -> String
(Int -> Hypergraph a -> ShowS)
-> (Hypergraph a -> String)
-> ([Hypergraph a] -> ShowS)
-> Show (Hypergraph a)
forall a. Show a => Int -> Hypergraph a -> ShowS
forall a. Show a => [Hypergraph a] -> ShowS
forall a. Show a => Hypergraph a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Hypergraph a] -> ShowS
$cshowList :: forall a. Show a => [Hypergraph a] -> ShowS
show :: Hypergraph a -> String
$cshow :: forall a. Show a => Hypergraph a -> String
showsPrec :: Int -> Hypergraph a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Hypergraph a -> ShowS
Show)

hypergraph :: [a] -> [[a]] -> Hypergraph a
hypergraph xs :: [a]
xs bs :: [[a]]
bs | [a] -> [[a]] -> Bool
forall a. Ord a => [a] -> [[a]] -> Bool
isSetSystem [a]
xs [[a]]
bs = [a] -> [[a]] -> Hypergraph a
forall a. [a] -> [[a]] -> Hypergraph a
H [a]
xs [[a]]
bs

toHypergraph :: [a] -> [[a]] -> Hypergraph a
toHypergraph xs :: [a]
xs bs :: [[a]]
bs = [a] -> [[a]] -> Hypergraph a
forall a. [a] -> [[a]] -> Hypergraph a
H [a]
xs' [[a]]
bs' where
    xs' :: [a]
xs' = [a] -> [a]
forall a. Ord a => [a] -> [a]
L.sort [a]
xs
    bs' :: [[a]]
bs' = [[a]] -> [[a]]
forall a. Ord a => [a] -> [a]
L.sort ([[a]] -> [[a]]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ ([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> [a]
forall a. Ord a => [a] -> [a]
L.sort [[a]]
bs
-- this still doesn't guarantee that all bs are subset of xs



-- |Is this hypergraph uniform - meaning that all blocks are of the same size

isUniform :: (Ord a) => Hypergraph a -> Bool
isUniform :: Hypergraph a -> Bool
isUniform h :: Hypergraph a
h@(H xs :: [a]
xs bs :: [[a]]
bs) = [a] -> [[a]] -> Bool
forall a. Ord a => [a] -> [[a]] -> Bool
isSetSystem [a]
xs [[a]]
bs Bool -> Bool -> Bool
&& [Int] -> Bool
forall a. Eq a => [a] -> Bool
same (([a] -> Int) -> [[a]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]]
bs)

same :: [a] -> Bool
same (x :: a
x:xs :: [a]
xs) = (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
x) [a]
xs
same [] = Bool
True



fromGraph :: Graph a -> Hypergraph a
fromGraph (G vs :: [a]
vs es :: [[a]]
es) = [a] -> [[a]] -> Hypergraph a
forall a. [a] -> [[a]] -> Hypergraph a
H [a]
vs [[a]]
es
fromDesign :: Design a -> Hypergraph a
fromDesign (D xs :: [a]
xs bs :: [[a]]
bs) = [a] -> [[a]] -> Hypergraph a
forall a. [a] -> [[a]] -> Hypergraph a
H [a]
xs ([[a]] -> [[a]]
forall a. Ord a => [a] -> [a]
L.sort [[a]]
bs)
-- !! should insist that designs have blocks in order

-- !! dual probably doesn't guarantee this at present


{-
dual (H xs bs) = toHypergraph (bs, map beta xs) where
    beta x = filter (x `elem`) bs
-}



-- INCIDENCE GRAPH


-- data Incidence a = P a | B [a] deriving (Eq, Ord, Show)


-- compare Design, where we just use Left, Right


-- Also called the Levi graph

incidenceGraph :: (Ord a) => Hypergraph a -> Graph (Either a [a])
incidenceGraph :: Hypergraph a -> Graph (Either a [a])
incidenceGraph (H xs :: [a]
xs bs :: [[a]]
bs) = [Either a [a]] -> [[Either a [a]]] -> Graph (Either a [a])
forall a. [a] -> [[a]] -> Graph a
G [Either a [a]]
vs [[Either a [a]]]
es where
    vs :: [Either a [a]]
vs = (a -> Either a [a]) -> [a] -> [Either a [a]]
forall a b. (a -> b) -> [a] -> [b]
map a -> Either a [a]
forall a b. a -> Either a b
Left [a]
xs [Either a [a]] -> [Either a [a]] -> [Either a [a]]
forall a. [a] -> [a] -> [a]
++ ([a] -> Either a [a]) -> [[a]] -> [Either a [a]]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> Either a [a]
forall a b. b -> Either a b
Right [[a]]
bs
    es :: [[Either a [a]]]
es = [[Either a [a]]] -> [[Either a [a]]]
forall a. Ord a => [a] -> [a]
L.sort [ [a -> Either a [a]
forall a b. a -> Either a b
Left a
x, [a] -> Either a [a]
forall a b. b -> Either a b
Right [a]
b] | [a]
b <- [[a]]
bs, a
x <- [a]
b]


-- INCIDENCE MATRIX


-- !! why are we doing this the other way round to the literature ??



-- incidence matrix of a hypergraph

-- (rows and columns indexed by edges and vertices respectively)

-- (warning: in the literature it is often the other way round)

incidenceMatrix :: Hypergraph a -> [[a]]
incidenceMatrix (H vs :: [a]
vs es :: [[a]]
es) = [ [if a
v a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
e then 1 else 0 | a
v <- [a]
vs] | [a]
e <- [[a]]
es]

fromIncidenceMatrix :: [[a]] -> Hypergraph a
fromIncidenceMatrix m :: [[a]]
m = [a] -> [[a]] -> Hypergraph a
forall a. [a] -> [[a]] -> Hypergraph a
H [a]
vs [[a]]
es where
    n :: a
n = [a] -> a
forall i a. Num i => [a] -> i
L.genericLength ([a] -> a) -> [a] -> a
forall a b. (a -> b) -> a -> b
$ [[a]] -> [a]
forall a. [a] -> a
head [[a]]
m
    vs :: [a]
vs = [1..a
n]
    es :: [[a]]
es = [[a]] -> [[a]]
forall a. Ord a => [a] -> [a]
L.sort ([[a]] -> [[a]]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ ([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> [a]
forall a. (Eq a, Num a) => [a] -> [a]
edge [[a]]
m
    edge :: [a] -> [a]
edge row :: [a]
row = [a
v | (1,v :: a
v) <- [a] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
row [a]
vs]




-- isTwoGraph



-- We can represent various incidence structures as hypergraphs,

-- by identifying the lines with the sets of points that they contain


isPartialLinearSpace :: (Ord a) => Hypergraph a -> Bool
isPartialLinearSpace :: Hypergraph a -> Bool
isPartialLinearSpace h :: Hypergraph a
h@(H ps :: [a]
ps ls :: [[a]]
ls) =
    [a] -> [[a]] -> Bool
forall a. Ord a => [a] -> [[a]] -> Bool
isSetSystem [a]
ps [[a]]
ls Bool -> Bool -> Bool
&&
    ([[a]] -> Bool) -> [[[a]]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ( (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=1) (Int -> Bool) -> ([[a]] -> Int) -> [[a]] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[a]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ) [([a] -> Bool) -> [[a]] -> [[a]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([a]
pair [a] -> [a] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
`isSubset`) [[a]]
ls | [a]
pair <- Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
combinationsOf 2 [a]
ps]
    -- any two points are incident with at most one line


-- Godsil & Royle, p79

-- |Is this hypergraph a projective plane - meaning that any two lines meet in a unique point,

-- and any two points lie on a unique line

isProjectivePlane :: (Ord a) => Hypergraph a -> Bool
isProjectivePlane :: Hypergraph a -> Bool
isProjectivePlane h :: Hypergraph a
h@(H ps :: [a]
ps ls :: [[a]]
ls) =
    [a] -> [[a]] -> Bool
forall a. Ord a => [a] -> [[a]] -> Bool
isSetSystem [a]
ps [[a]]
ls Bool -> Bool -> Bool
&&
    ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ( (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==1) (Int -> Bool) -> ([a] -> Int) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) [[a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
intersect [a]
l1 [a]
l2 | [l1 :: [a]
l1,l2 :: [a]
l2] <- Int -> [[a]] -> [[[a]]]
forall a. Int -> [a] -> [[a]]
combinationsOf 2 [[a]]
ls] Bool -> Bool -> Bool
&& -- any two lines meet in a unique point

    ([[a]] -> Bool) -> [[[a]]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ( (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==1) (Int -> Bool) -> ([[a]] -> Int) -> [[a]] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[a]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) [ ([a] -> Bool) -> [[a]] -> [[a]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([a
p1,a
p2] [a] -> [a] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
`isSubset`) [[a]]
ls | [p1 :: a
p1,p2 :: a
p2] <- Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
combinationsOf 2 [a]
ps] -- any two points lie in a unique line


-- |Is this hypergraph a projective plane with a triangle.

-- This is a weak non-degeneracy condition, which eliminates all points on the same line, or all lines through the same point.

isProjectivePlaneTri :: (Ord a) => Hypergraph a -> Bool
isProjectivePlaneTri :: Hypergraph a -> Bool
isProjectivePlaneTri h :: Hypergraph a
h@(H ps :: [a]
ps ls :: [[a]]
ls) =
    Hypergraph a -> Bool
forall a. Ord a => Hypergraph a -> Bool
isProjectivePlane Hypergraph a
h Bool -> Bool -> Bool
&& ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any [a] -> Bool
triangle (Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
combinationsOf 3 [a]
ps)
    where triangle :: [a] -> Bool
triangle t :: [a]
t@[p1 :: a
p1,p2 :: a
p2,p3 :: a
p3] =
                   (Bool -> Bool
not (Bool -> Bool) -> ([[a]] -> Bool) -> [[a]] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[a]
l | [a]
l <- [[a]]
ls, [a
p1,a
p2] [a] -> [a] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
`isSubset` [a]
l, a
p3 a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [a]
l] Bool -> Bool -> Bool
&& -- there is a line containing p1,p2 but not p3

                   (Bool -> Bool
not (Bool -> Bool) -> ([[a]] -> Bool) -> [[a]] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[a]
l | [a]
l <- [[a]]
ls, [a
p1,a
p3] [a] -> [a] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
`isSubset` [a]
l, a
p2 a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [a]
l] Bool -> Bool -> Bool
&&
                   (Bool -> Bool
not (Bool -> Bool) -> ([[a]] -> Bool) -> [[a]] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[a]
l | [a]
l <- [[a]]
ls, [a
p2,a
p3] [a] -> [a] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
`isSubset` [a]
l, a
p1 a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [a]
l] 

-- |Is this hypergraph a projective plane with a quadrangle.

-- This is a stronger non-degeneracy condition.

isProjectivePlaneQuad :: (Ord a) => Hypergraph a -> Bool
isProjectivePlaneQuad :: Hypergraph a -> Bool
isProjectivePlaneQuad h :: Hypergraph a
h@(H ps :: [a]
ps ls :: [[a]]
ls) =
    Hypergraph a -> Bool
forall a. Ord a => Hypergraph a -> Bool
isProjectivePlane Hypergraph a
h Bool -> Bool -> Bool
&& ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any [a] -> Bool
quadrangle (Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
combinationsOf 4 [a]
ps)
    where quadrangle :: [a] -> Bool
quadrangle q :: [a]
q = ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
collinear) (Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
combinationsOf 3 [a]
q) -- no three points collinear

          collinear :: [a] -> Bool
collinear ps :: [a]
ps = ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([a]
ps [a] -> [a] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
`isSubset`) [[a]]
ls


-- > isProjectivePlaneQuad $ fromDesign $ pg2 f2

-- True



-- GENERALIZED QUADRANGLES


-- Godsil & Royle p81

isGeneralizedQuadrangle :: (Ord a) => Hypergraph a -> Bool
isGeneralizedQuadrangle :: Hypergraph a -> Bool
isGeneralizedQuadrangle h :: Hypergraph a
h@(H ps :: [a]
ps ls :: [[a]]
ls) =
    Hypergraph a -> Bool
forall a. Ord a => Hypergraph a -> Bool
isPartialLinearSpace Hypergraph a
h Bool -> Bool -> Bool
&&
    (([a], a) -> Bool) -> [([a], a)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(l :: [a]
l,p :: a
p) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
unique [a
p' | a
p' <- [a]
l, [a] -> Bool
collinear (a -> a -> [a]
forall a. Ord a => a -> a -> [a]
pair a
p a
p')]) [([a]
l,a
p) | [a]
l <- [[a]]
ls, a
p <- [a]
ps, a
p a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [a]
l] Bool -> Bool -> Bool
&&
    -- given any line l and point p not on l, there is a unique point p' on l with p and p' collinear

    ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
collinear) ([a] -> [[a]]
forall a. [a] -> [[a]]
powerset [a]
ps) Bool -> Bool -> Bool
&& -- there are non collinear points

    ([[a]] -> Bool) -> [[[a]]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> ([[a]] -> Bool) -> [[a]] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[a]] -> Bool
forall (t :: * -> *) (t :: * -> *).
(Foldable t, Foldable t) =>
t (t a) -> Bool
concurrent) ([[a]] -> [[[a]]]
forall a. [a] -> [[a]]
powerset [[a]]
ls) -- there are non concurrent lines

    where unique :: t a -> Bool
unique xs :: t a
xs = t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1
          pair :: a -> a -> [a]
pair x :: a
x y :: a
y = if a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
y then [a
x,a
y] else [a
y,a
x]
          collinear :: [a] -> Bool
collinear ps :: [a]
ps = ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([a]
ps [a] -> [a] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
`isSubset`) [[a]]
ls
          concurrent :: t (t a) -> Bool
concurrent ls :: t (t a)
ls = (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\p :: a
p -> (t a -> Bool) -> t (t a) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a
p a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) t (t a)
ls) [a]
ps


grid :: a -> b -> Hypergraph (a, b)
grid m :: a
m n :: b
n = [(a, b)] -> [[(a, b)]] -> Hypergraph (a, b)
forall a. [a] -> [[a]] -> Hypergraph a
H [(a, b)]
ps [[(a, b)]]
ls where
    ps :: [(a, b)]
ps = [(a
i,b
j) | a
i <- [1..a
m], b
j <- [1..b
n] ]
    ls :: [[(a, b)]]
ls = [[(a, b)]] -> [[(a, b)]]
forall a. Ord a => [a] -> [a]
L.sort ([[(a, b)]] -> [[(a, b)]]) -> [[(a, b)]] -> [[(a, b)]]
forall a b. (a -> b) -> a -> b
$ [ [(a
i,b
j) | a
i <- [1..a
m] ] | b
j <- [1..b
n] ] -- horizontal lines

               [[(a, b)]] -> [[(a, b)]] -> [[(a, b)]]
forall a. [a] -> [a] -> [a]
++ [ [(a
i,b
j) | b
j <- [1..b
n] ] | a
i <- [1..a
m] ] -- vertical lines


dualGrid :: a -> a -> Hypergraph a
dualGrid m :: a
m n :: a
n = Graph a -> Hypergraph a
forall a. Graph a -> Hypergraph a
fromGraph (Graph a -> Hypergraph a) -> Graph a -> Hypergraph a
forall a b. (a -> b) -> a -> b
$ a -> a -> Graph a
forall t. Integral t => t -> t -> Graph t
kb a
m a
n
-- the lines of the grid are the points of the dual, and the points of the grid are the lines of the dual


isGenQuadrangle' :: Hypergraph a -> Bool
isGenQuadrangle' h :: Hypergraph a
h = Graph (Either a [a]) -> Int
forall t. Ord t => Graph t -> Int
diameter Graph (Either a [a])
g Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 4 Bool -> Bool -> Bool
&& Graph (Either a [a]) -> Int
forall t. Eq t => Graph t -> Int
girth Graph (Either a [a])
g Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 8 -- !! plus non-degeneracy conditions

    where g :: Graph (Either a [a])
g = Hypergraph a -> Graph (Either a [a])
forall a. Ord a => Hypergraph a -> Graph (Either a [a])
incidenceGraph Hypergraph a
h


-- CONFIGURATIONS


-- http://en.wikipedia.org/wiki/Projective_configuration

-- |Is this hypergraph a (projective) configuration.

isConfiguration :: (Ord a) => Hypergraph a -> Bool
isConfiguration :: Hypergraph a -> Bool
isConfiguration h :: Hypergraph a
h@(H ps :: [a]
ps ls :: [[a]]
ls) =
    Hypergraph a -> Bool
forall a. Ord a => Hypergraph a -> Bool
isUniform Hypergraph a
h Bool -> Bool -> Bool
&& -- a set system, with each line incident with the same number of points

    [Int] -> Bool
forall a. Eq a => [a] -> Bool
same [[[a]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (([a] -> Bool) -> [[a]] -> [[a]]
forall a. (a -> Bool) -> [a] -> [a]
filter (a
p a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) [[a]]
ls) | a
p <- [a]
ps] -- each point is incident with the same number of lines



fanoPlane :: Hypergraph Integer
fanoPlane :: Hypergraph Integer
fanoPlane = [Integer] -> [[Integer]] -> Hypergraph Integer
forall a. Ord a => [a] -> [[a]] -> Hypergraph a
toHypergraph [1..7] [[1,2,4],[2,3,5],[3,4,6],[4,5,7],[5,6,1],[6,7,2],[7,1,3]]

-- |The Heawood graph is the incidence graph of the Fano plane

heawoodGraph :: Graph (Either Integer [Integer])
heawoodGraph :: Graph (Either Integer [Integer])
heawoodGraph = Hypergraph Integer -> Graph (Either Integer [Integer])
forall a. Ord a => Hypergraph a -> Graph (Either a [a])
incidenceGraph Hypergraph Integer
fanoPlane


desarguesConfiguration :: Hypergraph [Integer]
desarguesConfiguration :: Hypergraph [Integer]
desarguesConfiguration = [[Integer]] -> [[[Integer]]] -> Hypergraph [Integer]
forall a. [a] -> [[a]] -> Hypergraph a
H [[Integer]]
xs [[[Integer]]]
bs where
    xs :: [[Integer]]
xs = Int -> [Integer] -> [[Integer]]
forall a. Int -> [a] -> [[a]]
combinationsOf 2 [1..5]
    bs :: [[[Integer]]]
bs = [ [[Integer]
x | [Integer]
x <- [[Integer]]
xs, [Integer]
x [Integer] -> [Integer] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
`isSubset` [Integer]
b] | [Integer]
b <- Int -> [Integer] -> [[Integer]]
forall a. Int -> [a] -> [[a]]
combinationsOf 3 [1..5] ]

desarguesGraph :: Graph (Either [Integer] [[Integer]])
desarguesGraph :: Graph (Either [Integer] [[Integer]])
desarguesGraph = Hypergraph [Integer] -> Graph (Either [Integer] [[Integer]])
forall a. Ord a => Hypergraph a -> Graph (Either a [a])
incidenceGraph Hypergraph [Integer]
desarguesConfiguration


pappusConfiguration :: Hypergraph Integer
pappusConfiguration :: Hypergraph Integer
pappusConfiguration = [Integer] -> [[Integer]] -> Hypergraph Integer
forall a. [a] -> [[a]] -> Hypergraph a
H [Integer]
xs [[Integer]]
bs where
    xs :: [Integer]
xs = [1..9]
    bs :: [[Integer]]
bs = [[Integer]] -> [[Integer]]
forall a. Ord a => [a] -> [a]
L.sort [ [1,2,3], [4,5,6], [7,8,9], [1,5,9], [1,6,8], [2,4,9], [3,4,8], [2,6,7], [3,5,7] ]

pappusGraph :: Graph (Either Integer [Integer])
pappusGraph :: Graph (Either Integer [Integer])
pappusGraph = Hypergraph Integer -> Graph (Either Integer [Integer])
forall a. Ord a => Hypergraph a -> Graph (Either a [a])
incidenceGraph Hypergraph Integer
pappusConfiguration



-- !! no particular reason why the following is here rather than elsewhere

{-
triples = combinationsOf 3 [1..7]

heptads = [ [a,b,c,d,e,f,g] | a <- triples,
                              b <- triples, a < b, meetOne b a,
                              c <- triples, b < c, all (meetOne c) [a,b],
                              d <- triples, c < d, all (meetOne d) [a,b,c],
                              e <- triples, d < e, all (meetOne e) [a,b,c,d],
                              f <- triples, e < f, all (meetOne f) [a,b,c,d,e],
                              g <- triples, f < g, all (meetOne g) [a,b,c,d,e,f],
                              foldl intersect [1..7] [a,b,c,d,e,f,g] == [] ]
    where meetOne x y = length (intersect x y) == 1
    -- each pair of triples meet in exactly one point, and there is no point in all of them - Godsil & Royle p69
    -- (so these are the projective planes over 7 points)
-}
-- Godsil & Royle p69

coxeterGraph :: Graph [Integer]
coxeterGraph :: Graph [Integer]
coxeterGraph = [[Integer]] -> [[[Integer]]] -> Graph [Integer]
forall a. [a] -> [[a]] -> Graph a
G [[Integer]]
vs [[[Integer]]]
es where
    g :: Permutation Integer
g = [[Integer]] -> Permutation Integer
forall a. Ord a => [[a]] -> Permutation a
p [[1..7]]
    vs :: [[Integer]]
vs = [[Integer]] -> [[Integer]]
forall a. Ord a => [a] -> [a]
L.sort ([[Integer]] -> [[Integer]]) -> [[Integer]] -> [[Integer]]
forall a b. (a -> b) -> a -> b
$ ([Integer] -> [[Integer]]) -> [[Integer]] -> [[Integer]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Permutation Integer] -> [Integer] -> [[Integer]]
forall a. Ord a => [Permutation a] -> [a] -> [[a]]
orbitB [Permutation Integer
g]) [[1,2,4],[3,5,7],[3,6,7],[5,6,7]]
    es :: [[[Integer]]]
es = [ [[Integer]]
e | e :: [[Integer]]
e@[v1 :: [Integer]
v1,v2 :: [Integer]
v2] <- Int -> [[Integer]] -> [[[Integer]]]
forall a. Int -> [a] -> [[a]]
combinationsOf 2 [[Integer]]
vs, [Integer] -> [Integer] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
disjoint [Integer]
v1 [Integer]
v2]

-- is this the incidence graph of a hypergraph involving heptads over triples?



-- edges of K6

duads :: [[Integer]]
duads = Int -> [Integer] -> [[Integer]]
forall a. Int -> [a] -> [[a]]
combinationsOf 2 [1..6]

-- 1-factors of K6

-- 15 different ways to pick three disjoint duads from [1..6]

synthemes :: [[[Integer]]]
synthemes = [ [[Integer]
d1,[Integer]
d2,[Integer]
d3] | [Integer]
d1 <- [[Integer]]
duads,
                           [Integer]
d2 <- [[Integer]]
duads, [Integer]
d2 [Integer] -> [Integer] -> Bool
forall a. Ord a => a -> a -> Bool
> [Integer]
d1, [Integer] -> [Integer] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
disjoint [Integer]
d1 [Integer]
d2,
                           [Integer]
d3 <- [[Integer]]
duads, [Integer]
d3 [Integer] -> [Integer] -> Bool
forall a. Ord a => a -> a -> Bool
> [Integer]
d2, [Integer] -> [Integer] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
disjoint [Integer]
d1 [Integer]
d3, [Integer] -> [Integer] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
disjoint [Integer]
d2 [Integer]
d3 ]

-- |The Tutte-Coxeter graph, also called the Tutte 8-cage

tutteCoxeterGraph :: Graph (Either [Integer] [[Integer]])
tutteCoxeterGraph :: Graph (Either [Integer] [[Integer]])
tutteCoxeterGraph = Hypergraph [Integer] -> Graph (Either [Integer] [[Integer]])
forall a. Ord a => Hypergraph a -> Graph (Either a [a])
incidenceGraph (Hypergraph [Integer] -> Graph (Either [Integer] [[Integer]]))
-> Hypergraph [Integer] -> Graph (Either [Integer] [[Integer]])
forall a b. (a -> b) -> a -> b
$ [[Integer]] -> [[[Integer]]] -> Hypergraph [Integer]
forall a. [a] -> [[a]] -> Hypergraph a
H [[Integer]]
duads [[[Integer]]]
synthemes


-- Also known as line graph

intersectionGraph :: Hypergraph a -> Graph [a]
intersectionGraph (H xs :: [a]
xs bs :: [[a]]
bs) = [[a]] -> [[[a]]] -> Graph [a]
forall a. [a] -> [[a]] -> Graph a
G [[a]]
vs [[[a]]]
es where
    vs :: [[a]]
vs = [[a]]
bs
    es :: [[[a]]]
es = [[[a]]
pair | pair :: [[a]]
pair@[b1 :: [a]
b1,b2 :: [a]
b2] <- Int -> [[a]] -> [[[a]]]
forall a. Int -> [a] -> [[a]]
combinationsOf 2 [[a]]
bs, Bool -> Bool
not ([a] -> [a] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
disjoint [a]
b1 [a]
b2)]