module Math.Combinatorics.Graph where
import qualified Data.List as L
import Data.Maybe (isJust)
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Arrow ( (&&&) )
import Math.Common.ListSet
import Math.Algebra.Group.PermutationGroup
import Math.Algebra.Group.SchreierSims as SS
set xs = map head $ L.group $ L.sort xs
powerset [] = [[]]
powerset (x:xs) = let p = powerset xs in p ++ map (x:) p
combinationsOf :: (Integral t) => t -> [a] -> [[a]]
combinationsOf 0 _ = [[]]
combinationsOf _ [] = []
combinationsOf k (x:xs) | k > 0 = map (x:) (combinationsOf (k1) xs) ++ combinationsOf k xs
data Graph a = G [a] [[a]] deriving (Eq,Ord,Show)
isSetSystem xs bs = isListSet xs && isListSet bs && all isListSet bs && all (`isSubset` xs) bs
isGraph vs es = isSetSystem vs es && all ( (==2) . length) es
graph (vs,es) | isGraph vs es = G vs es
toGraph (vs,es) | isGraph vs' es' = G vs' es' where
vs' = L.sort vs
es' = L.sort $ map L.sort es
vertices (G vs _) = vs
edges (G _ es) = es
incidenceMatrix (G vs es) = [ [if v `elem` e then 1 else 0 | v <- vs] | e <- es]
fromIncidenceMatrix m = graph (vs,es) where
n = L.genericLength $ head m
vs = [1..n]
es = L.sort $ map edge m
edge row = [v | (1,v) <- zip row vs]
adjacencyMatrix (G vs es) =
[ [if L.sort [i,j] `S.member` es' then 1 else 0 | j <- vs] | i <- vs]
where es' = S.fromList es
fromAdjacencyMatrix m = graph (vs,es) where
n = L.genericLength m
vs = [1..n]
es = es' 1 m
es' i (r:rs) = [ [i,j] | (j,1) <- drop i (zip vs r)] ++ es' (i+1) rs
es' _ [] = []
nullGraph :: Graph Int
nullGraph = G [] []
c :: (Integral t) => t -> Graph t
c n = graph (vs,es) where
vs = [1..n]
es = L.insert [1,n] [[i,i+1] | i <- [1..n1]]
k :: (Integral t) => t -> Graph t
k n = graph (vs,es) where
vs = [1..n]
es = [[i,j] | i <- [1..n1], j <- [i+1..n]]
kb m n = to1n $ kb' m n
kb' m n = graph (vs,es) where
vs = map Left [1..m] ++ map Right [1..n]
es = [ [Left i, Right j] | i <- [1..m], j <- [1..n] ]
q' k = graph (vs,es) where
vs = sequence $ replicate k [0,1]
es = [ [u,v] | [u,v] <- combinationsOf 2 vs, hammingDistance u v == 1 ]
hammingDistance as bs = length $ filter id $ zipWith (/=) as bs
q k = gmap (\v -> v <.> pows2) (q' k) where
pows2 = reverse $ take k $ iterate (*2) 1
u <.> v = sum $ zipWith (*) u v
gmap f (G vs es) = G (map f vs) ((map . map) f es)
tetrahedron = k 4
cube = q 3
octahedron = graph (vs,es) where
vs = [1..6]
es = combinationsOf 2 vs L.\\ [[1,6],[2,5],[3,4]]
dodecahedron = toGraph (vs,es) where
vs = [1..20]
es = [ [1,2],[2,3],[3,4],[4,5],[5,1],
[6,7],[7,8],[8,9],[9,10],[10,11],[11,12],[12,13],[13,14],[14,15],[15,6],
[16,17],[17,18],[18,19],[19,20],[20,16],
[1,6],[2,8],[3,10],[4,12],[5,14],
[7,16],[9,17],[11,18],[13,19],[15,20] ]
icosahedron = toGraph (vs,es) where
vs = [1..12]
es = [ [1,2],[1,3],[1,4],[1,5],[1,6],
[2,3],[3,4],[4,5],[5,6],[6,2],
[7,12],[8,12],[9,12],[10,12],[11,12],
[7,8],[8,9],[9,10],[10,11],[11,7],
[2,7],[7,3],[3,8],[8,4],[4,9],[9,5],[5,10],[10,6],[6,11],[11,2] ]
to1n (G vs es) = graph (vs',es') where
mapping = M.fromList $ zip vs [1..]
vs' = M.elems mapping
es' = [map (mapping M.!) e | e <- es]
fromDigits :: Integral a => Graph [a] -> Graph a
fromDigits (G vs es) = graph (vs',es') where
vs' = map fromDigits' vs
es' = (map . map) fromDigits' es
fromDigits' xs = f (reverse xs) where
f (x:xs) = x + 10 * f xs
f [] = 0
petersen = graph (vs,es) where
vs = combinationsOf 2 [1..5]
es = [ [v1,v2] | [v1,v2] <- combinationsOf 2 vs, disjoint v1 v2]
complement (G vs es) = graph (vs,es') where es' = combinationsOf 2 vs \\ es
lineGraph g = to1n $ lineGraph' g
lineGraph' (G vs es) = graph (es, [ [ei,ej] | ei <- es, ej <- dropWhile (<= ei) es, ei `intersect` ej /= [] ])
order g = length (vertices g)
size g = length (edges g)
valency (G vs es) v = length $ filter (v `elem`) es
valencies g@(G vs es) = map (head &&& length) $ L.group $ L.sort $ map (valency g) vs
regularParam g =
case valencies g of
[(v,_)] -> Just v
_ -> Nothing
isRegular g = isJust $ regularParam g
isCubic g = regularParam g == Just 3
nbrs (G vs es) v = [u | [u,v'] <- es, v == v']
++ [w | [v',w] <- es, v == v']
findPaths g@(G vs es) x y = map reverse $ bfs [ [x] ] where
bfs ((z:zs) : nodes)
| z == y = (z:zs) : bfs nodes
| otherwise = bfs (nodes ++ [(w:z:zs) | w <- nbrs g z, w `notElem` zs])
bfs [] = []
distance g x y =
case findPaths g x y of
[] -> 1
p:ps -> length p 1
diameter g@(G vs es)
| isConnected g = maximum $ map maxDistance vs
| otherwise = 1
where maxDistance v = length (distancePartition g v) 1
findCycles g@(G vs es) x = [reverse (x:z:zs) | z:zs <- bfs [ [x] ], z `elem` nbrsx, length zs > 1] where
nbrsx = nbrs g x
bfs ((z:zs) : nodes) = (z:zs) : bfs (nodes ++ [ w:z:zs | w <- nbrs g z, w `notElem` zs])
bfs [] = []
girth g@(G vs es) = minimum' $ map minCycle vs where
minimum' xs = let (zs,nzs) = L.partition (==0) xs in if null nzs then 1 else minimum nzs
minCycle v = case findCycles g v of
[] -> 0
c:cs -> length c 1
distancePartition g v = distancePartition' S.empty (S.singleton v) where
distancePartition' interior boundary
| S.null boundary = []
| otherwise = let interior' = S.union interior boundary
boundary' = foldl S.union S.empty [S.fromList (nbrs g x) | x <- S.toList boundary] S.\\ interior'
in S.toList boundary : distancePartition' interior' boundary'
component g v = concat $ distancePartition g v
isConnected g@(G (v:vs) es) = length (component g v) == length (v:vs)
isConnected (G [] []) = True
j v k i | v >= k && k >= i
= graph (vs,es) where
vs = combinationsOf k [1..v]
es = [ [v1,v2] | [v1,v2] <- combinationsOf 2 vs, length (v1 `intersect` v2) == i ]
kneser n k | 2*k <= n = graph (vs,es) where
vs = combinationsOf k [1..n]
es = [ [v1,v2] | [v1,v2] <- combinationsOf 2 vs, disjoint v1 v2]
johnson v k | v >= 2*k = j v k (k1)
bipartiteKneser n k | 2*k < n = graph (vs,es) where
vs = map Left (combinationsOf k [1..n])
++ map Right (combinationsOf (nk) [1..n])
es = [ [Left u, Right v] | u <- combinationsOf k [1..n], v <- combinationsOf (nk) [1..n], u `isSubset` v]
desargues1 = bipartiteKneser 5 2
gp n k | 2*k < n = toGraph (vs,es) where
vs = map Left [0..n1] ++ map Right [0..n1]
es = (map . map) Left [ [i, (i+1) `mod` n] | i <- [0..n1] ]
++ [ [Left i, Right i] | i <- [0..n1] ]
++ (map . map) Right [ [i, (i+k) `mod` n] | i <- [0..n1] ]
petersen2 = gp 5 2
prism n = gp n 1
durer = gp 6 2
mobiusKantor = gp 8 3
dodecahedron2 = gp 10 2
desargues2 = gp 10 3