├── cabal.project ├── Setup.hs ├── .gitignore ├── ChangeLog.md ├── examples ├── Basic.hs ├── Fgl.hs ├── Sonic.hs ├── examples.cabal ├── Currency.hs └── Courses.hs ├── Data └── HashGraph │ ├── Arbitrary.hs │ ├── Algorithms.hs │ ├── Algorithms │ └── MST.hs │ └── Strict.hs ├── LICENSE ├── README.md ├── hash-graph.cabal ├── benchmarks ├── benchmarks.md └── Benchmark.hs ├── .travis.yml └── tests └── Test.hs /cabal.project: -------------------------------------------------------------------------------- 1 | packages: ./ 2 | examples/ 3 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | cabal.project.local 2 | dist* 3 | **/dump* 4 | 5 | out.bench 6 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for fgl-ng 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /examples/Basic.hs: -------------------------------------------------------------------------------- 1 | -- Create and print a simple graph 2 | -- 3 | -- Nodes are city names 4 | -- Edges are distances between the cities 5 | 6 | module Main where 7 | 8 | import Data.HashGraph.Strict (Edge(..), mkGraph, pretty) 9 | 10 | main :: IO () 11 | main = putStr $ pretty $ mkGraph es ns 12 | 13 | ns :: [String] 14 | ns = [ "Boston" 15 | , "Chicago" 16 | , "Los Angeles" 17 | ] 18 | 19 | es :: [Edge Int String] 20 | es = [ Edge "Chicago" 1000 "Boston" 21 | , Edge "Chicago" 2000 "Los Angeles" 22 | , Edge "Boston" 3000 "Los Angeles" 23 | ] 24 | -------------------------------------------------------------------------------- /examples/Fgl.hs: -------------------------------------------------------------------------------- 1 | -- This module demonstrates the inductive API similar to FGL's interface. 2 | 3 | module Main where 4 | 5 | import Data.HashGraph.Strict (Gr, Context'(..), (&), empty, matchAny) 6 | import qualified Data.HashSet as HS 7 | 8 | main :: IO () 9 | main = deconstruct graph 10 | 11 | graph :: Gr String Int 12 | graph = Context' HS.empty 1 HS.empty & 13 | Context' HS.empty 3 HS.empty & 14 | Context' HS.empty 2 HS.empty & empty 15 | 16 | deconstruct :: Gr String Int -> IO () 17 | deconstruct g = case matchAny g of 18 | Just (Context' _ node _, g') -> do print node 19 | deconstruct g' 20 | Nothing -> putStrLn "Graph is empty" 21 | -------------------------------------------------------------------------------- /examples/Sonic.hs: -------------------------------------------------------------------------------- 1 | -- This module shows you how to go fast. 2 | -- 3 | -- This requires you to use some internal types, 4 | -- which I am working on improving 5 | 6 | module Main where 7 | 8 | import Data.HashGraph.Strict (Context'(..), Head(..), Tail(..), fromList, size) 9 | import qualified Data.HashSet as HS 10 | 11 | main :: IO () 12 | main = print $ size $ fromList contexts 13 | 14 | -- HashGraph.fromList is a tiny wrapper around HashMap.fromList, 15 | -- so we have to emulate a HashMap entry. Thus we have the node (b) 16 | -- and it's context. 17 | -- 18 | -- This list of contexts creates a graph with 1000 nodes, and 19 | -- every possible edge between them. 20 | contexts :: [(Int, Context' () Int)] 21 | contexts = [ (n, Context' ps n ss) | n <- [1..1000] ] 22 | where 23 | -- A HashSet of half edges to predecessors. 24 | -- Edges labeled with () are effectively unlabeled. 25 | ps = HS.fromList [ Head () n | n <- [1..1000] ] 26 | -- A HashSet of half edges to successors. 27 | ss = HS.fromList [ Tail () n | n <- [1..1000] ] 28 | -------------------------------------------------------------------------------- /Data/HashGraph/Arbitrary.hs: -------------------------------------------------------------------------------- 1 | module Data.HashGraph.Arbitrary where 2 | 3 | import Data.Hashable 4 | import Data.HashGraph.Strict 5 | import Data.List (nub) 6 | import Test.QuickCheck (Arbitrary(..), listOf) 7 | 8 | -- | A complete graph, where all nodes have an edge to all other nodes. 9 | -- Simulated undirected by having one edge each way. 10 | newtype CompleteGraph a b = CG (Gr a b) 11 | 12 | -- | A graph shaped like a binary tree. 13 | newtype BTreeGraph a b = BTG (Gr a b) 14 | 15 | -- | A circular graph, where there are 16 | 17 | instance (Arbitrary a, Arbitrary b, Eq a, Eq b, Hashable a, Hashable b) => Arbitrary (CompleteGraph a b) where 18 | arbitrary = do 19 | ns <- nub <$> listOf arbitrary 20 | eLabel <- arbitrary 21 | let es = (\x y -> Edge x eLabel y) <$> ns <*> ns 22 | return $ CG $ mkGraph es ns 23 | 24 | instance (Arbitrary a, Arbitrary b, Eq a, Eq b, Hashable a, Hashable b) => Arbitrary (BTreeGraph a b) where 25 | arbitrary = do 26 | ns <- nub <$> listOf arbitrary 27 | eLabel <- arbitrary 28 | let len = length ns 29 | es = [ Edge (ns!!x) eLabel (ns!!y) | x <- [0..len-1], y <- [2*x+1, 2*x+2], y < len ] 30 | return $ BTG $ mkGraph es ns 31 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, Patrick Dougherty 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 17 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 18 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 19 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 20 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 21 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 22 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 23 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 24 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Build 2 | Status](https://travis-ci.org/patrickdoc/hash-graph.svg?branch=master)](https://travis-ci.org/patrickdoc/hash-graph) 3 | 4 | A Hashing-based Graph Library 5 | ============================= 6 | 7 | This library provides a hashing-based graph implementation in Haskell. 8 | 9 | I aim to maintain high-quality tests and documentation, high performance, 10 | and a reasonably low memory profile. If any of those seem to be lacking, let me 11 | know. See the 12 | [benchmarks](https://github.com/patrickdoc/hash-graph/blob/master/benchmarks/benchmarks.md) 13 | for performance data. 14 | 15 | This library was originally intended to be a more current implementation of 16 | the Functional Graph Library (FGL): 17 | [Hackage](https://hackage.haskell.org/package/fgl), 18 | [GitHub](https://github.com/haskell/fgl), 19 | [Original Site](http://web.engr.oregonstate.edu/~erwig/fgl/haskell/). 20 | However, I made changes to bring the api closer to other container libraries 21 | and to be more consistent in input and output types. 22 | 23 | Examples 24 | -------- 25 | 26 | I've included some example code in the folder `examples`. These demonstrate some 27 | of the practicals of building and using graphs. With `cabal >= 1.24` you should 28 | be able to: 29 | 30 | cabal new-build examples 31 | 32 | and then run them from with `dist-newstyle`. I find it easiest to just copy the 33 | location from the final line of building that says something like: 34 | 35 | Linking /PATH/TO/EXE ... 36 | 37 | Source Navigation 38 | ----------------- 39 | 40 | The main module is `Data.HashGraph.Strict`. This defines most of the 41 | functionality at the moment. I'm working on adding common graph algorithms to 42 | `Data.HashGraph.Algorithms`. 43 | -------------------------------------------------------------------------------- /hash-graph.cabal: -------------------------------------------------------------------------------- 1 | name: hash-graph 2 | category: Data 3 | version: 0.1.0.0 4 | license: BSD2 5 | license-file: LICENSE 6 | author: Patrick Dougherty 7 | maintainer: Patrick Dougherty 8 | copyright: Copyright (C) 2017-2018 Patrick Dougherty 9 | cabal-version: >=1.10 10 | build-type: Simple 11 | extra-source-files: ChangeLog.md 12 | tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.2, GHC == 8.5.* 13 | synopsis: A hashmap-based graph implementation 14 | description: 15 | This package provides an inductive graph representation based upon 16 | Martin Erwig's original . 17 | . 18 | The directory contains 19 | many small demonstrations of how to use the library. 20 | 21 | source-repository head 22 | type: git 23 | location: https://github.com/patrickdoc/hash-graph.git 24 | 25 | library 26 | exposed-modules: Data.HashGraph.Strict 27 | Data.HashGraph.Algorithms 28 | Data.HashGraph.Algorithms.MST 29 | -- other-modules: 30 | -- other-extensions: 31 | build-depends: base >=4.8 && <4.12 32 | , deepseq 33 | , hashable 34 | , heaps 35 | , unordered-containers 36 | default-language: Haskell2010 37 | ghc-options: -Wall 38 | 39 | test-suite tests 40 | default-language: Haskell2010 41 | type: exitcode-stdio-1.0 42 | hs-source-dirs: tests 43 | main-is: Test.hs 44 | build-depends: base >=4.8 && <4.12 45 | , hash-graph 46 | , hspec 47 | , QuickCheck 48 | , unordered-containers 49 | ghc-options: -Wall -with-rtsopts=-K1K 50 | 51 | benchmark benchmarks 52 | default-language: Haskell2010 53 | type: exitcode-stdio-1.0 54 | hs-source-dirs: benchmarks 55 | main-is: Benchmark.hs 56 | build-depends: base >=4.8 && <4.12 57 | , criterion 58 | , deepseq 59 | , fgl 60 | , hash-graph 61 | , unordered-containers 62 | ghc-options: -Wall 63 | -------------------------------------------------------------------------------- /examples/examples.cabal: -------------------------------------------------------------------------------- 1 | -- Various example programs using hash-graph 2 | 3 | name: examples 4 | version: 0.1.0.0 5 | synopsis: A collection of hash-graph examples 6 | author: Patrick Dougherty 7 | maintainer: patrick.doc@ameritech.net 8 | build-type: Simple 9 | cabal-version: >=1.10 10 | 11 | flag dump 12 | description: Dump core 13 | default: False 14 | 15 | flag prof 16 | description: Enable profiling output 17 | default: False 18 | 19 | executable basic 20 | default-language: Haskell2010 21 | main-is: Basic.hs 22 | ghc-options: -Wall -O2 23 | build-depends: base >= 4.10 && <4.12 24 | , hash-graph 25 | 26 | -- -p enables time profile report 27 | -- -s print profiling data to stderr 28 | -- -hy graph heap usage by type 29 | -- -i0.1 set resolution of heap sampling 30 | if flag(prof) 31 | ghc-options: "-with-rtsopts=-p -s -hy -i0.1" 32 | 33 | if flag(dump) 34 | ghc-options: -ddump-simpl -dsuppress-all -ddump-to-file 35 | 36 | executable courses 37 | default-language: Haskell2010 38 | main-is: Courses.hs 39 | ghc-options: -Wall -O2 40 | build-depends: base >= 4.10 && <4.12 41 | , hash-graph 42 | 43 | if flag(prof) 44 | ghc-options: "-with-rtsopts=-p -s -hy -i0.1" 45 | 46 | if flag(dump) 47 | ghc-options: -ddump-simpl -dsuppress-all -ddump-to-file 48 | 49 | executable currency 50 | default-language: Haskell2010 51 | main-is: Currency.hs 52 | ghc-options: -Wall -O2 53 | build-depends: base >= 4.10 && <4.12 54 | , hash-graph 55 | , safe-money 56 | 57 | if flag(prof) 58 | ghc-options: "-with-rtsopts=-p -s -hy -i0.1" 59 | 60 | if flag(dump) 61 | ghc-options: -ddump-simpl -dsuppress-all -ddump-to-file 62 | 63 | executable fgl 64 | default-language: Haskell2010 65 | main-is: Fgl.hs 66 | ghc-options: -Wall -O2 67 | build-depends: base >= 4.10 && <4.12 68 | , hash-graph 69 | , unordered-containers 70 | 71 | if flag(prof) 72 | ghc-options: "-with-rtsopts=-p -s -hy -i0.1" 73 | 74 | if flag(dump) 75 | ghc-options: -ddump-simpl -dsuppress-all -ddump-to-file 76 | 77 | executable sonic 78 | default-language: Haskell2010 79 | main-is: Sonic.hs 80 | ghc-options: -Wall -O2 81 | build-depends: base >= 4.10 && <4.12 82 | , hash-graph 83 | , unordered-containers 84 | 85 | if flag(prof) 86 | ghc-options: "-with-rtsopts=-p -s -hy -i0.1" 87 | 88 | if flag(dump) 89 | ghc-options: -ddump-simpl -dsuppress-all -ddump-to-file 90 | -------------------------------------------------------------------------------- /Data/HashGraph/Algorithms.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | module Data.HashGraph.Algorithms ( 3 | -- * Traversals 4 | bfs 5 | , bfsn 6 | , dfs 7 | , dfsn 8 | , prim 9 | , primAt 10 | , topSort 11 | 12 | -- * Paths? 13 | , pathTree 14 | ) where 15 | 16 | import Data.List (foldl') 17 | import Data.HashGraph.Strict 18 | import Data.HashGraph.Algorithms.MST (prim, primAt) 19 | import Data.Hashable 20 | import qualified Data.HashSet as HS 21 | import Data.Maybe (fromJust, maybe) 22 | 23 | {- 24 | - Articulation Point 25 | - Bi-connected components of an undirected graph 26 | - Dominators 27 | - Graph Voronoi Diagram 28 | - Maximum Independent Node Sets 29 | - Max Flow 30 | - Shortest Path 31 | - Transitive and or Reflective Closure 32 | -} 33 | 34 | ----------------------------------- 35 | -- Breadth-first Search 36 | 37 | -- | Breadth-first search 38 | bfs :: (Eq a, Eq b, Hashable a, Hashable b) => Gr a b -> [b] 39 | bfs g = maybe [] (\(ctx,_) -> snd $ bfs_ g HS.empty [ctx]) $ matchAny g 40 | {-# INLINABLE bfs #-} 41 | 42 | bfsn :: (Eq a, Eq b, Hashable a, Hashable b) => b -> Gr a b -> [b] 43 | bfsn n g = maybe [] (\(ctx,_) -> snd $ bfs_ g HS.empty [ctx]) $ match n g 44 | {-# INLINABLE bfsn #-} 45 | 46 | bfs_ :: (Eq b, Hashable b) => Gr a b -> HS.HashSet b -> [Context a b] -> (HS.HashSet b, [b]) 47 | bfs_ _ set [] = (set, []) 48 | bfs_ g !set cs = 49 | (\(newSet, parents, kids) -> 50 | (\(resSet, resNodes) -> (resSet, parents ++ resNodes)) (bfs_ g newSet kids)) $ foldl' helper (set,[],[]) cs 51 | where 52 | helper (hs,ps,ctxs) (n,Context' _ ss) = if HS.member n hs 53 | then (hs,ps,ctxs) 54 | else (HS.insert n hs, n:ps, map (\(Tail _ s) -> (s,g!s)) (HS.toList ss) ++ ctxs) 55 | {-# INLINABLE bfs_ #-} 56 | 57 | ----------------------------------- 58 | -- Depth-first Search 59 | 60 | -- | Depth-first search 61 | dfs :: (Eq a, Eq b, Hashable a, Hashable b) => Gr a b -> [b] 62 | dfs g = maybe [] (snd . dfs_ g HS.empty . fst) $ matchAny g 63 | {-# INLINABLE dfs #-} 64 | 65 | dfsn :: (Eq a, Eq b, Hashable a, Hashable b) => b -> Gr a b -> [b] 66 | dfsn n g = maybe [] (snd . dfs_ g HS.empty . fst) $ match n g 67 | {-# INLINABLE dfsn #-} 68 | 69 | dfs_ :: (Eq b, Hashable b) => Gr a b -> HS.HashSet b -> Context a b -> (HS.HashSet b, [b]) 70 | dfs_ g !set (n,Context' _ ss) 71 | = if HS.member n set 72 | then (set,[]) 73 | else let (newSet, lst) = HS.foldl' 74 | (\(hs,ls) (Tail _ s) -> (\(dSet,dNodes) -> (dSet, dNodes ++ ls)) (dfs_ g hs (s,g!s))) 75 | (HS.insert n set,[]) 76 | ss 77 | in (newSet, n : lst) 78 | {-# INLINABLE dfs_ #-} 79 | 80 | ----------------------------------- 81 | -- pathTree from Graphalyze 82 | 83 | -- | Return all paths starting at the given node 84 | -- WARNING: Infinite loop if the graph contains a loop (an edge from a node to itself) 85 | pathTree :: (Eq a, Eq b, Hashable a, Hashable b) => b -> Gr a b -> [[Edge a b]] 86 | pathTree n g = case match n g of 87 | Just (_, g') -> case outEdges n g of 88 | Just es -> if Prelude.null es 89 | then [[]] 90 | else concatMap (\e@(Edge _ _ s) -> map (e:) (pathTree s g')) es 91 | Nothing -> [[]] 92 | Nothing -> [] 93 | 94 | ----------------------------------- 95 | -- Topological sorts 96 | 97 | topSort :: (Eq a, Eq b, Hashable a, Hashable b) => Gr a b -> Maybe [b] 98 | topSort g = go open 99 | where 100 | open = HS.fromList $ nodes g 101 | -- while there are unmarked nodes, visit them 102 | go o = snd $ HS.foldl' (\(unmarked, list) n -> visit n unmarked HS.empty list) (o, Just []) o 103 | where 104 | -- check for marks, then visit children, mark n, and add to list 105 | visit _ o _ Nothing = (o, Nothing) 106 | visit n o t l 107 | | not (HS.member n o) = (o, l) 108 | | HS.member n t = (o, Nothing) 109 | | otherwise = (HS.delete n newO, fmap (n :) newL) 110 | where 111 | -- visit all children 112 | (newO, newL) = foldl' (\(o',l') node -> visit node o' (HS.insert n t) l') (o,l) (fromJust $ succs n g) 113 | -------------------------------------------------------------------------------- /benchmarks/benchmarks.md: -------------------------------------------------------------------------------- 1 | # Benchmarks 2 | 3 | To keep up my promise of performance, here are some measurements taken on my 4 | computer. For the biggest wins, look to the sections on [queries](#queries) and 5 | [algorithms](#algorithms). 6 | 7 | N.B. FGL's implementation is based on Data.IntMap.Lazy, whereas this library is 8 | based on Data.HashGraph.Strict. I've tried to make this comparison fair with 9 | appropriate applications of `nf`. However, if you feel that I've compromised 10 | any of the measurements, please let me know. 11 | 12 | I would take these measurements with a grain of salt. Many of the measurements 13 | differ wildly between `whnf` and `nf`, and I have to look a little closer at the 14 | sources to determine the best way to compare them. 15 | 16 | All functions run on a graph with 1000 nodes and 1 million edges. 17 | 18 | ### Construction 19 | 20 | | Function | New | FGL | 21 | |---------------|-----------|-----------| 22 | | mkGraph | 3.479 s | 705.5 ms | 23 | | fromList | 81.92 μs | 316.4 ms | 24 | 25 | ### Basic Interface 26 | 27 | | Function | New | FGL | 28 | |---------------|-----------|-----------| 29 | | null | 7.866 ns | 7.731 ns | 30 | | match | 53.05 ms | 53.88 ms | 31 | | matchAny | 50.43 ms | 54.60 ms | 32 | | nodes | 19.33 μs | 21.87 μs | 33 | | order | 6.891 μs | 8.307 μs | 34 | | edges | 297.8 ms | 203.3 ms | 35 | | size | 14.49 ms | 228.2 ms | 36 | | (&) | 169.0 μs | 97.20 ns | 37 | | (!) | 29.44 ns | | 38 | | (!?) | 27.56 ns | | 39 | 40 | ### Maps 41 | 42 | | Function | New | FGL | 43 | |---------------|-----------|-----------| 44 | | nmap | 1.059 s | 52.02 ms | 45 | | emap | 1.080 s | 513.9 ms | 46 | | nemap | 1.055 s | 517.3 ms | 47 | | ctxMap | | 748.5 ms | 48 | 49 | ### Folds 50 | 51 | | Function | New | FGL | 52 | |---------------|-----------|-----------| 53 | | foldr | 47.47 μs | 287.0 ms | 54 | 55 | ### Queries 56 | 57 | | Function | New | FGL | 58 | |---------------|-----------|-----------| 59 | | member | 28.25 ns | 1.113 ms | 60 | | neighbors | 311.7 μs | 1.227 ms | 61 | | preds | 14.12 μs | 1.221 ms | 62 | | succs | 13.81 μs | 1.208 ms | 63 | | inEdges | 22.94 μs | 1.224 ms | 64 | | outEdges | 23.04 μs | 1.228 ms | 65 | | inDegree | 58.29 ns | 1.201 ms | 66 | | outDegree | 58.37 ns | 1.196 ms | 67 | | degree | 125.4 ns | 1.169 ms | 68 | | hasEdge | 260.1 ns | 1.218 ms | 69 | | hasNeighbor | 20.99 μs | 1.165 ms | 70 | 71 | ### Filters 72 | 73 | | Function | New | FGL | 74 | |---------------|-----------|-----------| 75 | | gfiltermap | | 1.635 s | 76 | | nfilter (lab) | 275.4 ms | 51.93 ms | 77 | | nfilter (node)| 275.4 ms | 52.28 ms | 78 | | efilter | 265.9 ms | 1.870 s | 79 | | subgraph | | 243.5 ms | 80 | 81 | ### Insertion and Deletion 82 | 83 | | Function | New | FGL | 84 | |---------------|-----------|-----------| 85 | | insNode | 84.83 ns | 67.92 ns | 86 | | delNode | 2.858 ms | 1.105 ms | 87 | | insEdge | 501.8 ns | 160.9 ns | 88 | | delEdge | 523.6 ns | 4.095 ms | 89 | | insNodes | | 746.0 ns | 90 | | delNodes | | 237.3 ms | 91 | | insEdges | | 159.6 ns | 92 | | delEdges | | 2.756 s | 93 | 94 | ### Algorithms 95 | 96 | | Function | New | FGL | 97 | |---------------|-----------|-----------| 98 | | bfs | 147.4 ms | 576.5 ms | 99 | | dfs | 123.8 ms | 286.1 ms | 100 | | mst | 112.3 ms | 617.8 ms | 101 | 102 | 103 | ## Detailed 104 | 105 | These are run on graphs with 1000 nodes, but only edges leading to nodes with 106 | values less than the original node. i.e. (1,1), (2,1), (2,2), (3,1), (3,2), 107 | (3,3) .... 108 | 109 | | Function | New | FGL | 110 | |---------------|-----------|-----------| 111 | | insNode | 84.91 ns | 70.28 ns | 112 | | insNode-dup | 80.08 ns | 91.51 ns | 113 | | delNode | 3.106 ms | 146.5 μs | 114 | | delNode-miss | 19.57 ns | 36.07 ns | 115 | | insEdge | 507.2 ns | 156.8 ns | 116 | | insEdge-dup | 275.8 ns | 172.2 ns | 117 | | delEdge | 512.6 ns | 1.038 ms | 118 | | delEdge-miss | 235.8 ns | 305.8 ns | 119 | | lookup | 27.23 ns | | 120 | | lookup-miss | 18.08 ns | | 121 | 122 | -------------------------------------------------------------------------------- /examples/Currency.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | -- Given a list of exchange rates, calculate all possible paths 4 | -- from "EUR" (Euro) to "AUD" (Australian dollar). 5 | -- With the given list of exchange rates, there will be multiple possible paths, 6 | -- but one will offer a lower exchange rate than the others. 7 | -- See also issues #3 and #4. 8 | 9 | module Main where 10 | 11 | import Data.HashGraph.Strict (Edge(..), mkGraph) 12 | import Data.HashGraph.Algorithms (pathTree) 13 | 14 | import Data.Maybe (fromJust, fromMaybe) 15 | import Data.List (nub, sortOn, intercalate) 16 | import qualified Money as M 17 | import GHC.TypeLits (KnownSymbol) 18 | import Text.Printf (printf) 19 | 20 | 21 | main :: IO () 22 | main = do 23 | let graph = mkGraph edges (nodes edges) 24 | paths = filter audEndPath (pathTree "EUR" graph) -- All paths going from "EUR" to "AUD" 25 | audEndPath = (\(Edge _ _ dst) -> dst == "AUD") . last 26 | edgeData (Edge _ ed _) = ed 27 | -- Fail if, for two adjacent edges, the destination edge of the first edge 28 | -- doesn't match the source edge of the second edge 29 | nothingFail eL = fromMaybe (error $ "Edges not in proper order: " ++ show eL) 30 | composedRate edgeL = nothingFail edgeL $ composeRates $ map edgeData edgeL 31 | prettyPath edgeL = intercalate "->" $ nodes edgeL -- Pretty path, e.g. "EUR->JPY->GBP" 32 | pathRatePair edgeL = (composedRate edgeL, prettyPath edgeL) -- Pair of rate and path 33 | sortedPairs = reverse $ sortOn fst (map pathRatePair paths) 34 | prettyPair (er, path) = printf "%.8g: %s" (fromRational $ M.someExchangeRateRate er :: Double) path :: String 35 | putStrLn "Final exchange rate, and exchange rate path, in order of highest exchange rate:" 36 | mapM_ putStrLn (map prettyPair sortedPairs) 37 | 38 | -- | Our exchange rates of interest 39 | exchangeRates :: [M.SomeExchangeRate] 40 | exchangeRates = 41 | [ toER (M.exchangeRate 1.25 :: Maybe (M.ExchangeRate "EUR" "USD")) 42 | , toER (M.exchangeRate 0.71 :: Maybe (M.ExchangeRate "USD" "GBP")) 43 | , toER (M.exchangeRate 132.74 :: Maybe (M.ExchangeRate "EUR" "JPY")) 44 | , toER (M.exchangeRate 0.0067 :: Maybe (M.ExchangeRate "JPY" "GBP")) 45 | , toER (M.exchangeRate 1.76 :: Maybe (M.ExchangeRate "GBP" "CAD")) 46 | , toER (M.exchangeRate 8.95 :: Maybe (M.ExchangeRate "GBP" "CNY")) 47 | , toER (M.exchangeRate 0.2 :: Maybe (M.ExchangeRate "CNY" "AUD")) 48 | , toER (M.exchangeRate 1.01 :: Maybe (M.ExchangeRate "CAD" "AUD")) 49 | ] where toER :: (KnownSymbol src, KnownSymbol dst) 50 | => Maybe (M.ExchangeRate src dst) 51 | -> M.SomeExchangeRate 52 | toER = M.toSomeExchangeRate . fromJust 53 | 54 | -- | Get a list of nodes along a path of non-cyclical edges 55 | nodes :: [Edge M.SomeExchangeRate String] -> [String] 56 | nodes = nub . concat . map toVertices -- Get all vertices and remove duplicates 57 | where toVertices (Edge v1 _ v2) = [v1, v2] 58 | 59 | -- | Edges = ExchangeRates 60 | edges :: [Edge M.SomeExchangeRate String] 61 | edges = map toEdge exchangeRates 62 | 63 | -- | Convert an exchange rate to an edge that goes from source currency to destination currency 64 | toEdge :: M.SomeExchangeRate -> Edge M.SomeExchangeRate String 65 | toEdge se = Edge 66 | (M.someExchangeRateSrcCurrency se) 67 | se 68 | (M.someExchangeRateDstCurrency se) 69 | 70 | -- | Compose two 'M.SomeExchangeRate's (if they're compatible). 71 | -- Given an exchange rate from EUR to USD, and another exchange rate from USD to JPY, 72 | -- return an exchange rate from EUR to JPY. 73 | -- Returns 'Nothing' in case the destination currency of the first exchange rate 74 | -- doesn't match the source currency of the second exchange rate. 75 | compose :: M.SomeExchangeRate -> M.SomeExchangeRate -> Maybe M.SomeExchangeRate 76 | compose se1 se2 77 | | M.someExchangeRateDstCurrency se1 /= M.someExchangeRateSrcCurrency se2 = Nothing 78 | | otherwise = Just . fromJust $ M.mkSomeExchangeRate 79 | (M.someExchangeRateSrcCurrency se1) 80 | (M.someExchangeRateDstCurrency se2) 81 | (M.someExchangeRateRate se1 * M.someExchangeRateRate se2) -- Both positive and non-zero 82 | 83 | -- | Compose a list of 'M.SomeExchangeRate's. 84 | -- Using 'compose' to return e.g. an exchange rate from "USD" to "JPY" from a list of 85 | -- exchange rates from ["USD->EUR", "EUR->GBP", "GBP->JPY"]. 86 | composeRates :: [M.SomeExchangeRate] -> Maybe M.SomeExchangeRate 87 | composeRates [] = Nothing 88 | composeRates (first:erLst) = foldl go (Just first) erLst 89 | where go Nothing _ = Nothing 90 | go (Just er1) er2 = er1 `compose` er2 91 | -------------------------------------------------------------------------------- /examples/Courses.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 2 | -- This module is why I wrote the library in the first place. 3 | -- 4 | -- Each node is a topic in computer science. 5 | -- 6 | -- Each edge represents the difficulty of moving from one topic to another. 7 | -- The goal of this module is to find the minimum spanning tree representing 8 | -- the simplest way to learn every topic. 9 | 10 | module Main where 11 | 12 | import Data.HashGraph.Strict (Gr, Edge(..), mkGraph, pretty) 13 | import Data.HashGraph.Algorithms (primAt) 14 | 15 | main :: IO () 16 | main = do 17 | -- Run prim's algorithm on a given starting node, 18 | -- then create a representation of the graph for printing 19 | putStr $ pretty $ primAt pythonAndTerm courseGraph 20 | 21 | -- | Type aliases to make the graph type clear 22 | -- node :: Course 23 | -- edge :: Difficulty 24 | type Course = String 25 | type Difficulty = Int 26 | 27 | -- | The graph will have edges labeled with /Difficulty/'s 28 | -- and nodes labeled with /Course/'s 29 | courseGraph :: Gr Difficulty Course 30 | courseGraph = mkGraph preReqs courses 31 | 32 | --------------------------------------- 33 | -- Nodes 34 | 35 | -- | A list of all the courses 36 | courses :: [Course] 37 | courses 38 | = [ introC 39 | , pythonAndTerm 40 | , bashAndIntermTerm 41 | , networking 42 | , git 43 | , ml 44 | , stat 45 | , discMath 46 | , formal 47 | , crypto 48 | , arch 49 | , haskell 50 | , compilers 51 | , gc 52 | , rust 53 | , testing 54 | , automation 55 | , os 56 | , distSys 57 | , building 58 | , algo 59 | , dataStruct 60 | , perfAndOpt 61 | , pkgAndLib 62 | , monitoring 63 | , cpuGraphics 64 | , linAlg 65 | , gpuGraphics 66 | ] 67 | 68 | -- Course definitions 69 | introC = "An Introduction to C" 70 | pythonAndTerm = "Python and the Terminal" 71 | bashAndIntermTerm = "Bash and Intermediate Terminal" 72 | networking = "Networking" 73 | git = "Git" 74 | ml = "Machine Learning" 75 | stat = "Statistics" 76 | discMath = "Discrete Math" 77 | formal = "Formal Languages" 78 | crypto = "Cryptography" 79 | arch = "Architecture" 80 | haskell = "Haskell" 81 | compilers = "Compilers" 82 | gc = "Garbage Collection" 83 | rust = "Rust" 84 | testing = "Testing" 85 | automation = "Automation" 86 | os = "Operating Systems" 87 | distSys = "Distributed Systems" 88 | building = "Building a Computer" 89 | algo = "Algorithms" 90 | dataStruct = "Data Structures" 91 | perfAndOpt = "Performance and Optimization" 92 | pkgAndLib = "Package Management and Working with Libraries" 93 | monitoring = "Monitoring" 94 | cpuGraphics = "CPU Graphics" 95 | linAlg = "Linear Algebra" 96 | gpuGraphics = "GPU Graphics" 97 | 98 | 99 | --------------------------------------- 100 | -- Edges 101 | 102 | -- | A list of the edges of the graph 103 | -- 104 | -- These /Edge/s connect two /Course/s with a /Difficulty/ label 105 | preReqs :: [Edge Difficulty Course] 106 | preReqs = 107 | [ Edge introC 1 bashAndIntermTerm 108 | , Edge introC 1 networking 109 | , Edge introC 1 crypto 110 | , Edge introC 1 arch 111 | , Edge introC 1 haskell 112 | , Edge introC 1 algo 113 | , Edge introC 1 dataStruct 114 | , Edge pythonAndTerm 1 introC 115 | , Edge pythonAndTerm 1 bashAndIntermTerm 116 | , Edge pythonAndTerm 1 testing 117 | , Edge pythonAndTerm 1 algo 118 | , Edge pythonAndTerm 1 pkgAndLib 119 | , Edge bashAndIntermTerm 1 networking 120 | , Edge bashAndIntermTerm 1 git 121 | , Edge bashAndIntermTerm 1 crypto 122 | , Edge bashAndIntermTerm 1 arch 123 | , Edge bashAndIntermTerm 1 haskell 124 | , Edge bashAndIntermTerm 1 testing 125 | , Edge bashAndIntermTerm 1 algo 126 | , Edge bashAndIntermTerm 1 dataStruct 127 | , Edge networking 1 git 128 | , Edge networking 1 crypto 129 | , Edge networking 1 arch 130 | , Edge networking 1 haskell 131 | , Edge networking 1 testing 132 | , Edge networking 1 os 133 | , Edge networking 1 dataStruct 134 | , Edge haskell 1 compilers 135 | , Edge haskell 1 gc 136 | , Edge haskell 1 testing 137 | , Edge arch 1 building 138 | , Edge perfAndOpt 1 monitoring 139 | , Edge pkgAndLib 1 automation 140 | , Edge stat 1 ml 141 | , Edge linAlg 1 cpuGraphics 142 | ] 143 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # runghc make_travis_yml_2.hs 'hash-graph.cabal' 4 | # 5 | # For more information, see https://github.com/hvr/multi-ghc-travis 6 | # 7 | language: c 8 | sudo: false 9 | 10 | git: 11 | submodules: false # whether to recursively clone submodules 12 | 13 | cache: 14 | directories: 15 | - $HOME/.cabal/packages 16 | - $HOME/.cabal/store 17 | 18 | before_cache: 19 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log 20 | # remove files that are regenerated by 'cabal update' 21 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* 22 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json 23 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache 24 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar 25 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx 26 | 27 | - rm -rfv $HOME/.cabal/packages/head.hackage 28 | 29 | matrix: 30 | include: 31 | - compiler: "ghc-7.10.3" 32 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 33 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.10.3], sources: [hvr-ghc]}} 34 | - compiler: "ghc-8.0.2" 35 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 36 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}} 37 | - compiler: "ghc-8.2.2" 38 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 39 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.2], sources: [hvr-ghc]}} 40 | - compiler: "ghc-8.4.2" 41 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 42 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.4.2], sources: [hvr-ghc]}} 43 | - compiler: "ghc-head" 44 | env: GHCHEAD=true 45 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-head], sources: [hvr-ghc]}} 46 | 47 | allow_failures: 48 | - compiler: "ghc-head" 49 | 50 | before_install: 51 | - HC=${CC} 52 | - HCPKG=${HC/ghc/ghc-pkg} 53 | - unset CC 54 | - ROOTDIR=$(pwd) 55 | - mkdir -p $HOME/.local/bin 56 | - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH" 57 | - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) 58 | - echo $HCNUMVER 59 | 60 | install: 61 | - cabal --version 62 | - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" 63 | - BENCH=${BENCH---enable-benchmarks} 64 | - TEST=${TEST---enable-tests} 65 | - HADDOCK=${HADDOCK-true} 66 | - INSTALLED=${INSTALLED-true} 67 | - GHCHEAD=${GHCHEAD-false} 68 | - travis_retry cabal update -v 69 | - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config" 70 | - rm -fv cabal.project cabal.project.local 71 | # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage 72 | - | 73 | if $GHCHEAD; then 74 | sed -i.bak 's/-- allow-newer:.*/allow-newer: *:base, *:template-haskell, *:ghc, *:Cabal/' ${HOME}/.cabal/config 75 | 76 | echo 'repository head.hackage' >> ${HOME}/.cabal/config 77 | echo ' url: http://head.hackage.haskell.org/' >> ${HOME}/.cabal/config 78 | echo ' secure: True' >> ${HOME}/.cabal/config 79 | echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config 80 | echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config 81 | echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config 82 | echo ' key-threshold: 3' >> ${HOME}/.cabal.config 83 | 84 | cabal new-update head.hackage -v 85 | fi 86 | - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' 87 | - "printf 'packages: \".\"\\n' > cabal.project" 88 | - cat cabal.project 89 | - if [ -f "./configure.ac" ]; then 90 | (cd "." && autoreconf -i); 91 | fi 92 | - rm -f cabal.project.freeze 93 | - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all 94 | - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all 95 | - rm -rf .ghc.environment.* "."/dist 96 | - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) 97 | 98 | # Here starts the actual work to be performed for the package under test; 99 | # any command which exits with a non-zero exit code causes the build to fail. 100 | script: 101 | # test that source-distributions can be generated 102 | - (cd "." && cabal sdist) 103 | - mv "."/dist/hash-graph-*.tar.gz ${DISTDIR}/ 104 | - cd ${DISTDIR} || false 105 | - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; 106 | - "printf 'packages: hash-graph-*/*.cabal\\n' > cabal.project" 107 | - cat cabal.project 108 | # this builds all libraries and executables (without tests/benchmarks) 109 | - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all 110 | 111 | # Build with installed constraints for packages in global-db 112 | - if $INSTALLED; then echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks $(${HCPKG} list --global --simple-output --names-only | sed 's/\([a-zA-Z0-9-]\{1,\}\) */--constraint="\1 installed" /g') all | sh; else echo "Not building with installed constraints"; fi 113 | 114 | # build & run tests, build benchmarks 115 | - cabal new-build -w ${HC} ${TEST} ${BENCH} all 116 | - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi 117 | 118 | # cabal check 119 | - (cd hash-graph-* && cabal check) 120 | 121 | # haddock 122 | - rm -rf ./dist-newstyle 123 | - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi 124 | 125 | # REGENDATA ["hash-graph.cabal"] 126 | # EOF 127 | -------------------------------------------------------------------------------- /Data/HashGraph/Algorithms/MST.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, TupleSections #-} 2 | 3 | module Data.HashGraph.Algorithms.MST ( 4 | prim 5 | , primAt 6 | , kruskal 7 | ) where 8 | 9 | import Data.HashGraph.Strict 10 | import Data.Hashable 11 | import qualified Data.HashSet as HS 12 | import qualified Data.HashMap.Strict as HM 13 | import qualified Data.Heap as H 14 | import Data.List (foldl') 15 | import Data.Maybe (maybe) 16 | 17 | -- | Prim's algorithm for the minimum spanning tree 18 | -- 19 | -- Implemented with a with a hash set of visited nodes and a hash map of 20 | -- optimal edges 21 | 22 | prim :: (Eq b, Hashable a, Hashable b, Ord a) => Gr a b -> Gr a b 23 | prim g = maybe g (primBoth g . fst) $ matchAny g 24 | 25 | primAt :: (Eq b, Hashable a, Hashable b, Ord a) => b -> Gr a b -> Gr a b 26 | primAt start g = maybe g (primBoth g . (start,)) $ g !? start 27 | 28 | -------------------------------------- 29 | -- Use just an optimal hash-map 30 | 31 | primMap :: (Eq b, Hashable a, Hashable b, Ord a) => Gr a b -> Context a b -> Gr a b 32 | primMap g (node,Context' _ sucs) = fixTails $ go HS.empty HM.empty (node,Context' HS.empty sucs) 33 | where 34 | -- Context has new ps (just the edge that was used to include this node) and old ss 35 | go !visited !optimal (n,Context' ps ss) = 36 | let newVisited = HS.insert n visited 37 | in case pickNextNode (addTailsMap n newVisited optimal ss) of 38 | Just (newOpt, newCtx) -> (n, Context' ps HS.empty) : go newVisited newOpt newCtx 39 | Nothing -> [(n, Context' ps HS.empty)] 40 | -- remove picked node from optimal and prep it for next round 41 | pickNextNode opt 42 | = (\(s,hd) -> (HM.delete s opt, (s, Context' (HS.singleton hd) (tails (g ! s))))) <$> minimumByWeight opt 43 | 44 | -- Add all new edges to the optimal map, keeping only better ones 45 | addTailsMap :: (Eq b, Hashable b, Ord a) => b -- New node 46 | -> HS.HashSet b -- Visited nodes 47 | -> HM.HashMap b (Head a b) -- Optimal edges 48 | -> HS.HashSet (Tail a b) -- New edges 49 | -> HM.HashMap b (Head a b) -- New optimal edges 50 | addTailsMap n visited = HS.foldl' checkedInsert 51 | where 52 | checkedInsert hm (Tail l s) 53 | = if HS.member s visited 54 | then hm 55 | else HM.insertWith minHead s (Head l n) hm 56 | 57 | -- Pick out the least weight edge from the optimal map 58 | minimumByWeight :: (Ord a) => HM.HashMap b (Head a b) -> Maybe (b, Head a b) 59 | minimumByWeight 60 | = HM.foldlWithKey' (\mh k hd -> 61 | case mh of 62 | Just e -> Just $ minEdge (k,hd) e 63 | Nothing -> Just (k,hd)) Nothing 64 | 65 | -- The generated list does not have any tails, match all the heads with tails 66 | fixTails :: (Eq a, Eq b, Hashable a, Hashable b) => [(b, Context' a b)] -> Gr a b 67 | fixTails ls 68 | = let es = foldl' (\es' (s, Context' ps _) -> map (\(Head l p) -> Edge p l s) (HS.toList ps) ++ es') [] ls 69 | in Gr $ foldl' (flip insTail) (HM.fromList ls) es 70 | 71 | minEdge :: Ord a => (b, Head a b) -> (b, Head a b) -> (b, Head a b) 72 | minEdge e1@(_, Head l1 _) e2@(_, Head l2 _) = if l1 < l2 then e1 else e2 73 | 74 | minHead :: Ord a => Head a b -> Head a b -> Head a b 75 | minHead hd1@(Head l1 _) hd2@(Head l2 _) = if l1 < l2 then hd1 else hd2 76 | 77 | ---------------------------------- 78 | -- Use just a min-heap 79 | 80 | primHeap :: (Eq a, Eq b, Hashable a, Hashable b, Ord a) => Gr a b -> Context a b -> Gr a b 81 | primHeap g (node,Context' _ sucs) = fixTails $ go (order g - 1) HS.empty H.empty (node,Context' HS.empty sucs) 82 | where 83 | go 0 _ _ _ = [] 84 | go count !visited !edgeHeap (n,Context' ps ss) = 85 | let newVisited = HS.insert n visited 86 | in case pickNextEdge newVisited (addTailsHeap n newVisited edgeHeap ss) of 87 | Just (newEdgeHeap, newCtx) -> (n, Context' ps HS.empty) : go (count - 1) newVisited newEdgeHeap newCtx 88 | Nothing -> [(n, Context' ps HS.empty)] 89 | pickNextEdge visited edgeHeap = H.uncons edgeHeap >>= \(Edge p l s, newHeap) -> 90 | if HS.member s visited 91 | then pickNextEdge visited newHeap 92 | else Just (newHeap, (s,Context' (HS.singleton (Head l p)) (tails (g!s)))) 93 | 94 | addTailsHeap :: (Eq b, Hashable b, Ord a) 95 | => b 96 | -> HS.HashSet b 97 | -> H.Heap (Edge a b) 98 | -> HS.HashSet (Tail a b) 99 | -> H.Heap (Edge a b) 100 | addTailsHeap p visited = HS.foldl' checkedInsert 101 | where 102 | checkedInsert heap (Tail l s) 103 | = if HS.member s visited 104 | then heap 105 | else H.insert (Edge p l s) heap 106 | 107 | ---------------------------------- 108 | -- Use both! 109 | 110 | primBoth :: (Eq a, Eq b, Hashable a, Hashable b, Ord a) => Gr a b -> Context a b -> Gr a b 111 | primBoth g (node,Context' _ sucs) = fixTails $ go HS.empty HM.empty H.empty (node,Context' HS.empty sucs) 112 | where 113 | go !visited !optimal !edgeHeap (n,Context' ps ss) = 114 | let newVisited = HS.insert n visited 115 | in case pickNextEdge newVisited (addTailsBoth n newVisited optimal edgeHeap ss) of 116 | Just (newEdgeHeap, newOpt, newCtx) -> (n, Context' ps HS.empty) : go newVisited newOpt newEdgeHeap newCtx 117 | Nothing -> [(n, Context' ps HS.empty)] 118 | pickNextEdge visited (opt, edgeHeap) 119 | | HM.null opt = Nothing 120 | | otherwise = H.uncons edgeHeap >>= \(Edge p l s, newHeap) -> if HS.member s visited 121 | then pickNextEdge visited (opt, newHeap) 122 | else Just (newHeap, HM.delete s opt, (s,Context' (HS.singleton (Head l p)) (tails (g!s)))) 123 | 124 | addTailsBoth :: (Eq b, Hashable b, Ord a) 125 | => b 126 | -> HS.HashSet b 127 | -> HM.HashMap b (Head a b) 128 | -> H.Heap (Edge a b) 129 | -> HS.HashSet (Tail a b) 130 | -> (HM.HashMap b (Head a b), H.Heap (Edge a b)) 131 | addTailsBoth p visited optimal edgeHeap = HS.foldl' checkedInsert (optimal, edgeHeap) 132 | where 133 | checkedInsert (opt, heap) (Tail l s) 134 | | HS.member s visited = (opt,heap) 135 | | otherwise = case HM.lookup s opt of 136 | Just (Head l' _) -> 137 | if l' <= l 138 | then (opt, heap) 139 | else (HM.insert s (Head l p) opt, H.insert (Edge p l s) heap) 140 | Nothing -> (HM.insert s (Head l p) opt, H.insert (Edge p l s) heap) 141 | 142 | -------------------------------- 143 | -- Kruskal 144 | 145 | -- | Kruskal's algorithm for the minimum spanning tree 146 | kruskal :: Gr a b -> Gr a b 147 | kruskal g = undefined 148 | -------------------------------------------------------------------------------- /benchmarks/Benchmark.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | module Main where 4 | 5 | -- New library imports 6 | import qualified Data.HashGraph.Strict as G 7 | import qualified Data.HashGraph.Algorithms as G 8 | 9 | -- FGL imports 10 | import qualified Data.Graph.Inductive.Basic as Old 11 | import qualified Data.Graph.Inductive.Graph as Old 12 | import qualified Data.Graph.Inductive.PatriciaTree as Old 13 | import qualified Data.Graph.Inductive.Query as Old 14 | 15 | import qualified Data.HashSet as HS 16 | import Control.DeepSeq (NFData(..)) 17 | import Criterion.Main 18 | 19 | main :: IO () 20 | main = defaultMain 21 | [ fgl 1000 -- Benchmark original FGL library 22 | , hashGraph 1000 -- Compare against original FGL library 23 | , oldDetails 1000 -- Detailed benchmarks from old implementation 24 | , details 1000 -- Detailed benchmarks from current implementation 25 | , algos -- Benchmark graph algorithms 26 | ] 27 | 28 | ------------------------------ 29 | -- * FGL (original library) benchmarks 30 | 31 | -- | Benchmark original library 32 | fgl :: Int -> Benchmark 33 | fgl n = let graph = buildOld (oldEdges n) (oldNodes n) in 34 | 35 | bgroup "old" 36 | [ bgroup "construction" 37 | [ bench "mkGraph" $ whnf (buildOld (oldEdges n)) (oldNodes n) 38 | , bench "fromList" $ whnf (Old.buildGr :: [Old.Context a b] -> Old.Gr a b) (oldCtxts n) 39 | ] 40 | 41 | -- Basic Interface 42 | , bgroup "basic" 43 | [ bench "null" $ whnf Old.isEmpty graph 44 | , bench "match" $ nf (Old.match n) graph 45 | , bench "matchAny" $ nf Old.matchAny graph 46 | , bench "nodes" $ nf Old.labNodes graph 47 | , bench "order" $ whnf Old.order graph 48 | , bench "edges" $ nf Old.labEdges graph 49 | , bench "size" $ whnf Old.size graph 50 | , bench "(&)" $ whnf (([], n+1, n+1, []) Old.&) graph 51 | ] 52 | 53 | -- Maps 54 | , bgroup "maps" 55 | [ bench "nmap" $ nf (Old.nmap id) graph 56 | , bench "emap" $ nf (Old.emap id) graph 57 | , bench "nemap" $ nf (Old.nemap id id) graph 58 | , bench "ctxMap" $ nf (Old.gmap id) graph 59 | ] 60 | 61 | -- Folds 62 | , bgroup "folds" 63 | [ bench "foldr" $ whnf (Old.ufold (\(_, _, a, _) c -> a + c) 0) graph 64 | ] 65 | 66 | -- Queries 67 | , bgroup "queries" 68 | [ bench "member" $ whnf (Old.gelem (n-1)) graph 69 | , bench "neighbors" $ nf (flip Old.neighbors (n-1)) graph 70 | , bench "preds" $ nf (flip Old.pre (n-1)) graph 71 | , bench "succs" $ nf (flip Old.suc (n-1)) graph 72 | , bench "inEdges" $ nf (flip Old.inn (n-1)) graph 73 | , bench "outEdges" $ nf (flip Old.out (n-1)) graph 74 | , bench "inDegree" $ whnf (flip Old.indeg (n-1)) graph 75 | , bench "outDegree" $ whnf (flip Old.outdeg (n-1)) graph 76 | , bench "degree" $ whnf (flip Old.deg (n-1)) graph 77 | , bench "hasEdge" $ whnf (flip Old.hasEdge (n-1,n-2)) graph 78 | , bench "hasNeighbor" $ whnf ((\x y z -> Old.hasNeighbor z x y) (n-1) (n-2)) graph 79 | ] 80 | 81 | -- Filters 82 | , bgroup "filters" 83 | [ bench "gfiltermap" $ whnf (Old.gfiltermap Just) graph 84 | , bench "nfilter (label)" $ nf (Old.labnfilter (const True)) graph 85 | , bench "nfilter (node)" $ nf (Old.nfilter (const True)) graph 86 | , bench "efilter" $ whnf (Old.efilter (const True)) graph 87 | , bench "subgraph" $ whnf (Old.subgraph [1..n `div` 2]) graph 88 | ] 89 | 90 | -- Insertion and Deletion 91 | , bgroup "insertion and deletion" 92 | [ bench "insNode" $ whnf (Old.insNode (n+1, n+1)) graph 93 | , bench "delNode" $ whnf (Old.delNode (n-1)) graph 94 | , bench "insEdge" $ whnf (Old.insEdge (1,1,1)) graph 95 | , bench "delEdge" $ whnf (Old.delEdge (n-1,n-1)) graph 96 | , bench "insNodes" $ whnf (Old.insNodes [(x,x) | x <- [n+1..n+10]]) graph 97 | , bench "delNodes" $ whnf (Old.delNodes [1..n `div` 2]) graph 98 | , bench "insEdges" $ whnf (Old.insEdges [(1,1,1)]) graph 99 | , bench "delEdges" $ whnf (Old.delEdges [(x,y) | x <- [n-1], y <- [1..n-1]]) graph 100 | ] 101 | 102 | -- Algorithms 103 | , bgroup "algorithms" 104 | [ bench "bfs" $ nf (Old.bfs (n-1)) graph 105 | , bench "dfs" $ nf (Old.dfs [n-1]) graph 106 | , bench "mst" $ nf (Old.msTreeAt n) graph 107 | ] 108 | ] 109 | 110 | -- To `nf` the `msTree` results we need this instance 111 | instance (NFData a) => NFData (Old.LPath a) where 112 | rnf (Old.LP lp) = rnf lp 113 | 114 | ------------------------------ 115 | -- * hash-graph (new library) benchmarks 116 | 117 | hashGraph :: Int -> Benchmark 118 | hashGraph n = let graph = G.fromList (listGraph n) in 119 | 120 | bgroup "new" 121 | -- Construction functions 122 | [ bgroup "construction" 123 | [ bench "singleton" $ whnf (G.singleton :: Int -> G.Gr Int Int) n 124 | , bench "mkGraph" $ whnf (G.mkGraph (newEdges n)) [1..n] 125 | , bench "fromList" $ whnf G.fromList (listGraph n) 126 | ] 127 | 128 | -- Basic interface 129 | , bgroup "basic" 130 | [ bench "null" $ whnf G.null graph 131 | , bench "nodes" $ nf G.nodes graph 132 | , bench "order" $ whnf G.order graph 133 | , bench "edges" $ nf G.edges graph 134 | , bench "size" $ whnf G.size graph 135 | , bench "(!)" $ whnf (G.! n) graph 136 | , bench "(!?)" $ whnf (G.!? n) graph 137 | , bench "match" $ nf (G.match n) graph 138 | , bench "matchAny" $ nf G.matchAny graph 139 | , bench "(&)" $ whnf ((n+1,G.Context' HS.empty HS.empty) G.&) graph 140 | ] 141 | 142 | -- Maps 143 | , bgroup "maps" 144 | [ bench "nmap" $ whnf (G.nmap id) graph 145 | , bench "emap" $ whnf (G.emap id) graph 146 | , bench "nemap" $ whnf (G.nemapH id id) graph 147 | ] 148 | 149 | -- Folds 150 | , bgroup "folds" 151 | [ bench "foldr" $ whnf (G.foldr (+) 0) graph 152 | ] 153 | 154 | -- Queries 155 | , bgroup "queries" 156 | [ bench "member" $ whnf (G.member n) graph 157 | , bench "neighbors" $ nf (G.neighbors n) graph 158 | , bench "preds" $ nf (G.preds n) graph 159 | , bench "succs" $ nf (G.succs n) graph 160 | , bench "inEdges" $ nf (G.inEdges n) graph 161 | , bench "outEdges" $ nf (G.outEdges n) graph 162 | , bench "inDegree" $ whnf (G.inDegree n) graph 163 | , bench "outDegree" $ whnf (G.outDegree n) graph 164 | , bench "degree" $ whnf (G.degree n) graph 165 | , bench "hasEdge" $ whnf (G.hasEdge (G.Edge (n-1) ((n-1)*(n-2)) (n-2))) graph 166 | , bench "hasNeighbor" $ whnf (G.hasNeighbor (n-1) (n-2)) graph 167 | ] 168 | 169 | -- Filters 170 | , bgroup "filters" 171 | [ bench "nfilter" $ whnf (G.nfilter (const True)) graph 172 | , bench "efilter" $ whnf (G.efilter (const True)) graph 173 | ] 174 | 175 | -- Insertion and Deletion 176 | , bgroup "insertion and deletion" 177 | [ bench "insNode" $ whnf (G.insNode (n+1)) graph 178 | , bench "safeInsNode" $ whnf (G.safeInsNode (n+1)) graph 179 | , bench "delNode" $ whnf (G.delNode n) graph 180 | , bench "insEdge" $ whnf (G.insEdge (G.Edge 1 1 1)) graph 181 | , bench "delEdge" $ whnf (G.delEdge (G.Edge n (n*n) n)) graph 182 | ] 183 | 184 | -- Algorithms 185 | , bgroup "algorithms" 186 | [ bench "bfs" $ nf (G.bfsn (n-1)) graph 187 | , bench "dfs" $ nf (G.dfsn (n-1)) graph 188 | , bench "mst" $ nf G.prim graph 189 | ] 190 | ] 191 | 192 | ------------------------------ 193 | -- * Detailed benchmarks 194 | 195 | details :: Int -> Benchmark 196 | details n = let graph = G.fromList (listGraph n) in 197 | 198 | bgroup "new/details" 199 | [ bgroup "insertion" 200 | [ bench "insNode" $ whnf (G.insNode (n+1)) graph 201 | , bench "insNode-dup" $ whnf (G.insNode (n-1)) graph 202 | , bench "insEdge" $ whnf (G.insEdge (G.Edge 1 1 1)) graph 203 | , bench "insEdge-dup" $ whnf (G.insEdge (G.Edge n (n*n) n)) graph 204 | ] 205 | 206 | , bgroup "deletion" 207 | [ bench "delNode" $ whnf (G.delNode (n-1)) graph 208 | , bench "delNode-miss" $ whnf (G.delNode (n+1)) graph 209 | , bench "delEdge" $ whnf (G.delEdge (G.Edge n (n*n) n)) graph 210 | , bench "delEdge-miss" $ whnf (G.delEdge (G.Edge 1 1 1)) graph 211 | ] 212 | 213 | , bgroup "lookup" 214 | [ bench "lookup" $ whnf (G.!? (n-1)) graph 215 | , bench "lookup-miss" $ whnf (G.!? (n+1)) graph 216 | ] 217 | ] 218 | 219 | oldDetails :: Int -> Benchmark 220 | oldDetails n = let graph = Old.buildGr (oldCtxts n) :: Old.Gr Int Int in 221 | 222 | bgroup "old/details" 223 | [ bgroup "insertion" 224 | [ bench "insNode" $ whnf (Old.insNode (n+1, n+1)) graph 225 | , bench "insNode-dup" $ whnf (Old.insNode (n-1, n-1)) graph 226 | , bench "insEdge" $ whnf (Old.insEdge (1,1,1)) graph 227 | , bench "insEdge-dup" $ whnf (Old.insEdge (1,2,2)) graph 228 | ] 229 | 230 | , bgroup "deletion" 231 | [ bench "delNode" $ whnf (Old.delNode (n-1)) graph 232 | , bench "delNode-miss" $ whnf (Old.delNode (n+1)) graph 233 | , bench "delEdge" $ whnf (Old.delEdge (n-1,n-1)) graph 234 | , bench "delEdge-miss" $ whnf (Old.delEdge (1,1)) graph 235 | ] 236 | ] 237 | 238 | ------------------------------ 239 | -- * Algorithm benchmarks 240 | 241 | algos :: Benchmark 242 | algos = bgroup "algos" [] 243 | 244 | ------------------------------ 245 | -- Utilities 246 | 247 | -- | Build a complete graph using fgl 248 | buildOld :: [Old.LEdge Int] -> [Old.LNode Int] -> Old.Gr Int Int 249 | buildOld es ns = Old.mkGraph ns es 250 | 251 | -- | Build a complete graph using fgl list of ctxts 252 | buildOldList :: [Old.Context Int Int] -> Old.Gr Int Int 253 | buildOldList ctxts = Old.buildGr ctxts 254 | 255 | -- | Generate old edges from number of nodes 256 | -- Exclude (1, 1, 1) for testing purposes 257 | oldEdges :: Int -> [(Int, Int, Int)] 258 | oldEdges n = tail $ (\x y -> (x,y,x*y)) <$> [1..n] <*> [1..n] 259 | 260 | -- | Generate old nodes from number of nodes 261 | oldNodes :: Int -> [(Int, Int)] 262 | oldNodes n = map (\x -> (x,x)) [1..n] 263 | 264 | -- | Generate old Contexts to build a complete graph 265 | oldCtxts :: Int -> [Old.Context Int Int] 266 | oldCtxts n = first : [([(n'*n'',n'') | n'' <- [1..n']], n', n', [(n'*n'',n'') | n'' <- [1..n']]) | n' <- [2..n]] 267 | where 268 | first :: Old.Context Int Int 269 | first = ([], 1, 1, []) 270 | 271 | -- | Generate new edges from number of nodes 272 | -- Exclude (1, 1, 1) for testing purposes 273 | newEdges :: Int -> [G.Edge Int Int] 274 | newEdges n = tail $ (\x y -> G.Edge x (x*y) y) <$> [1..n] <*> [1..n] 275 | 276 | listGraph :: Int -> [G.Context Int Int] 277 | listGraph n = first : [ (n', G.Context' (HS.fromList [G.Head (n'*n'') n'' | n'' <- [1..n]]) 278 | (HS.fromList [G.Tail (n'*n'') n'' | n'' <- [1..n]])) | n' <- [2..n] ] 279 | where 280 | first = (1, G.Context' (HS.fromList [G.Head n'' n'' | n'' <- [2..n]]) (HS.fromList [G.Tail n'' n'' | n'' <- [2..n]])) 281 | -------------------------------------------------------------------------------- /tests/Test.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Data.HashGraph.Strict as G 4 | import qualified Data.HashGraph.Algorithms as GA 5 | 6 | import Control.Exception (evaluate) 7 | import qualified Data.HashSet as HS 8 | import Data.List (nub, sort) 9 | 10 | import Test.Hspec 11 | import Test.Hspec.QuickCheck 12 | import Test.QuickCheck ((===)) 13 | 14 | type TestGraph = G.Gr Int Char 15 | 16 | main :: IO () 17 | main = hspec $ do 18 | library 19 | algos 20 | 21 | 22 | library :: Spec 23 | library = describe "Strict Graphs" $ do 24 | 25 | -- Construction 26 | describe "Construction" $ do 27 | describe "empty" $ do 28 | let e = G.empty :: TestGraph 29 | it "is null" $ 30 | G.null e `shouldBe` True 31 | it "has no nodes" $ 32 | G.nodes e `shouldBe` [] 33 | it "has no edges" $ 34 | G.edges e `shouldBe` [] 35 | it "has order 0" $ 36 | G.order e `shouldBe` 0 37 | it "has size 0" $ 38 | G.size e `shouldBe` 0 39 | describe "singleton" $ do 40 | let g = G.singleton 'a' :: TestGraph 41 | it "is not null" $ 42 | G.null g `shouldBe` False 43 | it "has one node" $ 44 | G.nodes g `shouldBe` ['a'] 45 | it "has no edges" $ 46 | G.edges g `shouldBe` [] 47 | it "has order 1" $ 48 | G.order g `shouldBe` 1 49 | it "has size 0" $ 50 | G.size g `shouldBe` 0 51 | describe "mkGraph" $ do 52 | let e = G.empty :: TestGraph 53 | edgeList ns = (\x y -> G.Edge x 1 y) <$> ns <*> ns 54 | it "makes the empty graph" $ 55 | (G.mkGraph [] [] :: TestGraph) `shouldBe` e 56 | prop "makes the correct number of nodes" $ 57 | \ns -> G.order (G.mkGraph [] ns :: TestGraph) === length (nub ns) 58 | prop "makes the correct set of nodes" $ 59 | \ns -> let nodeList = G.nodes (G.mkGraph [] ns :: TestGraph) 60 | in sort nodeList === sort (nub ns) 61 | prop "makes the correct number of edges" $ 62 | \ns -> let graph = G.mkGraph (edgeList ns) ns :: TestGraph 63 | in G.size graph === length (nub ns) * length (nub ns) 64 | prop "makes the correct set of edges" $ 65 | \ns -> let es = G.edges (G.mkGraph (edgeList ns) ns :: TestGraph) 66 | in HS.fromList es === HS.fromList (edgeList ns) 67 | 68 | -- Basic Interface 69 | describe "Basic Interface" $ do 70 | describe "null" $ 71 | it "is described throughout" $ True `shouldBe` True 72 | describe "order" $ 73 | it "is described throughout" $ True `shouldBe` True 74 | describe "size" $ 75 | it "is described throughout" $ True `shouldBe` True 76 | describe "match" $ do 77 | let gr = G.mkGraph [] ['a'] :: TestGraph 78 | it "finds and removes nodes in the graph" $ 79 | G.match 'a' gr `shouldBe` Just (('a',G.Context' HS.empty HS.empty), G.empty) 80 | it "doesn't find nodes not in the graph" $ 81 | G.match 'b' gr `shouldBe` Nothing 82 | describe "matchAny" $ do 83 | let gr = G.mkGraph [] ['a'] :: TestGraph 84 | it "finds nodes when the graph is non-empty" $ 85 | G.matchAny gr `shouldBe` Just (('a', G.Context' HS.empty HS.empty), G.empty) 86 | it "does not find a node when the graph is empty" $ 87 | G.matchAny (G.empty :: TestGraph) `shouldBe` Nothing 88 | --describe "(&)" $ do 89 | describe "(!)" $ do 90 | let gr = G.mkGraph [] ['a'] :: TestGraph 91 | it "finds nodes in the graph" $ 92 | gr G.! 'a' `shouldBe` G.Context' HS.empty HS.empty 93 | it "doesn't find nodes not in the graph" $ 94 | evaluate (gr G.! 'b') `shouldThrow` errorCall "Data.Graph.Inductive.Strict.(!): node not found" 95 | describe "(!?)" $ do 96 | let gr = G.mkGraph [] ['a'] :: TestGraph 97 | it "finds nodes in the graph" $ 98 | gr G.!? 'a' `shouldBe` Just (G.Context' HS.empty HS.empty) 99 | it "doesn't find nodes not in the graph" $ 100 | gr G.!? 'b' `shouldBe` Nothing 101 | describe "nodes" $ 102 | it "is described throughout" $ True `shouldBe` True 103 | describe "edges" $ 104 | it "is described throughout" $ True `shouldBe` True 105 | 106 | -- Maps 107 | describe "Maps" $ do 108 | let fn = (:[]) 109 | fe = (*(-1)) 110 | edgeList ns = (\x y -> G.Edge x 1 y) <$> ns <*> ns 111 | gr = G.mkGraph (edgeList "ab") "ab" 112 | describe "node map" $ do 113 | it "adjusts every node" $ 114 | G.nodes (G.nmap fn gr :: G.Gr Int String) `shouldBe` ["a","b"] 115 | it "adjusts every edge" $ 116 | G.edges (G.nmap fn gr :: G.Gr Int String) 117 | `shouldBe` [ G.Edge "b" 1 "b" 118 | , G.Edge "b" 1 "a" 119 | , G.Edge "a" 1 "b" 120 | , G.Edge "a" 1 "a" ] 121 | describe "edge map" $ 122 | it "adjusts every edge" $ 123 | G.edges (G.emap fe gr :: G.Gr Int Char) 124 | `shouldBe` [ G.Edge 'b' (-1) 'b' 125 | , G.Edge 'b' (-1) 'a' 126 | , G.Edge 'a' (-1) 'b' 127 | , G.Edge 'a' (-1) 'a' ] 128 | describe "node and Edge map" $ 129 | it "is described by node map and edge map" $ True `shouldBe` True 130 | 131 | -- Folds 132 | describe "Folds" $ 133 | describe "foldr" $ 134 | prop "works like a list" $ 135 | \ns -> 136 | let graph = G.mkGraph [] ns :: TestGraph in 137 | length (G.foldr (:) [] graph) 138 | === length (foldr (:) [] (nub ns)) 139 | 140 | -- Queries 141 | describe "Queries" $ do 142 | let edgeList ns = (\x y -> G.Edge x 1 y) <$> ns <*> ns 143 | gr = G.mkGraph (tail (edgeList "abcde")) "abcde" 144 | describe "member" $ do 145 | it "returns True for a node in the graph" $ 146 | G.member 'a' gr `shouldBe` True 147 | it "returns False for a node not in the graph" $ 148 | G.member 'z' gr `shouldBe` False 149 | describe "neighbors" $ do 150 | it "returns `Just lst` for a node in the graph" $ 151 | G.neighbors 'a' gr `shouldBe` Just "bcde" 152 | it "returns `Nothing` for a node not in the graph" $ 153 | G.neighbors 'z' gr `shouldBe` Nothing 154 | describe "preds" $ do 155 | it "returns `Just lst` for a node in the graph" $ 156 | G.preds 'a' gr `shouldBe` Just "bcde" 157 | it "returns `Nothing` for a node not in the graph" $ 158 | G.preds 'z' gr `shouldBe` Nothing 159 | describe "succs" $ do 160 | it "returns `Just lst` for a node in the graph" $ 161 | G.succs 'a' gr `shouldBe` Just "bcde" 162 | it "returns `Nothing` for a node not in the graph" $ 163 | G.succs 'z' gr `shouldBe` Nothing 164 | describe "inEdges" $ do 165 | it "returns `Just lst` for a node in the graph" $ 166 | G.inEdges 'a' gr `shouldBe` (Just [ G.Edge 'b' 1 'a' 167 | , G.Edge 'c' 1 'a' 168 | , G.Edge 'd' 1 'a' 169 | , G.Edge 'e' 1 'a' ] :: Maybe [G.Edge Int Char]) 170 | it "returns `Nothing` for a node not in the graph" $ 171 | G.inEdges 'z' gr `shouldBe` Nothing 172 | describe "outEdges" $ do 173 | it "returns `Just lst` for a node in the graph" $ 174 | G.outEdges 'a' gr `shouldBe` (Just [ G.Edge 'a' 1 'b' 175 | , G.Edge 'a' 1 'c' 176 | , G.Edge 'a' 1 'd' 177 | , G.Edge 'a' 1 'e' ] :: Maybe [G.Edge Int Char]) 178 | it "returns `Nothing` for a node not in the graph" $ 179 | G.outEdges 'z' gr `shouldBe` Nothing 180 | describe "inDegree" $ do 181 | it "returns `Just int` for a node in the graph" $ 182 | G.inDegree 'b' gr `shouldBe` Just 5 183 | it "returns `Nothing` for a node not in the graph" $ 184 | G.inDegree 'z' gr `shouldBe` Nothing 185 | describe "outDegree" $ do 186 | it "returns `Just int` for a node in the graph" $ 187 | G.outDegree 'b' gr `shouldBe` Just 5 188 | it "returns `Nothing` for a node not in the graph" $ 189 | G.outDegree 'z' gr `shouldBe` Nothing 190 | describe "degree" $ do 191 | it "returns `Just int` for a node in the graph" $ 192 | G.degree 'b' gr `shouldBe` Just 10 193 | it "returns `Nothing` for a node not in the graph" $ 194 | G.degree 'z' gr `shouldBe` Nothing 195 | describe "hasEdge" $ do 196 | it "returns `True` for an edge in the graph" $ 197 | G.hasEdge (G.Edge 'a' 1 'b' :: G.Edge Int Char) gr `shouldBe` True 198 | it "returns `False` for an edge not in the graph" $ 199 | G.hasEdge (G.Edge 'a' 1 'a' :: G.Edge Int Char) gr `shouldBe` False 200 | describe "hasNeighbor" $ do 201 | it "returns `True` if the second node is a neighbor of the first" $ 202 | G.hasNeighbor 'a' 'b' gr `shouldBe` True 203 | it "returns `False` otherwise" $ 204 | G.hasNeighbor 'z' 'a' gr `shouldBe` False 205 | 206 | -- Filters 207 | describe "Filters" $ do 208 | let edgeList ns = (\x y -> G.Edge x 1 y) <$> ns <*> ns 209 | gr = G.mkGraph (tail (edgeList "abcde")) "abcde" :: TestGraph 210 | describe "node filter" $ 211 | prop "filters" $ 212 | \ns -> sort (G.nodes (G.nfilter (/= 'a') (G.mkGraph [] ns :: TestGraph))) === filter (/= 'a') (sort (nub ns)) 213 | describe "edge filter" $ 214 | it "filters edges" $ 215 | G.edges (G.efilter (\(G.Edge x _ _) -> x == 'a') gr) `shouldBe` [ G.Edge 'a' 1 'b' 216 | , G.Edge 'a' 1 'c' 217 | , G.Edge 'a' 1 'd' 218 | , G.Edge 'a' 1 'e' 219 | ] 220 | {- 221 | -- Insertion and Deletion 222 | describe "Insertion and Deletion" $ do 223 | describe "insNode" $ do 224 | describe "safeInsNode" $ do 225 | describe "delNode" $ do 226 | describe "insEdge" $ do 227 | -} 228 | 229 | algos :: Spec 230 | algos = describe "algorithms" $ do 231 | let es = [ G.Edge 'a' 1 'b', G.Edge 'a' 1 'c', G.Edge 'b' 1 'd', G.Edge 'b' 1 'e', G.Edge 'c' 1 'f', G.Edge 'c' 1 'g' ] 232 | lineEs = [ G.Edge 'a' 1 'b', G.Edge 'b' 1 'c', G.Edge 'c' 1 'd' ] 233 | treeGraph = G.mkGraph es "abcdefg" :: TestGraph 234 | lineGraph = G.mkGraph lineEs "abcd" :: TestGraph 235 | describe "bfs" $ 236 | it "creates the correct list" $ 237 | GA.bfs treeGraph `shouldBe` ['a','b','c','f','g','d','e'] 238 | describe "dfs" $ 239 | it "creates the correct list" $ 240 | GA.dfs treeGraph `shouldBe` ['a','b','d','e','c','f','g'] 241 | describe "topSort" $ 242 | it "sorts a line" $ 243 | GA.topSort lineGraph `shouldBe` Just ['a','b','c','d'] 244 | describe "topSort" $ 245 | it "sorts a tree" $ 246 | GA.topSort treeGraph `shouldBe` Just ['a','c','g','f','b','e','d'] 247 | -------------------------------------------------------------------------------- /Data/HashGraph/Strict.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | ------------------------------------- 4 | -- | 5 | -- Module : Data.HashGraph.Strict 6 | -- Copyright : 2017 Patrick Dougherty 7 | -- License : BSD2 8 | -- Maintainer : Patrick Dougherty 9 | -- 10 | -- A hashing-based graph implementation. 11 | 12 | module Data.HashGraph.Strict ( 13 | -- * Graph Type 14 | Gr(..) 15 | 16 | -- * Construction 17 | , empty 18 | , singleton 19 | , mkGraph 20 | 21 | -- * Basic interface 22 | , null 23 | , nodes 24 | , order 25 | , edges 26 | , size 27 | , (!) 28 | , (!?) 29 | 30 | -- * Inductive 31 | , (&) 32 | , match 33 | , matchAny 34 | 35 | -- * Maps 36 | , nmap 37 | , emap 38 | , nemapH 39 | 40 | -- * Folds 41 | , foldr 42 | 43 | -- * Queries 44 | , member 45 | , neighbors 46 | , preds 47 | , succs 48 | , inEdges 49 | , outEdges 50 | , inDegree 51 | , outDegree 52 | , degree 53 | , hasEdge 54 | , hasNeighbor 55 | 56 | -- * Filters 57 | , nfilter 58 | , efilter 59 | 60 | -- * Insertion and Deletion 61 | , insNode 62 | , safeInsNode 63 | , delNode 64 | , insEdge 65 | , delEdge 66 | 67 | -- * Lists 68 | , toList 69 | , fromList 70 | , fromListWith 71 | 72 | -- * Pretty printing 73 | , pretty 74 | 75 | -- The rest 76 | , Context'(..) 77 | , Edge(..) 78 | , Head(..) 79 | , Tail(..) 80 | , Context 81 | , insTail 82 | ) where 83 | 84 | import Control.DeepSeq 85 | import Data.Hashable 86 | import qualified Data.List as L 87 | import qualified Data.HashMap.Strict as HM 88 | import qualified Data.HashSet as HS 89 | import Data.Maybe (fromMaybe) 90 | import GHC.Generics 91 | import Prelude hiding (foldr, null) 92 | 93 | -- Graph type 94 | type GraphRep a b = HM.HashMap b (Context' a b) 95 | newtype Gr a b = Gr (GraphRep a b) deriving (Eq, Show) 96 | 97 | instance (NFData a, NFData b) => NFData (Gr a b) where 98 | rnf (Gr hm) = rnf hm 99 | 100 | -- | The Edge type and corresponding half edges 101 | data Edge a b = Edge !b !a !b deriving (Eq, Generic, Show) 102 | data Head a b = Head !a !b deriving (Eq, Generic, Show) 103 | data Tail a b = Tail !a !b deriving (Eq, Generic, Show) 104 | 105 | instance (Eq a, Eq b, Ord a) => Ord (Edge a b) where 106 | compare (Edge _ l1 _) (Edge _ l2 _) = compare l1 l2 107 | 108 | instance (Hashable a, Hashable b) => Hashable (Edge a b) 109 | instance (Hashable a, Hashable b) => Hashable (Head a b) 110 | instance (Hashable a, Hashable b) => Hashable (Tail a b) 111 | 112 | instance (NFData a, NFData b) => NFData (Edge a b) 113 | instance (NFData a, NFData b) => NFData (Head a b) 114 | instance (NFData a, NFData b) => NFData (Tail a b) 115 | 116 | -- | The Context of a node within the Graph type 117 | data Context' a b = Context' 118 | { heads :: !(HS.HashSet (Head a b)) -- ^ Predecessors of the node 119 | , tails :: !(HS.HashSet (Tail a b)) -- ^ Successors of the node 120 | } deriving (Eq, Generic, Show) 121 | 122 | instance (NFData a, NFData b) => NFData (Context' a b) 123 | 124 | -- A node alongside its context' 125 | type Context a b = (b, Context' a b) 126 | 127 | ------------------------------- 128 | -- Construction 129 | 130 | -- | /O(1)/ Construct an empty graph 131 | empty :: Gr a b 132 | empty = Gr HM.empty 133 | 134 | -- | /O(1)/ Construct a graph with a single node 135 | singleton :: (Eq b, Hashable b) => b -> Gr a b 136 | singleton b = Gr $ HM.singleton b (Context' HS.empty HS.empty) 137 | 138 | -- TODO: cleanup and determine time complexity 139 | -- | Construct a graph from the given edges and nodes 140 | mkGraph :: (Eq a, Eq b, Hashable a, Hashable b) => [Edge a b] -> [b] -> Gr a b 141 | mkGraph es ns = L.foldl' (flip insEdge) nodeGraph es 142 | where 143 | nodeGraph = Gr $ HM.fromList $ map (\x -> (x, Context' HS.empty HS.empty)) ns 144 | {-# INLINE mkGraph #-} 145 | 146 | ------------------------------- 147 | -- Basic interface 148 | 149 | -- | /O(1)/ Return 'True' if this graph is empty, 'False' otherwise 150 | null :: Gr a b -> Bool 151 | null (Gr g) = HM.null g 152 | {-# INLINABLE null #-} 153 | 154 | -- | /O(n)/ Return the number of nodes in the graph 155 | order :: Gr a b -> Int 156 | order (Gr g) = HM.size g 157 | 158 | -- | /O(n+e)/ Return the number of edges in the graph 159 | size :: Gr a b -> Int 160 | size = L.foldl' (\c (_, Context' ps _) -> c + HS.size ps) 0 . toList 161 | 162 | infixl 9 !, !? 163 | -- | /O(log n)/ Return the 'Context' of a node in the graph. 164 | -- Call 'error' if the node is not in the graph. 165 | (!) :: (Eq b, Hashable b) => Gr a b -> b -> Context' a b 166 | (!) g n = fromMaybe (error "Data.Graph.Inductive.Strict.(!): node not found") $ g !? n 167 | 168 | -- | /O(log n)/ Return the 'Context' of a node if it is in the graph, 169 | -- or 'Nothing' if it is not. 170 | (!?) :: (Eq b, Hashable b) => Gr a b -> b -> Maybe (Context' a b) 171 | (!?) (Gr graph) n = HM.lookup n graph 172 | {-# INLINE (!?) #-} 173 | 174 | -- | /O(n)/ Return a list of the nodes in the graph. 175 | -- The list is produced lazily 176 | nodes :: Gr a b -> [b] 177 | nodes (Gr g) = HM.keys g 178 | 179 | -- TODO: Determine time complexity 180 | -- | /O(?)/ Return a list of the edges in the graph 181 | edges :: Gr a b -> [Edge a b] 182 | edges (Gr hm) = HM.foldlWithKey' (\lst p ctx -> getTails p ctx ++ lst) [] hm 183 | where 184 | getTails p (Context' _ ss) = HS.foldl' (\lst (Tail l s) -> Edge p l s : lst) [] ss 185 | 186 | -------------------------------------- 187 | -- Inductive 188 | 189 | -- | Extract a node from the graph 190 | match :: (Eq a, Eq b, Hashable a, Hashable b) => b -> Gr a b -> Maybe (Context a b, Gr a b) 191 | match n g = g !? n >>= \ctx -> Just ((n,ctx), delCtx n ctx g) 192 | {-# INLINE match #-} 193 | 194 | -- | Extract any node from the graph 195 | matchAny :: (Eq a, Eq b, Hashable a, Hashable b) => Gr a b -> Maybe (Context a b, Gr a b) 196 | matchAny g = L.uncons (toList g) >>= \((l,ctx),_) -> Just ((l,ctx), delCtx l ctx g) 197 | {-# INLINE matchAny #-} 198 | 199 | infixr 9 & 200 | -- TODO: Figure out how this should be implemented 201 | -- | Merge the 'Context' into the graph 202 | -- Currently deletes old node if present 203 | (&) :: (Eq a, Eq b, Hashable a, Hashable b) => Context a b -> Gr a b -> Gr a b 204 | (&) (l,ctx) (Gr g) = Gr $ HM.insert l ctx g 205 | 206 | -------------------------------------- 207 | -- Maps 208 | 209 | -- TODO: Clarify collisions after mapping 210 | -- TODO: Consider cmap for contexts 211 | 212 | -- | Map /f/ over the nodes. 213 | nmap :: (Eq a, Eq c, Hashable a, Hashable c) => (b -> c) -> Gr a b -> Gr a c 214 | nmap = nemapH id 215 | 216 | -- | Map /f/ over the edges. 217 | emap :: (Eq b, Eq c, Hashable b, Hashable c) => (a -> c) -> Gr a b -> Gr c b 218 | emap fe (Gr g) = Gr $ HM.map go g 219 | where 220 | go (Context' ps ss) = Context' (goHead ps) (goTail ss) 221 | goHead = HS.map (\(Head l p) -> Head (fe l) p) 222 | goTail = HS.map (\(Tail l s) -> Tail (fe l) s) 223 | 224 | -- HashMap based 225 | -- | Map /fe/ over the edges and /fn/ over the nodes. 226 | nemapH :: (Eq c, Eq d, Hashable c, Hashable d) => (a -> c) -> (b -> d) -> Gr a b -> Gr c d 227 | nemapH fe fn g = fromList $ map go $ toList g 228 | where 229 | go (n, Context' ps ss) = (fn n, Context' (goHead ps) (goTail ss)) 230 | goHead = HS.map (\(Head l p) -> Head (fe l) (fn p)) 231 | goTail = HS.map (\(Tail l s) -> Tail (fe l) (fn s)) 232 | 233 | -- Inductive based 234 | -- | Map /fe/ over the edges and /fn/ over the nodes. 235 | {- 236 | nemapI :: (a -> c) -> (b -> d) -> Gr a b -> Gr c d nemapI fe fn g = case matchAny g of 237 | Just (Context' ps l ss, g') -> Context' (goHead ps) (fn l) (goTail ss) & nemapI fe fn g' 238 | Nothing -> empty 239 | where 240 | goHead = HS.map (\(Head l p) -> Head (fe l) (fn p)) 241 | goTail = HS.map (\(Tail l s) -> Tail (fe l) (fn s)) 242 | -} 243 | 244 | --------------------------------------- 245 | -- Folds 246 | 247 | instance Foldable (Gr a) where 248 | foldr = foldr 249 | 250 | -- | HashMap based 251 | foldr :: (b -> c -> c) -> c -> Gr a b -> c 252 | foldr f x g = L.foldr (\(n, _) c -> f n c) x $ toList g 253 | 254 | ------------------------------------ 255 | -- Queries 256 | 257 | -- | /O(log n)/ Return 'True' if the given node is in the graph, 'False' otherwise. 258 | member :: (Eq b, Hashable b) => b -> Gr a b -> Bool 259 | member n (Gr g) = HM.member n g 260 | 261 | -- | /O(?)/ Return a list of the neighbors of the given node. 262 | neighbors :: (Eq b, Hashable b) => b -> Gr a b -> Maybe [b] 263 | neighbors n g = g !? n >>= \(Context' ps ss) -> 264 | let hds = HS.foldl' (\hs (Head _ p) -> HS.insert p hs) HS.empty ps 265 | in Just $ HS.toList $ HS.foldl' (\hs (Tail _ s) -> HS.insert s hs) hds ss 266 | 267 | -- | /O(?)/ Return a list of the predecessors of the given node. 268 | preds :: (Eq b, Hashable b) => b -> Gr a b -> Maybe [b] 269 | preds n g = HS.foldl' (\ls (Head _ p) -> p : ls) [] . heads <$> g !? n 270 | 271 | -- | /O(?)/ Return a list of the successors of the given node. 272 | succs :: (Eq b, Hashable b) => b -> Gr a b -> Maybe [b] 273 | succs n g = HS.foldl' (\ls (Tail _ s) -> s : ls) [] . tails <$> g !? n 274 | 275 | -- | /O(?)/ Return a list of the incoming edges to the node. 276 | inEdges :: (Eq b, Hashable b) => b -> Gr a b -> Maybe [Edge a b] 277 | inEdges n g = HS.foldl' (\ls (Head l p) -> Edge p l n : ls) [] . heads <$> g !? n 278 | 279 | -- | /O(?)/ Return a list of the outgoing edges from the node. 280 | outEdges :: (Eq b, Hashable b) => b -> Gr a b -> Maybe [Edge a b] 281 | outEdges n g = HS.foldl' (\ls (Tail l s) -> Edge n l s : ls) [] . tails <$> g !? n 282 | 283 | -- | /O(?)/ Return the number of incoming edges to the node. 284 | inDegree :: (Eq b, Hashable b) => b -> Gr a b -> Maybe Int 285 | inDegree b g = length <$> inEdges b g 286 | 287 | -- | /O(?)/ Return the number of outgoing edges from a node. 288 | outDegree :: (Eq b, Hashable b) => b -> Gr a b -> Maybe Int 289 | outDegree b g = length <$> outEdges b g 290 | 291 | -- | /O(?)/ Return the number of edges touching this node 292 | degree :: (Eq b, Hashable b) => b -> Gr a b -> Maybe Int 293 | degree n g = (+) <$> inDegree n g <*> outDegree n g 294 | 295 | -- | /O(?)/ Return 'True' if the graph contains the given edge, 'False' otherwise. 296 | hasEdge :: (Eq a, Eq b, Hashable a, Hashable b) => Edge a b -> Gr a b -> Bool 297 | hasEdge (Edge p l s) g = case g !? p of 298 | Just (Context' _ ss) -> HS.member (Tail l s) ss 299 | Nothing -> False 300 | 301 | -- | TODO: FIX, should be true if undirected edge between nodes 302 | -- | /O(?)/ Return 'True' if the given nodes are neighbors, 'False' otherwise. 303 | hasNeighbor :: (Eq b, Hashable b) => b -> b -> Gr a b -> Bool 304 | hasNeighbor n1 n2 g = case g !? n1 of 305 | Just (Context' _ ss) -> HS.foldl' (\t (Tail _ p) -> t || p == n2) False ss 306 | Nothing -> False 307 | 308 | ----------------------------- 309 | -- Filters 310 | 311 | {- 312 | - filter: 313 | - - contexts 314 | - - create subgraph from specific nodes? 315 | - ^ could just be nfilter (`elem` [Node]) 316 | -} 317 | 318 | -- | /O(n+e)/ Filter this graph by retaining only 319 | -- nodes that satisfy the predicate 'f'. 320 | nfilter :: (b -> Bool) -> Gr a b -> Gr a b 321 | nfilter f (Gr g) = Gr $ HM.mapMaybeWithKey go g 322 | where 323 | go n (Context' ps ss) = if f n 324 | then Just (Context' (HS.filter (\(Head _ p) -> f p) ps) 325 | (HS.filter (\(Tail _ s) -> f s) ss)) 326 | else Nothing 327 | 328 | -- | /O(n+e)/ Filter this graph by retaining only 329 | -- edges that satisfy the predicate 'f'. 330 | efilter :: (Edge a b -> Bool) -> Gr a b -> Gr a b 331 | efilter f (Gr g) = Gr $ HM.mapWithKey go g 332 | where 333 | go n (Context' ps ss) = Context' (HS.filter (\(Head l p) -> f (Edge p l n)) ps) 334 | (HS.filter (\(Tail l s) -> f (Edge n l s)) ss) 335 | 336 | ------------------------------ 337 | -- Insertion and Deletion 338 | 339 | -- | Insert a node, deleting the current context if the node exists 340 | insNode :: (Eq b, Hashable b) => b -> Gr a b -> Gr a b 341 | insNode n (Gr g) = Gr $ HM.insert n (Context' HS.empty HS.empty) g 342 | 343 | -- | Insert a node only if it does not already exist in the graph 344 | safeInsNode :: (Eq b, Hashable b) => b -> Gr a b -> Gr a b 345 | safeInsNode n g 346 | = if n `member` g 347 | then g 348 | else insNode n g 349 | 350 | -- | Insert a node, using the combining function if it already exists 351 | insNodeWith :: (Eq b, Hashable b) => (Context' a b -> Context' a b -> Context' a b) -> Context a b -> Gr a b -> Gr a b 352 | insNodeWith f (n,c) (Gr g) = Gr $ HM.insertWith f n c g 353 | 354 | -- | Remove a node and its edges 355 | delNode :: (Eq a, Eq b, Hashable a, Hashable b) => b -> Gr a b -> Gr a b 356 | delNode n g = case g !? n of 357 | Just ctx -> delCtx n ctx g 358 | Nothing -> g 359 | {-# INLINABLE delNode #-} 360 | 361 | -- | Remove a context 362 | delCtx :: (Eq a, Eq b, Hashable a, Hashable b) => b -> Context' a b -> Gr a b -> Gr a b 363 | delCtx n ctx (Gr graph) = Gr $ delHeads n ctx $ delTails n ctx $ HM.delete n graph 364 | 365 | -- TODO: Currently unsafe? check how adjust works 366 | insEdge :: (Eq a, Eq b, Hashable a, Hashable b) => Edge a b -> Gr a b -> Gr a b 367 | insEdge e (Gr g) = Gr $ insTail e (insHead e g) 368 | {-# INLINABLE insEdge #-} 369 | 370 | -- | Remove an edge 371 | delEdge :: (Eq a, Eq b, Hashable a, Hashable b) => Edge a b -> Gr a b -> Gr a b 372 | delEdge e (Gr g) = Gr $ delTail e (delHead e g) 373 | {-# INLINABLE delEdge #-} 374 | 375 | -- Insertion and Deletion Internals 376 | 377 | -- | Insert a head into the graph 378 | insHead :: (Eq a, Eq b, Hashable a, Hashable b) => Edge a b -> GraphRep a b -> GraphRep a b 379 | insHead (Edge p l s) = HM.adjust go s 380 | where 381 | go (Context' ps _ss) = Context' (HS.insert (Head l p) ps) _ss 382 | {-# INLINABLE insHead #-} 383 | 384 | -- | Remove a head from the graph 385 | delHead :: (Eq a, Eq b, Hashable a, Hashable b) => Edge a b -> GraphRep a b -> GraphRep a b 386 | delHead (Edge p l s) = HM.adjust go s 387 | where 388 | go (Context' ps _ss) = Context' (HS.delete (Head l p) ps) _ss 389 | {-# INLINABLE delHead #-} 390 | 391 | -- | Remove the head ends of tails attached to the node 392 | delHeads :: (Eq a, Eq b, Hashable a, Hashable b) => b -> Context' a b -> GraphRep a b -> GraphRep a b 393 | delHeads p (Context' _ ss) g = HS.foldl' go g ss 394 | where 395 | go hm (Tail l s) = delHead (Edge p l s) hm 396 | {-# INLINABLE delHeads #-} 397 | 398 | -- | Insert a tail into the graph 399 | insTail :: (Eq a, Eq b, Hashable a, Hashable b) => Edge a b -> GraphRep a b -> GraphRep a b 400 | insTail (Edge p l s) = HM.adjust go p 401 | where 402 | go (Context' _ps ss) = Context' _ps $ HS.insert (Tail l s) ss 403 | {-# INLINABLE insTail #-} 404 | 405 | -- | Remove a tail from the graph 406 | delTail :: (Eq a, Eq b, Hashable a, Hashable b) => Edge a b -> GraphRep a b -> GraphRep a b 407 | delTail (Edge p l s) = HM.adjust go p 408 | where 409 | go (Context' _ps ss) = Context' _ps $ HS.delete (Tail l s) ss 410 | {-# INLINABLE delTail #-} 411 | 412 | -- | Remove the head ends of tails attached to the node 413 | delTails :: (Eq a, Eq b, Hashable a, Hashable b) => b -> Context' a b -> GraphRep a b -> GraphRep a b 414 | delTails s (Context' ps _) g = HS.foldl' go g ps 415 | where 416 | go hm (Head l p) = delTail (Edge p l s) hm 417 | {-# INLINABLE delTails #-} 418 | 419 | ----------------------------------------- 420 | -- Equality? 421 | 422 | ---------------------------------------- 423 | -- Lists 424 | 425 | -- | /O(n)/ Return a list of this graph's elements. The list is 426 | -- produced lazily. The order of its elements is unspecified. 427 | toList :: Gr a b -> [Context a b] 428 | toList (Gr g) = HM.toList g 429 | 430 | -- | /O(n)/ Construct a graph with the supplied structure. If the 431 | -- list contains duplicate nodes, the later edges take precedence. 432 | fromList :: (Eq b, Hashable b) => [Context a b] -> Gr a b 433 | fromList = Gr . HM.fromList 434 | {-# INLINE fromList #-} 435 | 436 | -- | /O(n*log n)/ Construct a graph with the supplied structure. Uses 437 | -- the provided function to merge duplicate entries. 438 | fromListWith :: (Eq b, Hashable b) => (Context' a b -> Context' a b -> Context' a b) -> [Context a b] -> Gr a b 439 | fromListWith f = Gr . HM.fromListWith f 440 | 441 | ------------------------------------ 442 | -- Pretty Printing 443 | 444 | -- | Pretty-print the graph 445 | pretty :: (Show a, Show b) => Gr a b -> String 446 | pretty (Gr g) 447 | = HM.foldlWithKey' (\str n (Context' ps ss) -> show (HS.toList ps) ++ " -> " 448 | ++ show n 449 | ++ " -> " ++ show (HS.toList ss) 450 | ++ "\n" ++ str) [] g 451 | --------------------------------------------------------------------------------