1+ {-# LANGUAGE TupleSections #-}
2+
3+ module Autotool.Data.Graph (Graph , mkGraph , mkI , mkK , mkP , mkC , kante , neighbours , complement , join , add , subgraph , isCircle , Color (.. )) where
4+
5+ import Data.Set (fromList , Set , toList , (\\) , notMember )
6+ import qualified Data.Set as S
7+ import Data.Maybe (mapMaybe )
8+
9+ -- FIXME: a graph may need a Name for output!
10+ type Graph a = (Set a , Set (a ,a ))
11+
12+ -- constructors
13+
14+ mkGraph :: (Ord a ) => [a ] -> [(a ,a )] -> Graph a
15+ mkGraph vs es = (fromList vs, fromList es)
16+
17+ kante :: (Ord a ) => a -> a -> (a ,a )
18+ kante = (,)
19+
20+ mkI :: Int -> Graph Int
21+ mkI n = mkGraph [1 .. n] []
22+
23+ mkK :: Int -> Graph Int
24+ mkK n = let vs = [1 .. n] in mkGraph vs (allEdges vs)
25+
26+ mkP :: Int -> Graph Int
27+ mkP n = let vs = [1 .. n] in mkGraph vs (zip vs $ drop 1 vs)
28+
29+ mkC :: Int -> Graph Int
30+ mkC n = let vs = [1 .. n] in mkGraph vs ((n,1 ): zip vs (drop 1 vs))
31+
32+ -- operations
33+
34+ neighbours :: (Eq a ) => Graph a -> a -> [a ]
35+ neighbours (vs, es) v = mapMaybe f (toList es) where
36+ f (a,b)
37+ | a == v = Just b
38+ | b == v = Just a
39+ | otherwise = Nothing
40+
41+ complement :: (Ord a ) => Graph a -> Graph a
42+ complement (vs, es) = let esAll = fromList $ allEdges (toList vs) in (vs, diff esAll es)
43+ where diff ea eb = S. filter (\ (a,b) -> (a,b) `notMember` eb && (b,a) `notMember` eb) ea
44+
45+ -- TODO: make join take a rename function
46+ join :: (Ord a , Num a ) => Graph a -> Graph a -> Graph a
47+ join g@ (vs, es) h@ (hs,_) = (S. union vs vs', edges) where
48+ (vs', es') = rename renameF h
49+ edges = fromList $ concatMap (\ v -> map (,v) (toList vs')) (toList vs)
50+ maxV = S. findMax vs
51+ minV' = S. findMin hs
52+ renameF = if maxV >= minV' then (+ maxV) else id
53+
54+ add :: (Ord a , Num a ) => Graph a -> Graph a -> Graph a
55+ add (vs, es) h@ (hs,_) = (S. union vs vs', S. union es es') where
56+ (vs', es') = rename renameF h
57+ maxV = S. findMax vs
58+ minV' = S. findMin hs
59+ renameF = if maxV >= minV' then (+ maxV) else id
60+
61+ subgraph :: (Ord a ) => Graph a -> [a ] -> Graph a
62+ subgraph (vs, es) vs' = (fromList vs', es') where
63+ es' = S. filter (\ (a,b) -> a `elem` vs' && b `elem` vs') es
64+
65+ isCircle :: (Eq a ) => Graph a -> Bool
66+ isCircle g@ (vs, es) = length vs == length es && all ((== 2 ) . degree g) (toList vs)
67+
68+ degree :: (Eq a ) => Graph a -> a -> Int
69+ degree (_, es) v = length $ S. filter (\ (a,b) -> a == v || b == v) es
70+
71+ -- utility functions
72+
73+ allEdges :: [a ] -> [(a ,a )]
74+ allEdges [a,b] = [(a,b)]
75+ allEdges (v: vs) = allEdges vs ++ concatMap (allEdges . (: [v])) vs
76+ allEdges _ = []
77+
78+ rename :: (Ord a , Ord b ) => (a -> b ) -> Graph a -> Graph b
79+ rename f (vs, es) = (vs', es') where
80+ vs' = S. map f vs
81+ es' = S. map f' es
82+ f' (a,b) = (f a, f b)
83+
84+ -- Colors
85+
86+ data Color = A | B | C | D | E | F deriving (Eq , Ord , Enum , Show )
0 commit comments