module Data.Graph.Graph where
import Control.Monad (replicateM)
import Data.List (foldl')
import Data.Maybe (fromMaybe)
import System.Random
import Data.Hashable
import qualified Data.HashMap.Lazy as HM
import Test.QuickCheck
import Data.Graph.Types
newtype Graph v e = Graph { unGraph :: HM.HashMap v (Links v e) }
deriving (Eq, Show)
instance (Arbitrary v, Arbitrary e, Hashable v, Num v, Ord v)
=> Arbitrary (Graph v e) where
arbitrary = insertEdges <$> arbitrary <*> pure empty
randomGraphIO :: Int -> IO (Graph Int ())
randomGraphIO n = replicateM n randRow
>>= (\m -> return $ fromMaybe empty (fromAdjacencyMatrix m))
where randRow = replicateM n (randomRIO (0,1)) :: IO [Int]
empty :: (Hashable v) => Graph v e
empty = Graph HM.empty
insertVertex :: (Hashable v, Eq v) => v -> Graph v e -> Graph v e
insertVertex v (Graph g) = Graph $ hashMapInsert v HM.empty g
removeVertex :: (Hashable v, Eq v) => v -> Graph v e -> Graph v e
removeVertex v g = Graph
$ (\(Graph g') -> HM.delete v g')
$ foldl' (flip removeEdge) g $ incidentEdges g v
insertVertices :: (Hashable v, Eq v) => [v] -> Graph v e -> Graph v e
insertVertices vs g = foldl' (flip insertVertex) g vs
insertEdge :: (Hashable v, Eq v) => Edge v e -> Graph v e -> Graph v e
insertEdge (Edge v1 v2 edgeAttr) g = Graph $ link v2 v1 $ link v1 v2 g'
where
g' = unGraph $ insertVertices [v1, v2] g
link fromV toV = HM.adjust (insertLink toV edgeAttr) fromV
insertEdges :: (Hashable v, Eq v) => [Edge v e] -> Graph v e -> Graph v e
insertEdges as g = foldl' (flip insertEdge) g as
removeEdge :: (Hashable v, Eq v) => Edge v e -> Graph v e -> Graph v e
removeEdge = removeEdge' . toUnorderedPair
removeEdge' :: (Hashable v, Eq v) => (v, v) -> Graph v e -> Graph v e
removeEdge' (v1, v2) graph@(Graph g)
| containsVertex graph v1 && containsVertex graph v2 =
Graph $ update v2Links v2 $ update v1Links v1 g
| otherwise = Graph g
where
v1Links = HM.delete v2 $ getLinks v1 g
v2Links = HM.delete v1 $ getLinks v2 g
update = HM.adjust . const
removeEdgeAndVertices :: (Hashable v, Eq v) => Edge v e -> Graph v e -> Graph v e
removeEdgeAndVertices = removeEdgeAndVertices' . toUnorderedPair
removeEdgeAndVertices' :: (Hashable v, Eq v) => (v, v) -> Graph v e -> Graph v e
removeEdgeAndVertices' (v1, v2) g =
removeVertex v2 $ removeVertex v1 $ removeEdge' (v1, v2) g
vertices :: Graph v e -> [v]
vertices (Graph g) = HM.keys g
order :: Graph v e -> Int
order (Graph g) = HM.size g
size :: (Hashable v, Eq v) => Graph v e -> Int
size = length . edges
edges :: forall v e . (Hashable v, Eq v) => Graph v e -> [Edge v e]
edges (Graph g) = linksToEdges $ zip vs links
where
vs :: [v]
vs = vertices $ Graph g
links :: [Links v e]
links = fmap (`getLinks` g) vs
edges' :: (Hashable v, Eq v) => Graph v e -> [(v, v)]
edges' g = toUnorderedPair <$> edges g
containsVertex :: (Hashable v, Eq v) => Graph v e -> v -> Bool
containsVertex (Graph g) = flip HM.member g
containsEdge :: (Hashable v, Eq v) => Graph v e -> Edge v e -> Bool
containsEdge g = containsEdge' g . toUnorderedPair
containsEdge' :: (Hashable v, Eq v) => Graph v e -> (v, v) -> Bool
containsEdge' graph@(Graph g) (v1, v2) =
containsVertex graph v1 && containsVertex graph v2 && v2 `HM.member` v1Links
where v1Links = getLinks v1 g
incidentEdges :: (Hashable v, Eq v) => Graph v e -> v -> [Edge v e]
incidentEdges g v = filter (\(Edge v1 v2 _) -> v == v1 || v == v2) $ edges g
vertexDegree :: (Hashable v, Eq v) => Graph v e -> v -> Int
vertexDegree g = length . incidentEdges g
degrees :: (Hashable v, Eq v) => Graph v e -> [Int]
degrees g = vertexDegree g <$> vertices g
maxDegree :: (Hashable v, Eq v) => Graph v e -> Int
maxDegree = maximum . degrees
minDegree :: (Hashable v, Eq v) => Graph v e -> Int
minDegree = minimum . degrees
isLoop :: (Eq v) => Edge v e -> Bool
isLoop (Edge v1 v2 _) = v1 == v2
isSimple :: (Hashable v, Eq v) => Graph v e -> Bool
isSimple = not . any isLoop . edges
isRegular :: Graph v e -> Bool
isRegular = undefined
fromAdjacencyMatrix :: [[Int]] -> Maybe (Graph Int ())
fromAdjacencyMatrix m
| length m /= length (head m) = Nothing
| otherwise = Just $ insertEdges (foldl genEdges [] labeledM) empty
where
labeledM :: [(Int, [(Int, Int)])]
labeledM = zip [1..] $ fmap (zip [1..]) m
genEdges :: [Edge Int ()] -> (Int, [(Int, Int)]) -> [Edge Int ()]
genEdges es (i, vs) = es ++ fmap (\v -> Edge i v ()) connected
where connected = fst <$> filter (\(_, v) -> v /= 0) vs
toAdjacencyMatrix :: Graph v e -> [[Int]]
toAdjacencyMatrix = undefined