diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015 Ivan Lazar Miljenovic + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,2 @@ +# unordered-graphs +Graph library using unordered-containers diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Data/Graph/Unordered.hs b/src/Data/Graph/Unordered.hs new file mode 100644 --- /dev/null +++ b/src/Data/Graph/Unordered.hs @@ -0,0 +1,464 @@ +{-# LANGUAGE ConstraintKinds, DeriveAnyClass, DeriveFunctor, DeriveGeneric, + FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, + StandaloneDeriving, TupleSections, TypeFamilies #-} + +{- | + Module : Data.Graph.Unordered + Description : Graphs with Hashable nodes + Copyright : (c) Ivan Lazar Miljenovic + License : MIT + Maintainer : Ivan.Miljenovic@gmail.com + +Known limitations: + +* Adding edges might not be the same depending on graph construction + (if you add then delete a lot of edges, then the next new edge might + be higher than expected). + + -} +module Data.Graph.Unordered + ( -- * Graph datatype + Graph + , DirGraph + , UndirGraph + , ValidGraph + -- ** Edge types + , Edge (..) + , DirEdge (..) + , UndirEdge (..) + , EdgeType (..) + , NodeFrom (..) + , DirAdj (..) + , Identity (..) + -- ** Graph Context + , Context (..) + , AdjLookup + , Contextual (..) + , ValidContext + , FromContext (..) + , ToContext (..) + + -- * Graph functions + -- ** Graph Information + , isEmpty + + -- *** Node information + , order + , hasNode + , ninfo + , nodes + , nodeDetails + , lnodes + , nlab + , neighbours + + -- *** Edge information + , size + , hasEdge + , einfo + , edges + , edgeDetails + , ledges + , elab + , edgePairs + , ledgePairs + + -- ** Graph construction + , empty + , mkGraph + , buildGr + , insNode + , insEdge + -- *** Merging + , Mergeable + , merge + , mergeAs + + -- ** Graph deconstruction + , delNode + , delEdge + , delEdgeLabel + , delEdgesBetween + -- *** Matching + , Matchable + , match + , matchAs + , matchAny + , matchAnyAs + + -- ** Manipulation + , nmap + , nmapFor + , emap + , emapFor + ) where + +import Data.Graph.Unordered.Internal + +import Control.Arrow (first, second) +import Control.DeepSeq (NFData) +import Data.Function (on) +import Data.Functor.Identity +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM +import Data.List (delete, foldl', groupBy, sortBy) +import Data.Maybe (listToMaybe) +import GHC.Generics (Generic) + +-- ----------------------------------------------------------------------------- + +type DirGraph = Graph DirEdge + +type UndirGraph = Graph UndirEdge + +type AdjLookup n el = HashMap Edge (n,el) + +-- ----------------------------------------------------------------------------- + +data DirEdge n = DE { fromNode :: !n + , toNode :: !n + } + deriving (Eq, Ord, Show, Read, Functor, Generic, NFData) + +-- 2-element set +-- INVARIANT: always has length == 2. +-- TODO: compare against using a simple tuple. +newtype UndirEdge n = UE { ueElem :: [n] } + deriving (Eq, Ord, Show, Read, Functor, Generic, NFData) + +data DirAdj n = ToNode n + | FromNode n + deriving (Eq, Ord, Show, Read, Generic, NFData) + +instance NodeFrom DirAdj where + getNode (ToNode n) = n + getNode (FromNode n) = n + +-- | Note that for loops, the result of 'otherN' will always be a +-- 'ToNode'. +instance EdgeType DirEdge where + type AdjType DirEdge = DirAdj + + mkEdge = DE + + otherN n (DE u v) + | n == u = ToNode v + | otherwise = FromNode u + + toEdge u (ToNode v) = DE u v + toEdge v (FromNode u) = DE u v + + edgeNodes (DE u v) = [u,v] + + edgeTriple (DE u v, el) = (u,v,el) + +instance EdgeType UndirEdge where + type AdjType UndirEdge = Identity + + mkEdge u v = UE [u,v] + + otherN n (UE vs) = Identity $ head (delete n vs) + + toEdge u (Identity v) = UE [u,v] + + edgeNodes = ueElem + + edgeTriple (UE vs,el) = let [u,v] = vs + in (u,v,el) + +-- ----------------------------------------------------------------------------- + +data Context at n nl el = Ctxt { cNode :: !n + , cLabel :: !nl + , cAdj :: !(AdjLookup (at n) el) + } + deriving (Eq, Show, Read, Generic, NFData) + +class Contextual ctxt where + type CNode ctxt :: * + type CAType ctxt :: * -> * + type CNLabel ctxt :: * + type CELabel ctxt :: * + +type ValidContext et n nl el ctxt = (Contextual ctxt + ,n ~ CNode ctxt + ,AdjType et ~ CAType ctxt + ,nl ~ CNLabel ctxt + ,el ~ CELabel ctxt + ) + +instance Contextual (Context at n nl el) where + type CNode (Context at n nl el) = n + type CAType (Context at n nl el) = at + type CNLabel (Context at n nl el) = nl + type CELabel (Context at n nl el) = el + +class (Contextual ctxt) => FromContext ctxt where + + fromContext :: Context (CAType ctxt) (CNode ctxt) (CNLabel ctxt) (CELabel ctxt) + -> ctxt + +-- This isn't quite right: have to work out what to do with Edge identifiers. +class (Contextual ctxt) => ToContext ctxt where + + toContext :: ctxt -> Context (CAType ctxt) (CNode ctxt) (CNLabel ctxt) (CELabel ctxt) + +instance FromContext (Context at n nl el) where + fromContext = id + +instance ToContext (Context at n nl el) where + toContext = id + +instance Contextual (n, nl, AdjLookup (at n) el) where + type CNode (n, nl, AdjLookup (at n) el) = n + type CAType (n, nl, AdjLookup (at n) el) = at + type CNLabel (n, nl, AdjLookup (at n) el) = nl + type CELabel (n, nl, AdjLookup (at n) el) = el + +instance FromContext (n, nl, AdjLookup (at n) el) where + fromContext (Ctxt n nl adj) = (n,nl,adj) + +instance ToContext (n, nl, AdjLookup (at n) el) where + toContext (n,nl,adj) = Ctxt n nl adj + +instance Contextual (n, nl, [(n,[el])]) where + type CNode (n, nl, [(n,[el])]) = n + type CAType (n, nl, [(n,[el])]) = AdjType UndirEdge + type CNLabel (n, nl, [(n,[el])]) = nl + type CELabel (n, nl, [(n,[el])]) = el + +instance (Ord n) => FromContext (n, nl, [(n,[el])]) where + fromContext ctxt = (cNode ctxt + ,cLabel ctxt + ,toLookup (cAdj ctxt)) + where + toLookup = map (\cels -> (fst (head cels), map snd cels)) + . groupBy ((==) `on` fst) + . sortBy (compare `on` fst) + . map (first runIdentity) + . HM.elems + +-- Can't have a ToContext for (n, nl, [(n,[el])]) as we threw out the +-- Edge values. + +-- ----------------------------------------------------------------------------- + +empty :: Graph et n nl el +empty = Gr HM.empty HM.empty minBound + +isEmpty :: Graph et n nl el -> Bool +isEmpty = HM.null . nodeMap + +-- | Number of nodes +order :: Graph et n nl el -> Int +order = HM.size . nodeMap + +-- | Number of edges +size :: Graph et n nl el -> Int +size = HM.size . edgeMap + +-- | Assumes the Contexts describe a graph in total, with the +-- outermost one first (i.e. @buildGr (c:cs) == c `merge` buildGr +-- cs@). +buildGr :: (ValidGraph et n) => [Context (AdjType et) n nl el] -> Graph et n nl el +buildGr = foldr merge empty + +ninfo :: (ValidGraph et n) => Graph et n nl el -> n -> Maybe ([Edge], nl) +ninfo g = fmap (first HM.keys) . (`HM.lookup` nodeMap g) + +hasNode :: (ValidGraph et n) => Graph et n nl el -> n -> Bool +hasNode g n = HM.member n (nodeMap g) + +nlab :: (ValidGraph et n) => Graph et n nl el -> n -> Maybe nl +nlab g = fmap snd . (`HM.lookup` nodeMap g) + +neighbours :: (ValidGraph et n) => Graph et n nl el -> n -> [n] +neighbours g n = maybe [] (map (getNode . otherN n . fst . (edgeMap g HM.!)) . fst) + $ ninfo g n + +hasEdge :: (ValidGraph et n) => Graph et n nl el -> Edge -> Bool +hasEdge g e = HM.member e (edgeMap g) + +einfo :: (ValidGraph et n) => Graph et n nl el -> Edge -> Maybe (et n, el) +einfo g = (`HM.lookup` edgeMap g) + +elab :: (ValidGraph et n) => Graph et n nl el -> Edge -> Maybe el +elab g = fmap snd . einfo g + +nodes :: Graph et n nl el -> [n] +nodes = HM.keys . nodeMap + +-- ----------------------------------------------------------------------------- + +type Matchable et n nl el ctxt = (ValidGraph et n + ,FromContext ctxt + ,ValidContext et n nl el ctxt + ) + +-- | Note that for any loops, the resultant edge will only appear once +-- in the output 'cAdj' field. +match :: (ValidGraph et n) => n -> Graph et n nl el + -> Maybe (Context (AdjType et) n nl el, Graph et n nl el) +match n g = getCtxt <$> HM.lookup n nm + where + nm = nodeMap g + em = edgeMap g + + getCtxt (adj,nl) = (ctxt, g') + where + ctxt = Ctxt n nl adjM + + -- Note that loops will only appear once here. + adjM = HM.map (first $ otherN n) (HM.intersection em adj) + + g' = g { nodeMap = nm' + , edgeMap = em' + } + + em' = em `HM.difference` adj + + adjNs = filter (/=n) -- take care of loops + . map (getNode . fst) + $ HM.elems adjM + nm' = foldl' (flip $ HM.adjust (first (`HM.difference`adj))) + (HM.delete n nm) + adjNs + +matchAs :: (Matchable et n nl el ctxt) => n -> Graph et n nl el + -> Maybe (ctxt, Graph et n nl el) +matchAs n = fmap (first fromContext) . match n + +matchAny :: (ValidGraph et n) => Graph et n nl el + -> Maybe (Context (AdjType et) n nl el, Graph et n nl el) +matchAny g + | isEmpty g = Nothing + | otherwise = flip match g . head . HM.keys $ nodeMap g + +matchAnyAs :: (Matchable et n nl el ctxt) => Graph et n nl el + -> Maybe (ctxt, Graph et n nl el) +matchAnyAs = fmap (first fromContext) . matchAny + +-- ----------------------------------------------------------------------------- + +type Mergeable et n nl el ctxt = (ValidGraph et n + ,ToContext ctxt + ,ValidContext et n nl el ctxt + ) + +-- Assumes edge identifiers are valid +merge :: (ValidGraph et n) => Context (AdjType et) n nl el + -> Graph et n nl el -> Graph et n nl el +merge ctxt g = Gr nm' em' nextE' + where + n = cNode ctxt + + adjM = cAdj ctxt + + adj = HM.map (adjCount n . getNode . fst) adjM + + nAdj = HM.toList + . foldl' (HM.unionWith HM.union) HM.empty + . map (uncurry toNAdj) + . HM.toList + $ adjM + + toNAdj e (av,_) = let v = getNode av + in HM.singleton v (HM.singleton e (adjCount n v)) + + -- Can we blindly assume that max == last ? + maxCE = fmap succ . listToMaybe . sortBy (flip compare) . HM.keys $ adjM + + nextE = nextEdge g + nextE' = maybe nextE (max nextE) maxCE + + em = edgeMap g + em' = em `HM.union` HM.map (first $ toEdge n) adjM + + nm = nodeMap g + nm' = foldl' (\m (v,es) -> HM.adjust (first (`HM.union`es)) v m) + (HM.insert n (adj,cLabel ctxt) nm) + nAdj + +mergeAs :: (Mergeable et n nl el ctxt) => ctxt -> Graph et n nl el + -> Graph et n nl el +mergeAs = merge . toContext + +-- ----------------------------------------------------------------------------- + +insNode :: (ValidGraph et n) => n -> nl -> Graph et n nl el -> Graph et n nl el +insNode n l g = g { nodeMap = HM.insert n (HM.empty, l) (nodeMap g) } + +insEdge :: (ValidGraph et n) => (n,n,el) -> Graph et n nl el + -> (Edge, Graph et n nl el) +insEdge (u,v,l) g = (e, Gr nm' em' (succ e)) + where + e = nextEdge g + + nm' = addE u . addE v $ nodeMap g + + addE = HM.adjust (first $ HM.insert e (adjCount u v)) + + em' = HM.insert e (mkEdge u v, l) (edgeMap g) + +delNode :: (ValidGraph et n) => n -> Graph et n nl el -> Graph et n nl el +delNode n g = maybe g snd $ match n g + +delEdge :: (ValidGraph et n) => Edge -> Graph et n nl el -> Graph et n nl el +delEdge e g = g { nodeMap = foldl' (flip delE) (nodeMap g) ens + , edgeMap = HM.delete e (edgeMap g) + } + where + ens = maybe [] (edgeNodes . fst) (HM.lookup e (edgeMap g)) + + delE = HM.adjust (first $ HM.delete e) + +-- TODO: care about directionality of edge. +delEdgeLabel :: (ValidGraph et n, Eq el) => (n,n,el) -> Graph et n nl el + -> Graph et n nl el +delEdgeLabel (u,v,l) g + | HM.null es = g + | otherwise = g { nodeMap = delEs u . delEs v $ nm + , edgeMap = em `HM.difference` es + } + where + nm = nodeMap g + + em = edgeMap g + + es = maybe HM.empty (HM.filter isE . HM.intersection em . fst) $ HM.lookup u nm + + isE (et,el) = getNode (otherN u et) == v && el == l + + delEs = HM.adjust (first (`HM.difference`es)) + +delEdgesBetween :: (ValidGraph et n) => n -> n -> Graph et n nl el + -> Graph et n nl el +delEdgesBetween u v g + | HM.null es = g + | otherwise = g { nodeMap = delEs u . delEs v $ nm + , edgeMap = em `HM.difference` es + } + where + nm = nodeMap g + em = edgeMap g + es = maybe HM.empty (HM.filter isE . HM.intersection em . fst) $ HM.lookup u nm + + isE (et,_) = getNode (otherN u et) == v + + delEs = HM.adjust (first (`HM.difference`es)) + +-- ----------------------------------------------------------------------------- + +nmap :: (ValidGraph et n) => (nl -> nl') -> Graph et n nl el -> Graph et n nl' el +nmap f = withNodeMap (HM.map (second f)) + +nmapFor :: (ValidGraph et n) => (nl -> nl) -> Graph et n nl el -> n + -> Graph et n nl el +nmapFor f g n = withNodeMap (HM.adjust (second f) n) g + +emap :: (ValidGraph et n) => (el -> el') -> Graph et n nl el -> Graph et n nl el' +emap f = withEdgeMap (HM.map (second f)) + +emapFor :: (ValidGraph et n) => (el -> el) -> Graph et n nl el -> Edge + -> Graph et n nl el +emapFor f g e = withEdgeMap (HM.adjust (second f) e) g diff --git a/src/Data/Graph/Unordered/Algorithms/Clustering.hs b/src/Data/Graph/Unordered/Algorithms/Clustering.hs new file mode 100644 --- /dev/null +++ b/src/Data/Graph/Unordered/Algorithms/Clustering.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE BangPatterns, ConstraintKinds, FlexibleContexts, + GeneralizedNewtypeDeriving, MultiParamTypeClasses, + StandaloneDeriving, TupleSections #-} + +{- | + Module : Data.Graph.Unordered.Algorithms.Clustering + Description : Graph partitioning + Copyright : (c) Ivan Lazar Miljenovic + License : MIT + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module Data.Graph.Unordered.Algorithms.Clustering + (bgll + ,EdgeMergeable + ) where + +import Data.Graph.Unordered +import Data.Graph.Unordered.Internal + +import Control.Arrow (first, (***)) +import Control.Monad (void) +import Data.Bool (bool) +import Data.Function (on) +import Data.Hashable (Hashable) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM +import Data.List (delete, foldl', foldl1', group, maximumBy, + sort) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Proxy (Proxy (Proxy)) + +-- ----------------------------------------------------------------------------- + +-- | Find communities in weighted graphs using the algorithm by +-- Blondel, Guillaume, Lambiotte and Lefebvre in their paper +-- . +bgll :: (ValidGraph et n, EdgeMergeable et, Fractional el, Ord el) + => Graph et n nl el -> [[n]] +bgll g = maybe [nodes g] nodes (recurseUntil pass g') + where + pass = fmap phaseTwo . phaseOne + + -- HashMap doesn't allow directly mapping the keys + g' = Gr { nodeMap = HM.fromList . map ((: []) *** void) . HM.toList $ nodeMap g + , edgeMap = HM.map (first (fmap (: []))) (edgeMap g) + , nextEdge = nextEdge g + } + +data CGraph et n el = CG { comMap :: HashMap Community (Set [n]) + , cGraph :: Graph et [n] Community el + } + deriving (Show, Read) + +deriving instance (Eq n, Eq el, Eq (et [n])) => Eq (CGraph et n el) + +newtype Community = C Word + deriving (Eq, Ord, Show, Read, Enum, Bounded, Hashable) + +type ValidC et n el = (ValidGraph et n, EdgeMergeable et, Fractional el, Ord el) + +phaseOne :: (ValidC et n el) => Graph et [n] nl el -> Maybe (CGraph et n el) +phaseOne = recurseUntil moveAll . initCommunities + +initCommunities :: (ValidC et n el) => Graph et [n] nl el -> CGraph et n el +initCommunities g = CG { comMap = cm + , cGraph = Gr { nodeMap = nm' + , edgeMap = edgeMap g + , nextEdge = nextEdge g + } + } + where + nm = nodeMap g + + ((_,cm),nm') = mapAccumWithKeyL go (C minBound, HM.empty) nm + + go (!c,!cs) ns al = ( (succ c, HM.insert c (HM.singleton ns ()) cs) + , c <$ al + ) + +moveAll :: (ValidC et n el) => CGraph et n el -> Maybe (CGraph et n el) +moveAll cg = uncurry (bool Nothing . Just) + $ foldl' go (cg,False) (nodes (cGraph cg)) + where + go pr@(cg',_) = maybe pr (,True) . tryMove cg' + +tryMove :: (ValidC et n el) => CGraph et n el -> [n] -> Maybe (CGraph et n el) +tryMove cg ns = moveTo <$> bestMove cg ns + where + cm = comMap cg + g = cGraph cg + + currentC = getC g ns + + currentCNs = cm HM.! currentC + + moveTo c = CG { comMap = HM.adjust (HM.insert ns ()) c cm' + , cGraph = nmapFor (const c) g ns + } + where + currentCNs' = HM.delete ns currentCNs + + cm' | HM.null currentCNs' = HM.delete currentC cm + | otherwise = HM.adjust (const currentCNs') currentC cm + +bestMove :: (ValidC et n el) => CGraph et n el -> [n] -> Maybe Community +bestMove cg n + | null vs = Nothing + | null cs = Nothing + | maxDQ <= 0 = Nothing + | otherwise = Just maxC + where + g = cGraph cg + c = getC g n + vs = neighbours g n + cs = delete c . map head . group . sort . map (getC g) $ vs + + (maxC, maxDQ) = maximumBy (compare`on`snd) + . map ((,) <*> diffModularity cg n) + $ cs + +getC :: (ValidC et n el) => Graph et [n] Community el -> [n] -> Community +getC g = fromMaybe (error "Node doesn't have a community!") . nlab g + +-- This is the 𝝙Q function. Assumed that @i@ is not within the community @c@. +diffModularity :: (ValidC et n el) => CGraph et n el -> [n] -> Community -> el +diffModularity cg i c = ((sumIn + kiIn)/m2 - sq ((sumTot + ki)/m2)) + - (sumIn/m2 - sq (sumTot/m2) - sq (ki/m2)) + where + g = cGraph cg + nm = nodeMap g + em = edgeMap g + + -- Nodes within the community + cNs = fromMaybe HM.empty (HM.lookup c (comMap cg)) + + -- Edges solely within the community + cEMap = HM.filter (all (`HM.member`cNs) . edgeNodes . fst) em + + -- All edges incident with C + incEs = HM.filter (any (`HM.member`cNs) . edgeNodes . fst) em + + -- Twice the weight of all edges in the graph (take into account both directions) + m2 = eTot em + + -- Sum of weights of all edges within the community + sumIn = eTot cEMap + -- Sum of weights of all edges incident with the community + sumTot = eTot incEs + + iAdj = maybe HM.empty fst $ HM.lookup i nm + + ki = kTot . HM.intersection em $ iAdj + kiIn = kTot . HM.intersection incEs $ iAdj + + -- 2* because the EdgeMap only contains one copy of each edge. + eTot = (2*) . kTot + + kTot = (2*) . sum . map snd . HM.elems + + sq x = x * x + +phaseTwo :: (ValidC et n el) => CGraph et n el -> Graph et [n] () el +phaseTwo cg = mkGraph ns es + where + nsCprs = map ((,) <*> concat . HM.keys) . HM.elems $ comMap cg + + nsToC = HM.fromList . concatMap (\(vs,c) -> map (,c) (HM.keys vs)) $ nsCprs + + emNCs = HM.map (first (fmap (nsToC HM.!))) (edgeMap (cGraph cg)) + + es = compressEdgeMap Proxy emNCs + ns = map (,()) (map snd nsCprs) + + -- eM' = map toCE + -- . groupBy ((==)`on`fst) + -- . sortBy (compare`on`fst) + -- . map (first edgeNodes) + -- . HM.elems + -- $ edgeMap (cGraph cg) + + -- d + + -- toCE es = let ([u,v],_) = head es + -- in (u,v, sum (map snd es)) + +-- The resultant (n,n) pairings will be unique +compressEdgeMap :: (ValidC et n el) => Proxy et -> EdgeMap et [n] el -> [([n],[n],el)] +compressEdgeMap p em = concatMap (\(u,vels) -> map (uncurry $ mkE u) (HM.toList vels)) + (HM.toList esUndir) + where + -- Mapping on edge orders as created + esDir = foldl1' (HM.unionWith (HM.unionWith (+))) + . map ((\(u,v,el) -> HM.singleton u (HM.singleton v el)) . edgeTriple) + $ HM.elems em + + esUndir = fst $ foldl' checkOpp (HM.empty, esDir) (HM.keys esDir) + + mkE u v el + | el < 0 = (v,u,applyOpposite p el) + | otherwise = (u,v,el) + + checkOpp (esU,esD) u + | HM.null uVs = (esU , esD' ) + | otherwise = (esU', esD'') + where + uVs = esD HM.! u + -- So we don't worry about loops. + esD' = HM.delete u esD + + uAdj = mapMaybe (\v -> fmap (v,) . HM.lookup u =<< (HM.lookup v esD')) + (HM.keys (esD' `HM.intersection` uVs)) + + esD'' = foldl' (flip $ HM.adjust (HM.delete u)) esD' (map fst uAdj) + + uVs' = foldl' toE uVs uAdj + toE m (v,el) = HM.insertWith (+) v (applyOpposite p el) m + + esU' = HM.insert u uVs' esU + +class (EdgeType et) => EdgeMergeable et where + applyOpposite :: (Fractional el) => Proxy et -> el -> el + +instance EdgeMergeable DirEdge where + applyOpposite _ = negate + +instance EdgeMergeable UndirEdge where + applyOpposite _ = id + +-- ----------------------------------------------------------------------------- +-- StateL was copied from the source of Data.Traversable in base-4.8.1.0 + +mapAccumWithKeyL :: (a -> k -> v -> (a, y)) -> a -> HashMap k v -> (a, HashMap k y) +mapAccumWithKeyL f a m = runStateL (HM.traverseWithKey f' m) a + where + f' k v = StateL $ \s -> f s k v + +-- left-to-right state transformer +newtype StateL s a = StateL { runStateL :: s -> (s, a) } + +instance Functor (StateL s) where + fmap f (StateL k) = StateL $ \ s -> let (s', v) = k s in (s', f v) + +instance Applicative (StateL s) where + pure x = StateL (\ s -> (s, x)) + StateL kf <*> StateL kv = StateL $ \ s -> + let (s', f) = kf s + (s'', v) = kv s' + in (s'', f v) + +-- ----------------------------------------------------------------------------- + +recurseUntil :: (a -> Maybe a) -> a -> Maybe a +recurseUntil f = fmap go . f + where + go a = maybe a go (f a) diff --git a/src/Data/Graph/Unordered/Algorithms/Components.hs b/src/Data/Graph/Unordered/Algorithms/Components.hs new file mode 100644 --- /dev/null +++ b/src/Data/Graph/Unordered/Algorithms/Components.hs @@ -0,0 +1,56 @@ +{- | + Module : Data.Graph.Unordered.Algorithms.Components + Description : Connected components + Copyright : (c) Ivan Lazar Miljenovic + License : MIT + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module Data.Graph.Unordered.Algorithms.Components where + +import Data.Graph.Unordered + +import Control.Arrow (first) +import qualified Data.DList as DL +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import Data.List (unfoldr,mapAccumL) +import Data.Maybe (catMaybes) +import Data.Tuple (swap) + +-- ----------------------------------------------------------------------------- + +-- | Calculate connected components of a graph; edge directionality +-- doesn't matter. +components :: (ValidGraph et n) => Graph et n nl el -> [Graph et n nl el] +components = unfoldr getComponent + +getComponent :: (ValidGraph et n) => Graph et n nl el + -> Maybe (Graph et n nl el, Graph et n nl el) +getComponent g = uncurry getComponentFrom <$> matchAny g + +getComponentFrom :: (ValidGraph et n) => Context (AdjType et) n nl el + -> Graph et n nl el -> (Graph et n nl el, Graph et n nl el) +getComponentFrom c = first (buildGr . (c:) . DL.toList) + . step (HS.singleton (cNode c)) (HS.fromList (adjN c)) + where + step vis toVis g + | HS.null toVis = (mempty,g) + | otherwise = first (DL.fromList cs`DL.append`) (step vis' toVis' g') + where + (g',mcs) = mapAccumL getC g (HS.toList toVis) + + cs = catMaybes mcs + + -- smaller set should be first for good performance + vis' = toVis `HS.union` vis + + toVis' = (`HS.difference`vis') + . HS.fromList + . concatMap adjN + $ cs + + getC g n = maybe (g,Nothing) (swap . first Just) (match n g) + adjN = map (getNode . fst) . HM.elems . cAdj diff --git a/src/Data/Graph/Unordered/Algorithms/Subgraphs.hs b/src/Data/Graph/Unordered/Algorithms/Subgraphs.hs new file mode 100644 --- /dev/null +++ b/src/Data/Graph/Unordered/Algorithms/Subgraphs.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +{- | + Module : Data.Graph.Unordered.Algorithms.Subgraphs + Description : Functions dealing with sub-graphs + Copyright : (c) Ivan Lazar Miljenovic + License : MIT + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module Data.Graph.Unordered.Algorithms.Subgraphs where + +import Data.Graph.Unordered.Internal + +import Control.Arrow (first) +import Data.Function (on) +import qualified Data.HashMap.Strict as HM + +-- ----------------------------------------------------------------------------- + +subgraph :: (ValidGraph et n) => Graph et n nl el -> [n] -> Graph et n nl el +subgraph g ns = g { nodeMap = nm', edgeMap = em' } + where + nsS = mkSet ns + + em' = HM.filter (all (`HM.member` nsS) . edgeNodes . fst) (edgeMap g) + + nm' = HM.map (first (`HM.intersection`em')) . (`HM.intersection`nsS) $ nodeMap g + +isSubGraphOf :: (ValidGraph et n, Eq (et n), Eq nl, Eq el) + => Graph et n nl el -> Graph et n nl el -> Bool +isSubGraphOf gs g = isSubOn nodeMap && isSubOn edgeMap + where + isSubOn f = (isSub`on`f) gs g + + isSub ms m = ms == (m `HM.intersection` ms) diff --git a/src/Data/Graph/Unordered/Internal.hs b/src/Data/Graph/Unordered/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Graph/Unordered/Internal.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, GeneralizedNewtypeDeriving, + MultiParamTypeClasses, TupleSections, TypeFamilies #-} + +{- | + Module : Data.Graph.Unordered.Internal + Description : Internal data definition + Copyright : (c) Ivan Lazar Miljenovic + License : MIT + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module Data.Graph.Unordered.Internal where + +import Control.Arrow (first, second) +import Control.DeepSeq (NFData (..)) +import Data.Functor.Identity +import Data.Hashable (Hashable) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM +import Data.List (foldl') + +-- ----------------------------------------------------------------------------- + +data Graph et n nl el = Gr { nodeMap :: !(NodeMap n nl) + , edgeMap :: !(EdgeMap et n el) + , nextEdge :: !Edge + } + +-- NOTE: we don't include nextEdge in equality tests. +instance (Eq (et n), Eq n, Eq nl, Eq el) => Eq (Graph et n nl el) where + g1 == g2 = nodeMap g1 == nodeMap g2 + && edgeMap g1 == edgeMap g2 + +instance (EdgeType et, Show n, Show nl, Show el) => Show (Graph et n nl el) where + showsPrec d g = showParen (d > 10) $ + showString "mkGraph " + . shows (lnodes g) + . showString " " + . shows (ledgePairs g) + +instance (ValidGraph et n, Read n, Read nl, Read el) => Read (Graph et n nl el) where + readsPrec p = readParen (p > 10) $ \r -> do + ("mkGraph", s) <- lex r + (ns,t) <- reads s + (es,u) <- reads t + return (mkGraph ns es, u) + +instance (NFData n, NFData (et n), NFData nl, NFData el) => NFData (Graph et n nl el) where + rnf (Gr nm em ne) = rnf nm `seq` rnf em `seq` rnf ne + +type NodeMap n nl = HashMap n (Adj, nl) +type EdgeMap et n el = HashMap Edge (et n, el) + +newtype Edge = Edge { unEdge :: Word } + deriving (Eq, Ord, Show, Read, Hashable, Enum, Bounded, NFData) + +type Set n = HashMap n () + +mkSet :: (Eq n, Hashable n) => [n] -> Set n +mkSet = HM.fromList . map (,()) + +-- The Int value is used for how many times that edge is attached to +-- the node: 1 for normal edges, 2 for loops. +-- +-- If we change this to being a list, then the Eq instance for Graph can't be derived. +type Adj = HashMap Edge Int + +adjCount :: (Eq n) => n -> n -> Int +adjCount u v + | u == v = 2 + | otherwise = 1 + +type ValidGraph et n = (Hashable n + ,Eq n + ,EdgeType et + ) + +-- | Assumes all nodes are in the node list. +mkGraph :: (ValidGraph et n) => [(n,nl)] -> [(n,n,el)] -> Graph et n nl el +mkGraph nlk elk = Gr nM eM nextE + where + addEs = zip [minBound..] elk + + eM = HM.fromList . map (second toE) $ addEs + toE (u,v,el) = (mkEdge u v, el) + + adjs = foldl' (HM.unionWith HM.union) HM.empty (concatMap toAdjM addEs) + toAdjM (e,(u,v,_)) = [toA u, toA v] + where + toA n = HM.singleton n (HM.singleton e (adjCount u v)) + + nM = HM.mapWithKey (\n nl -> (HM.lookupDefault HM.empty n adjs, nl)) + (HM.fromList nlk) + + -- TODO: can this be derived more efficiently? Consider defining + -- an alternate definition of zip... + nextE + | null addEs = minBound + | otherwise = succ . fst $ last addEs + +-- ----------------------------------------------------------------------------- + +class (Functor et, NodeFrom (AdjType et)) => EdgeType et where + type AdjType et :: * -> * + + mkEdge :: n -> n -> et n + + -- | Assumes @n@ is one of the end points of this edge. + otherN :: (Eq n) => n -> et n -> AdjType et n + + toEdge :: n -> AdjType et n -> et n + + -- | Returns a list of length 2. + edgeNodes :: et n -> [n] + + edgeTriple :: (et n, el) -> (n, n, el) + +class NodeFrom at where + getNode :: at n -> n + +instance NodeFrom Identity where + getNode = runIdentity + +-- ----------------------------------------------------------------------------- + +nodeDetails :: Graph et n nl el -> [(n, ([Edge], nl))] +nodeDetails = map (second (first (concatMap (uncurry $ flip replicate) . HM.toList))) + . HM.toList . nodeMap + +lnodes :: Graph et n nl el -> [(n,nl)] +lnodes = map (second snd) . nodeDetails + +edges :: Graph et n nl el -> [Edge] +edges = HM.keys . edgeMap + +edgeDetails :: Graph et n nl el -> [(Edge, (et n, el))] +edgeDetails = HM.toList . edgeMap + +ledges :: Graph et n nl el -> [(Edge, el)] +ledges = map (second snd) . edgeDetails + +edgePairs :: (EdgeType et) => Graph et n nl el -> [(n, n)] +edgePairs = map (ePair . fst) . HM.elems . edgeMap + where + ePair et = let [u,v] = edgeNodes et + in (u,v) + +ledgePairs :: (EdgeType et) => Graph et n nl el -> [(n,n,el)] +ledgePairs = map eTriple . HM.elems . edgeMap + where + eTriple (et,el) = let [u,v] = edgeNodes et + in (u,v,el) + +-- ----------------------------------------------------------------------------- + +degNM :: (Eq n, Hashable n) => NodeMap n nl -> n -> Int +degNM nm = maybe 0 (sum . HM.elems . fst) . (`HM.lookup` nm) + +-- ----------------------------------------------------------------------------- + +withNodeMap :: (NodeMap n nl -> NodeMap n nl') + -> Graph et n nl el -> Graph et n nl' el +withNodeMap f (Gr nm em e) = Gr (f nm) em e + +withEdgeMap :: (EdgeMap et n el -> EdgeMap et n el') + -> Graph et n nl el -> Graph et n nl el' +withEdgeMap f (Gr nm em e) = Gr nm (f em) e diff --git a/unordered-graphs.cabal b/unordered-graphs.cabal new file mode 100644 --- /dev/null +++ b/unordered-graphs.cabal @@ -0,0 +1,37 @@ +name: unordered-graphs +version: 0.1.0 +synopsis: Graph library using unordered-containers +description: Simple graph library allowing any Hashable instance + to be a node type. +license: MIT +license-file: LICENSE +author: Ivan Lazar Miljenovic +maintainer: Ivan.Miljenovic@gmail.com +-- copyright: +category: Data Structures, Graphs +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/ivan-m/unordered-graphs.git + +library + exposed-modules: Data.Graph.Unordered + , Data.Graph.Unordered.Algorithms.Clustering + , Data.Graph.Unordered.Algorithms.Components + , Data.Graph.Unordered.Algorithms.Subgraphs + , Data.Graph.Unordered.Internal + -- other-modules: + -- other-extensions: + build-depends: base >=4.8 && <4.9 + , deepseq >= 1.4.0.0 + , dlist >= 0.5 && < 0.8 + , hashable + , unordered-containers == 0.2.* + hs-source-dirs: src + default-language: Haskell2010 + + ghc-options: -Wall + ghc-prof-options: -prof