unordered-graphs (empty) → 0.1.0
raw patch · 9 files changed
+1046/−0 lines, 9 filesdep +basedep +deepseqdep +dlistsetup-changed
Dependencies added: base, deepseq, dlist, hashable, unordered-containers
Files
- LICENSE +20/−0
- README.md +2/−0
- Setup.hs +2/−0
- src/Data/Graph/Unordered.hs +464/−0
- src/Data/Graph/Unordered/Algorithms/Clustering.hs +258/−0
- src/Data/Graph/Unordered/Algorithms/Components.hs +56/−0
- src/Data/Graph/Unordered/Algorithms/Subgraphs.hs +38/−0
- src/Data/Graph/Unordered/Internal.hs +169/−0
- unordered-graphs.cabal +37/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,2 @@+# unordered-graphs+Graph library using unordered-containers
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Data/Graph/Unordered.hs view
@@ -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
+ src/Data/Graph/Unordered/Algorithms/Clustering.hs view
@@ -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+-- <http://arxiv.org/abs/0803.0476 Fast unfolding of communities in large networks>.+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)
+ src/Data/Graph/Unordered/Algorithms/Components.hs view
@@ -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
+ src/Data/Graph/Unordered/Algorithms/Subgraphs.hs view
@@ -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)
+ src/Data/Graph/Unordered/Internal.hs view
@@ -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
+ unordered-graphs.cabal view
@@ -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