module Data.Graph.Types where
import Data.List (nubBy)
import GHC.Float (float2Double)
import Data.Hashable
import qualified Data.HashMap.Lazy as HM
import Test.QuickCheck
data Edge v e = Edge v v e
deriving (Show, Read, Ord)
data Arc v e = Arc v v e
deriving (Show, Read, Ord)
type Links v e = HM.HashMap v e
instance (Eq v, Eq a) => Eq (Edge v a) where
(Edge v1 v2 a) == (Edge v1' v2' a') =
(a == a')
&& (v1 == v1' && v2 == v2')
|| (v1 == v2' && v2 == v1')
instance (Eq v, Eq a) => Eq (Arc v a) where
(Arc v1 v2 a) == (Arc v1' v2' a') = (a == a') && (v1 == v1' && v2 == v2')
class Weighted a where
weight :: a -> Double
class Labeled a where
label :: a -> String
instance Weighted Int where
weight = fromIntegral
instance Weighted Float where
weight = float2Double
instance Weighted Double where
weight = id
instance Labeled String where
label = id
instance Weighted (Double, String) where
weight = fst
instance Labeled (Double, String) where
label = snd
instance (Arbitrary v, Arbitrary e, Num v, Ord v) => Arbitrary (Edge v e) where
arbitrary = arbitraryEdge Edge
instance (Arbitrary v, Arbitrary e, Num v, Ord v) => Arbitrary (Arc v e) where
arbitrary = arbitraryEdge Arc
arbitraryEdge :: (Arbitrary v, Arbitrary e, Ord v, Num v)
=> (v -> v -> e -> edge)
-> Gen edge
arbitraryEdge edgeType = edgeType <$> vert <*> vert <*> arbitrary
where vert = getPositive <$> arbitrary
(<->) :: (Hashable v) => v -> v -> Edge v ()
(<->) v1 v2 = Edge v1 v2 ()
(-->) :: (Hashable v) => v -> v -> Arc v ()
(-->) v1 v2 = Arc v1 v2 ()
toOrderedPair :: Arc v a -> (v, v)
toOrderedPair (Arc fromV toV _) = (fromV, toV)
toUnorderedPair :: Edge v a -> (v, v)
toUnorderedPair (Edge v1 v2 _) = (v1, v2)
insertLink :: (Hashable v, Eq v) => v -> a -> Links v a -> Links v a
insertLink = HM.insert
getLinks :: (Hashable v, Eq v) => v -> HM.HashMap v (Links v e) -> Links v e
getLinks = HM.lookupDefault HM.empty
linksToArcs :: [(v, Links v a)] -> [Arc v a]
linksToArcs ls = concat $ fmap toArc ls
where
toArc :: (v, Links v a) -> [Arc v a]
toArc (fromV, links) = fmap (\(v, a) -> Arc fromV v a) (HM.toList links)
linksToEdges :: (Eq v) => [(v, Links v a)] -> [Edge v a]
linksToEdges ls = nubBy shallowEdgeEq $ concat $ fmap toEdge ls
where
toEdge :: (v, Links v a) -> [Edge v a]
toEdge (fromV, links) = fmap (\(v, a) -> Edge fromV v a) (HM.toList links)
shallowEdgeEq (Edge v1 v2 _) (Edge v1' v2' _) =
(v1 == v1' && v2 == v2')
|| (v1 == v2' && v2 == v1')
hashMapInsert :: (Eq k, Hashable k) => k -> v -> HM.HashMap k v -> HM.HashMap k v
hashMapInsert k v m = if not (HM.member k m) then HM.insert k v m else m