├── .gitignore ├── README.md ├── tests ├── ConsoleRunner.elm ├── Test.elm ├── HtmlRunner.elm ├── elm-package.json └── Test │ ├── Graph │ └── Tree.elm │ └── Graph.elm ├── .travis.yml ├── elm-package.json └── src ├── Graph └── Tree.elm └── Graph.elm /.gitignore: -------------------------------------------------------------------------------- 1 | elm.js 2 | elm-stuff/ 3 | repl-temp-000.elm 4 | tests/elm-io.sh 5 | tests/*.js 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Development under this repository is discontinued. Use https://github.com/elm-community/graph instead! -------------------------------------------------------------------------------- /tests/ConsoleRunner.elm: -------------------------------------------------------------------------------- 1 | module Main exposing (..) 2 | 3 | import ElmTest exposing (..) 4 | import Test 5 | 6 | main : Program Never 7 | main = runSuite Test.tests 8 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | install: 3 | - cd tests/ 4 | - nvm install 6.2.1 5 | - npm install -g elm 6 | - npm install -g elm-test 7 | - elm-package install -y 8 | before_script: 9 | - elm-make --yes --output test.js ConsoleRunner.elm 10 | script: node test.js 11 | -------------------------------------------------------------------------------- /tests/Test.elm: -------------------------------------------------------------------------------- 1 | module Test exposing (tests) 2 | 3 | 4 | import Test.Graph 5 | import Test.Graph.Tree 6 | 7 | import ElmTest exposing (..) 8 | 9 | 10 | tests : Test 11 | tests = 12 | suite "elm-graph test suite" 13 | [ Test.Graph.tests 14 | , Test.Graph.Tree.tests 15 | ] 16 | -------------------------------------------------------------------------------- /tests/HtmlRunner.elm: -------------------------------------------------------------------------------- 1 | module Main exposing (..) 2 | 3 | import Html exposing (Html) 4 | import Element exposing (Element, leftAligned) 5 | import ElmTest exposing (stringRunner) 6 | import Text exposing (fromString) 7 | import Test 8 | 9 | main : Html Element 10 | main = 11 | Element.toHtml (leftAligned (fromString (stringRunner Test.tests))) 12 | -------------------------------------------------------------------------------- /elm-package.json: -------------------------------------------------------------------------------- 1 | { 2 | "version": "1.1.2", 3 | "summary": "Handling graphs the functional way.", 4 | "repository": "https://github.com/sgraf812/elm-graph.git", 5 | "license": "BSD3", 6 | "source-directories": [ 7 | "src" 8 | ], 9 | "exposed-modules": [ 10 | "Graph", 11 | "Graph.Tree" 12 | ], 13 | "dependencies": { 14 | "elm-lang/core": "4.0.1 <= v < 5.0.0", 15 | "evancz/focus": "2.0.1 <= v < 3.0.0", 16 | "imeckler/queue": "1.1.3 <= v < 2.0.0", 17 | "sgraf812/elm-intdict": "1.4.3 <= v < 2.0.0" 18 | }, 19 | "elm-version": "0.17.0 <= v < 0.18.0" 20 | } 21 | -------------------------------------------------------------------------------- /tests/elm-package.json: -------------------------------------------------------------------------------- 1 | { 2 | "version": "1.0.0", 3 | "summary": "elm-graph test suite", 4 | "repository": "https://github.com/sgraf812/elm-graph.git", 5 | "license": "BSD3", 6 | "source-directories": [ 7 | ".", 8 | "../src" 9 | ], 10 | "exposed-modules": [], 11 | "dependencies": { 12 | "elm-community/elm-test": "1.1.0 <= v < 2.0.0", 13 | "elm-lang/core": "4.0.1 <= v < 5.0.0", 14 | "elm-lang/html": "1.0.0 <= v < 2.0.0", 15 | "evancz/elm-graphics": "1.0.0 <= v < 2.0.0", 16 | "evancz/focus": "2.0.1 <= v < 3.0.0", 17 | "imeckler/queue": "1.1.3 <= v < 2.0.0", 18 | "sgraf812/elm-intdict": "1.4.3 <= v < 2.0.0" 19 | }, 20 | "elm-version": "0.17.0 <= v < 0.18.0" 21 | } -------------------------------------------------------------------------------- /tests/Test/Graph/Tree.elm: -------------------------------------------------------------------------------- 1 | module Test.Graph.Tree exposing (tests) 2 | 3 | import String 4 | import Debug 5 | import Graph.Tree as Tree exposing (Tree, Forest) 6 | 7 | import ElmTest exposing (..) 8 | 9 | 10 | size : Tree a -> Int 11 | size tree = 12 | tree 13 | |> Tree.preOrderList 14 | |> List.length 15 | 16 | 17 | tests : Test 18 | tests = 19 | let 20 | innerExample1 = Tree.inner 1 [Tree.leaf 2, Tree.leaf 3, Tree.leaf 4] 21 | innerExample2 = Tree.inner 1 [Tree.leaf 2, Tree.leaf 3, Tree.leaf 4, Tree.empty] 22 | 23 | buildingTests = 24 | suite "building" 25 | [ test "empty has no nodes" <| assertEqual 0 (size Tree.empty) 26 | , test "leaf has one node" <| assertEqual 1 (size (Tree.leaf 42)) 27 | , test "inner with 3 children has 3 nodes" <| 28 | assertEqual 4 (size innerExample1) 29 | , test "inner removes empty children" <| 30 | assertEqual innerExample1 innerExample2 31 | , test "unfoldTree" <| 32 | assertEqual 33 | innerExample1 34 | (Tree.unfoldTree (\s -> (s, if s == 1 then [2, 3, 4] else [])) 1) 35 | ] 36 | 37 | queryTests = 38 | suite "query" 39 | [ test "empty isEmpty" <| assertEqual True (Tree.isEmpty Tree.empty) 40 | , test "leaf is not empty" <| assertEqual False (Tree.isEmpty (Tree.leaf 42)) 41 | , test "inner with 2 children is not empty" <| 42 | assertEqual False (Tree.isEmpty (Tree.leaf ())) 43 | , test "root of a non-empty tree" <| 44 | assertEqual (Just (42, [])) (Tree.root (Tree.leaf 42)) 45 | , test "root of an empty tree" <| 46 | assertEqual Nothing (Tree.root Tree.empty) 47 | , test "size of a non-empty tree" <| 48 | assertEqual (Tree.size traversedTree) 7 49 | , test "height of a non-empty tree" <| 50 | assertEqual (Tree.height traversedTree) 3 51 | , test "height of an empty tree" <| 52 | assertEqual (Tree.height Tree.empty) 0 53 | ] 54 | 55 | traversedTree = 56 | Tree.inner 0 57 | [ Tree.inner 1 58 | [ Tree.leaf 2, Tree.leaf 3 ] 59 | , Tree.inner 4 60 | [ Tree.leaf 5, Tree.leaf 6 ] 61 | ] 62 | 63 | traversalTests = 64 | suite "traversal" 65 | [ test "levelOrderList" <| 66 | assertEqual 67 | [0, 1, 4, 2, 3, 5, 6] 68 | (Tree.levelOrderList traversedTree) 69 | , test "postOrderList" <| 70 | assertEqual 71 | [2, 3, 1, 5, 6, 4, 0] 72 | (Tree.postOrderList traversedTree) 73 | , test "preOrderList" <| 74 | assertEqual 75 | [0, 1, 2, 3, 4, 5, 6] 76 | (Tree.preOrderList traversedTree) 77 | ] 78 | 79 | unitTests = 80 | suite "unit tests" 81 | [ buildingTests 82 | , queryTests 83 | , traversalTests 84 | ] 85 | in 86 | suite "Tree tests" 87 | [ unitTests 88 | ] 89 | -------------------------------------------------------------------------------- /src/Graph/Tree.elm: -------------------------------------------------------------------------------- 1 | module Graph.Tree exposing 2 | ( Tree, Forest 3 | -- BUILDING 4 | , empty, leaf, inner, unfoldTree, unfoldForest 5 | -- QUERY 6 | , isEmpty, root, size, height 7 | -- TRAVERSAL 8 | , levelOrder, levelOrderList 9 | , preOrder, preOrderList 10 | , postOrder, postOrderList 11 | ) 12 | 13 | 14 | {-| This module provides a simple tree data type of arbitrary arity (a rose tree). 15 | There are primitives for building and traversing such a tree. 16 | 17 | # Data 18 | @docs Tree, Forest 19 | 20 | # Building 21 | @docs empty, leaf, inner, unfoldTree, unfoldForest 22 | 23 | # Query 24 | @docs isEmpty, root, size, height 25 | 26 | # Traversal 27 | 28 | It is instructory to read the article on [tree traversals on Wikipedia](https://en.wikipedia.org/wiki/Tree_traversal) first if you are not familiar with the concept. 29 | 30 | @docs levelOrder, levelOrderList, preOrder, preOrderList, postOrder, postOrderList 31 | 32 | -} 33 | 34 | 35 | import Queue exposing (Queue) 36 | 37 | 38 | {-| Data type representing an n-ary tree with node labels of type `a` 39 | Building such a tree is done with the `empty`, `leaf` and `inner` smart 40 | constructors. An example for a tree with three leafs and a root node: 41 | 42 | tree = inner 1 [leaf 2, leaf 3, leaf 4] 43 | -} 44 | type Tree label = 45 | MkTree Int (Maybe (label, List (Tree label))) 46 | 47 | 48 | {-| This is just an alias for a list of trees, called a forest in the 49 | literature. 50 | -} 51 | type alias Forest label = 52 | List (Tree label) 53 | 54 | 55 | {- BUILDING -} 56 | 57 | 58 | {-| Construct an empty tree with no nodes. -} 59 | empty : Tree label 60 | empty = 61 | MkTree 0 Nothing 62 | 63 | 64 | {-| Construct a tree with a single node from a value for the node's label. 65 | 66 | tree : Tree Int 67 | tree = leaf 42 68 | -} 69 | leaf : label -> Tree label 70 | leaf val = 71 | inner val [] 72 | 73 | 74 | {-| Construct a new tree by `inner label children`, combining a number of 75 | subtrees `children` with a `label` for the new inner node which will be 76 | the root of the tree. Empty subtrees are filtered out. An example: 77 | 78 | tree1 = inner 1 [leaf 2, leaf 3, leaf 4] 79 | tree2 = inner 1 [leaf 2, leaf 3, leaf 4, empty] 80 | tree1 == tree2 81 | -} 82 | inner : label -> List (Tree label) -> Tree label 83 | inner label children = 84 | let 85 | children' = 86 | List.filter (not << isEmpty) children 87 | 88 | size' = 89 | List.foldl (size >> (+)) 1 children' 90 | in 91 | MkTree size' (Just (label, children')) 92 | 93 | 94 | {-| Construct a new tree with `unfoldTree next seed`, top to bottom. `next` will be 95 | called repeatedly with seeds, from which it should construct a label for 96 | the current tree node but also a list of seeds from which to unfold 97 | child nodes. This sort of works top to bottom compared to creating a 98 | tree bottom up by using the other primitives. 99 | 100 | tree1 = inner 1 [leaf 2, leaf 3, leaf 4] 101 | next seed = (seed, if seed == 1 then [2, 3, 4] else []) 102 | tree2 = unfoldTree next 1 103 | tree1 == tree2 104 | -} 105 | unfoldTree : (seed -> (label, List seed)) -> seed -> Tree label 106 | unfoldTree next seed = 107 | let 108 | (label, seeds) = next seed 109 | in 110 | inner label (List.map (unfoldTree next) seeds) 111 | 112 | 113 | {-| Construct a new forest with `unfoldForest next seeds` by `unfoldTree next seed` 114 | for each `seed` in `seeds`. A simple specification would be 115 | 116 | unfoldForest next seeds = List.map (unfoldTree next) seeds 117 | -} 118 | unfoldForest : (seed -> (label, List seed)) -> List seed -> Forest label 119 | unfoldForest next seeds = 120 | List.map (unfoldTree next) seeds 121 | 122 | 123 | {- QUERY -} 124 | 125 | 126 | {-| `isEmpty tree` returns true if and only if `tree` is `empty`. 127 | 128 | isEmpty empty == True 129 | isEmpty (leaf 42) == False 130 | -} 131 | isEmpty : Tree label -> Bool 132 | isEmpty tree = 133 | tree == empty 134 | 135 | {-| `root tree` returns `Nothing` if `tree` is `empty`, otherwise 136 | it returns `Just (label, childForest)` of the root node. 137 | 138 | tree = inner 1 [leaf 2, leaf 3, leaf 4] 139 | root tree == Just (1, [leaf 2, leaf 3, leaf 4]) 140 | root empty == Nothing 141 | -} 142 | root : Tree label -> Maybe (label, Forest label) 143 | root tree = 144 | case tree of 145 | MkTree _ maybe -> maybe 146 | 147 | 148 | {-| The size of the tree, e.g. the number of nodes. 149 | 150 | tree = inner 0 [inner 1 [leaf 2, leaf 3], inner 4 [leaf 5, leaf 6]] 151 | size tree == 7 152 | -} 153 | size : Tree label -> Int 154 | size tree = 155 | case tree of 156 | MkTree n _ -> n 157 | 158 | 159 | {-| Computes the height of the tree in O(n) time. 160 | 161 | tree = inner 0 [inner 1 [leaf 2, leaf 3], inner 4 [leaf 5, leaf 6]] 162 | height tree == 3 163 | -} 164 | height : Tree label -> Int 165 | height tree = 166 | let 167 | go h t = 168 | case root t of 169 | Just (_, children) -> 170 | children 171 | |> List.foldl (go (h + 1) >> max) (h + 1) 172 | Nothing -> 173 | h 174 | in 175 | go 0 tree 176 | 177 | 178 | {- TRAVERSAL -} 179 | 180 | 181 | -- This is private. No type annotation for this, traversal is quite daunting. 182 | listForTraversal traversal tree = 183 | -- we will compute a DList that we then can turn into a List. 184 | let 185 | f label children rest = 186 | (::) label >> rest 187 | acc = identity 188 | -- the call to postOrder returns a DList ([a] -> [a]), so [] turns it into a list 189 | in 190 | traversal f acc tree [] 191 | 192 | 193 | -- This is also not exported. 194 | pushMany : List a -> Queue a -> Queue a 195 | pushMany vals queue = 196 | List.foldl Queue.push queue vals 197 | 198 | 199 | {-| `levelOrder visit acc tree` is a breadth-first fold over `tree`, 200 | visiting each node and accumulating results with `visit`. Nodes are visited 201 | in level-order, e.g. for a tree like 202 | 203 | tree = inner 0 [inner 1 [leaf 2, leaf 3], inner 4 [leaf 5, leaf 6]] 204 | 205 | nodes would be visited in order `[0, 1, 4, 2, 3, 5, 6]`. This is in fact the 206 | list produced by `levelOrderList`, but through `levelOrder` you also get access 207 | to the children of the current node via the second parameter of visit. 208 | -} 209 | levelOrder : (label -> Forest label -> acc -> acc) -> acc -> Tree label -> acc 210 | levelOrder visit acc tree = 211 | let 212 | go acc toVisit = 213 | case Queue.pop toVisit of 214 | Nothing -> acc 215 | Just (tree', toVisit') -> 216 | case root tree' of 217 | Nothing -> go acc toVisit' 218 | Just (label, children) -> 219 | go (visit label children acc) (pushMany children toVisit') 220 | in 221 | go acc (Queue.empty |> Queue.push tree) 222 | 223 | 224 | {-| See the documentation on `levelOrder`. `levelOrderList tree` produces 225 | a list of the nodes of the tree visited in level-order, e.g. breadth-first. 226 | So: 227 | 228 | tree = inner 0 [inner 1 [leaf 2, leaf 3], inner 4 [leaf 5, leaf 6]] 229 | levelOrderList tree == [0, 1, 4, 2, 3, 5, 6] 230 | 231 | If you also need information on child trees instead of just the node labels, 232 | use `levelOrder`. 233 | -} 234 | levelOrderList : Tree label -> List label 235 | levelOrderList = 236 | listForTraversal levelOrder 237 | 238 | 239 | {-| `postOrder visit acc tree` is a (depth-first) post-order traversal (fold) 240 | over `tree` where `visit` is called with the label and the child sub-forest of 241 | the current node in addition to a supplied accumulator value. 242 | 243 | When `visit` is called for some node, `acc` already contains the value of all 244 | sub-trees, so post-order traversal is a kind of bottom-up traversal, where 245 | all children are visited prior to their parent. 246 | See `postOrderList` for an example on the order in which nodes are visited. 247 | -} 248 | postOrder : (label -> Forest label -> acc -> acc) -> acc -> Tree label -> acc 249 | postOrder visit acc tree = 250 | let 251 | folder = flip (postOrder visit) 252 | in 253 | case root tree of 254 | Nothing -> acc 255 | Just (label, children) -> 256 | visit label children (List.foldl folder acc children) 257 | 258 | 259 | {-| See `postOrder` for an explanation of how post-order traversals work. 260 | Here is an example on visit order: 261 | 262 | tree = inner 0 [inner 1 [leaf 2, leaf 3], inner 4 [leaf 5, leaf 6]] 263 | postOrderList tree == [2, 3, 1, 5, 6, 4, 0] 264 | 265 | If you also need information on child trees instead of just the node labels, 266 | use `postOrder`. 267 | -} 268 | postOrderList : Tree label -> List label 269 | postOrderList = 270 | listForTraversal postOrder 271 | 272 | 273 | {-| `preOrder visit acc tree` is a (depth-first) pre-order traversal (fold) 274 | over `tree` where `visit` is called with the label and the child sub-forest of 275 | the current node in addition to a supplied accumulator value. 276 | 277 | Post-order traversals work top-down: When `visit` is called for some node, 278 | `acc` already contains the value of all ancestral nodes. 279 | See `preOrderList` for an example on the order in which nodes are visited. 280 | -} 281 | preOrder : (label -> Forest label -> acc -> acc) -> acc -> Tree label -> acc 282 | preOrder visit acc tree = 283 | let 284 | folder = flip (preOrder visit) 285 | in 286 | case root tree of 287 | Nothing -> acc 288 | Just (label, children) -> 289 | List.foldl folder (visit label children acc) children 290 | 291 | 292 | {-| See `preOrder` for an explanation of how post-order traversals work. 293 | Here is an example on visit order: 294 | 295 | tree = inner 0 [inner 1 [leaf 2, leaf 3], inner 4 [leaf 5, leaf 6]] 296 | preOrderList tree == [0, 1, 2, 3, 4, 5, 6] 297 | 298 | If you also need information on child trees instead of just the node labels, 299 | use `preOrder`. 300 | -} 301 | preOrderList : Tree label -> List label 302 | preOrderList = 303 | listForTraversal preOrder 304 | -------------------------------------------------------------------------------- /tests/Test/Graph.elm: -------------------------------------------------------------------------------- 1 | module Test.Graph exposing (tests) 2 | 3 | import String 4 | import Debug 5 | import Set exposing (Set) 6 | import IntDict exposing (IntDict) 7 | import Graph exposing (Graph, NodeId, Node, Edge, NodeContext) 8 | import Focus exposing (Focus) 9 | 10 | import ElmTest exposing (..) 11 | 12 | 13 | isJust : Maybe a -> Bool 14 | isJust m = 15 | case m of 16 | Just _ -> True 17 | _ -> False 18 | 19 | 20 | assertComparing : (a -> b) -> a -> a -> Assertion 21 | assertComparing f a b = 22 | assertEqual (f a) (f b) 23 | 24 | 25 | edgeTriples : Graph n e -> List (NodeId, NodeId, e) 26 | edgeTriples = 27 | Graph.edges >> List.map (\e -> (e.from, e.to, e.label)) 28 | 29 | 30 | dressUp : Graph String () 31 | dressUp = 32 | let 33 | nodes = 34 | [ Node 0 "Socks" 35 | , Node 1 "Undershorts" 36 | , Node 2 "Pants" 37 | , Node 3 "Shoes" 38 | , Node 4 "Watch" 39 | , Node 5 "Shirt" 40 | , Node 6 "Belt" 41 | , Node 7 "Tie" 42 | , Node 8 "Jacket" 43 | ] 44 | 45 | e from to = 46 | Edge from to () 47 | 48 | edges = 49 | [ e 0 3 -- socks before shoes 50 | , e 1 2 -- undershorts before pants 51 | , e 1 3 -- undershorts before shoes 52 | , e 2 3 -- pants before shoes 53 | , e 2 6 -- pants before belt 54 | , e 5 6 -- shirt before belt 55 | , e 5 7 -- shirt before tie 56 | , e 6 8 -- belt before jacket 57 | , e 7 8 -- tie before jacket 58 | ] 59 | 60 | in 61 | Graph.fromNodesAndEdges nodes edges 62 | 63 | 64 | connectedComponents : Graph Char () 65 | connectedComponents = 66 | let 67 | nodes = 68 | ['a', 'b', 'c', 'd', 'e', 'f', 'g', 'h'] 69 | 70 | edges = 71 | [ (0, 1), (1, 2), (1, 4), (1, 5), (2, 3) 72 | , (2, 6), (3, 2), (3, 7), (4, 0), (4, 5) 73 | , (5, 6), (6, 5), (6, 7)] 74 | in 75 | Graph.fromNodeLabelsAndEdgePairs nodes edges 76 | 77 | 78 | noNeighbors : Node String -> NodeContext String () 79 | noNeighbors node = 80 | NodeContext node IntDict.empty IntDict.empty 81 | 82 | 83 | tests : Test 84 | tests = 85 | let 86 | emptyTests = 87 | suite "empty" 88 | [ test "has size 0" <| assertEqual 0 (Graph.size Graph.empty) 89 | , test "isEmpty" <| assertEqual True (Graph.isEmpty Graph.empty) 90 | ] 91 | 92 | memberTests = 93 | suite "member" 94 | [ test "True" <| assertEqual True (Graph.member 0 dressUp) 95 | , test "True" <| assertEqual False (Graph.member 99 dressUp) 96 | ] 97 | 98 | getTests = 99 | suite "get" 100 | [ test "id 0, the socks" <| 101 | assertEqual 102 | (Just "Socks") 103 | (dressUp |> Graph.get 0 |> Maybe.map (.node >> .label)) 104 | , test "id 99, Nothing" <| assertEqual Nothing (Graph.get 99 dressUp) 105 | ] 106 | 107 | nodeIdRangeTests = 108 | suite "nodeIdRange" 109 | [ test "dressUp: [0, 8]" <| 110 | assertEqual 111 | (Just (0, 8)) 112 | (Graph.nodeIdRange dressUp) 113 | , test "dressUp - 0: [1, 8]" <| 114 | assertEqual 115 | (Just (1, 8)) 116 | (dressUp |> Graph.remove 0 |> Graph.nodeIdRange) 117 | , test "dressUp - 8: [0, 7]" <| 118 | assertEqual 119 | (Just (0, 7)) 120 | (dressUp |> Graph.remove 8 |> Graph.nodeIdRange) 121 | ] 122 | 123 | listRepTests = 124 | suite "list conversions" 125 | [ test "nodeIds" <| 126 | assertEqual 127 | [0, 1, 2, 3, 4, 5, 6, 7, 8] 128 | (dressUp |> Graph.nodeIds) 129 | , test "nodes" <| 130 | assertEqual 131 | [0, 1, 2, 3, 4, 5, 6, 7, 8] 132 | (dressUp |> Graph.nodes |> List.map .id) 133 | , test "edges" <| 134 | assertEqual 135 | [(0, 3), (1, 2), (1, 3), (2, 3), (2, 6), (5, 6), (5, 7), (6, 8), (7, 8)] 136 | (dressUp 137 | |> Graph.edges 138 | |> List.map (\e -> (e.from, e.to)) 139 | |> List.sort) 140 | ] 141 | 142 | focusTests = 143 | suite "foci" 144 | [ test "get anyNode - empty" <| 145 | assertEqual 146 | Nothing 147 | (Focus.get Graph.anyNode Graph.empty) 148 | , test "get anyNode - not empty" <| 149 | assert 150 | (dressUp |> Focus.get Graph.anyNode |> isJust) 151 | , test "set anyNode - empty" <| 152 | assertEqual 153 | Nothing 154 | (Graph.empty 155 | |> Focus.set Graph.anyNode (Just (noNeighbors (Node 9 "lkj"))) 156 | |> Graph.get 9) 157 | ] 158 | 159 | insertTests = 160 | suite "insert" 161 | [ test "new node - size" <| 162 | assertEqual 163 | (dressUp |> Graph.size |> (+) 1) 164 | (dressUp |> Graph.insert (noNeighbors (Node 99 "Ring")) |> Graph.size) 165 | , test "new node - can get it" <| 166 | assertEqual 167 | (Just "Ring") 168 | (dressUp 169 | |> Graph.insert (noNeighbors (Node 99 "Ring")) 170 | |> Graph.get 99 171 | |> Maybe.map (.node >> .label)) 172 | , test "replace node - size" <| 173 | assertEqual 174 | (dressUp |> Graph.size) 175 | (dressUp |> Graph.insert (noNeighbors (Node 0 "Ring")) |> Graph.size) 176 | , test "replace node - can get it" <| 177 | assertEqual 178 | (Just "Ring") 179 | (dressUp 180 | |> Graph.insert (noNeighbors (Node 0 "Ring")) 181 | |> Graph.get 0 182 | |> Maybe.map (.node >> .label)) 183 | , test "replace node - replaces adjacency" <| 184 | assertEqual 185 | (Just True) 186 | (dressUp 187 | |> Graph.insert (noNeighbors (Node 0 "Ring")) 188 | |> Graph.get 0 189 | |> Maybe.map (\ctx -> IntDict.isEmpty ctx.incoming && IntDict.isEmpty ctx.outgoing)) 190 | ] 191 | 192 | removeTests = 193 | suite "remove" 194 | [ test "nonexistent node" <| 195 | assertEqual 196 | dressUp 197 | (dressUp |> Graph.remove 99) 198 | , test "existing node - size" <| 199 | assertEqual 200 | (dressUp |> Graph.size |> flip (-) 1) 201 | (dressUp |> Graph.remove 0 |> Graph.size) 202 | , test "existing node - can't get it" <| 203 | assertEqual 204 | Nothing 205 | (dressUp |> Graph.remove 0 |> Graph.get 0) 206 | ] 207 | 208 | updateTests = 209 | suite "update" 210 | [ test "remove outgoing edges" <| 211 | assertEqual 212 | (Just True) 213 | (dressUp 214 | |> Graph.update 0 -- "Shorts" has outgoing edges 215 | (Maybe.map (Focus.set Graph.outgoing IntDict.empty)) 216 | |> Graph.get 0 217 | |> Maybe.map (.outgoing >> IntDict.isEmpty)) 218 | ] 219 | 220 | inducedSubgraphTests = 221 | suite "inducedSubgraph" 222 | [ test "should not have any dangling edges" <| 223 | assertComparing 224 | (edgeTriples >> List.sortBy (\(f, t, _) -> (f, t))) 225 | (Graph.fromNodesAndEdges 226 | [Node 0 'a', Node 1 'b', Node 4 'e'] 227 | [Edge 0 1 (), Edge 1 4 (), Edge 4 0 ()]) 228 | (Graph.inducedSubgraph [0, 1, 4] connectedComponents) 229 | ] 230 | 231 | foldTests = 232 | suite "fold" 233 | [ test "sum up ids" <| 234 | assertEqual 235 | 36 236 | (dressUp 237 | |> Graph.fold (\ctx -> (+) ctx.node.id) 0) 238 | ] 239 | 240 | mapTests = 241 | suite "map*" 242 | [ test "mapContexts over id is the id" <| 243 | assertEqual 244 | dressUp 245 | (dressUp |> Graph.mapContexts identity) 246 | , test "mapNodes over id is the id" <| 247 | assertEqual 248 | dressUp 249 | (dressUp |> Graph.mapNodes identity) 250 | , test "mapEdges over id is the id" <| 251 | assertEqual 252 | dressUp 253 | (dressUp |> Graph.mapNodes identity) 254 | -- This should be backed by more tests, but I'm not in the mood for that :/ 255 | ] 256 | 257 | characterizationTests = 258 | suite "characterization" 259 | [ 260 | ] 261 | 262 | graphOpsTests = 263 | suite "Graph ops" 264 | [ test "symmetricClosure is symmetric" <| 265 | assert 266 | (dressUp 267 | |> Graph.symmetricClosure (\_ _ e _ -> e) 268 | |> Graph.fold (\ctx acc -> 269 | ctx.incoming == ctx.outgoing && acc) True) 270 | , test "reverseEdges" <| 271 | assertEqual 272 | (dressUp 273 | |> Graph.edges 274 | |> List.map (\e -> (e.from, e.to)) 275 | |> List.sort) 276 | (dressUp 277 | |> Graph.reverseEdges 278 | |> Graph.edges 279 | |> List.map (\e -> (e.to, e.from)) 280 | |> List.sort) 281 | ] 282 | 283 | isValidTopologicalOrderingOf graph ordering = 284 | ordering 285 | |> List.foldl 286 | (\ctx maybeIds -> 287 | maybeIds `Maybe.andThen` \ids -> 288 | if List.all (flip IntDict.member ids) (IntDict.keys ctx.incoming) 289 | then ids |> IntDict.insert ctx.node.id () |> Just 290 | else Nothing) 291 | (Just IntDict.empty) 292 | |> isJust 293 | |> (&&) (List.length ordering == Graph.size graph) 294 | 295 | topologicalSortTests = 296 | suite "topologicalSort" 297 | [ test "topologicalSort" <| 298 | assert 299 | (dressUp 300 | |> Graph.topologicalSort 301 | |> isValidTopologicalOrderingOf dressUp) 302 | , test "heightLevels" <| 303 | assert 304 | (dressUp 305 | |> Graph.heightLevels 306 | |> List.concat 307 | |> isValidTopologicalOrderingOf dressUp) 308 | ] 309 | 310 | 311 | bfsTests = 312 | suite "BFS" 313 | [ test "breadth-first node order" <| 314 | assertEqual 315 | [0, 3, 1, 2, 6, 8, 4, 5, 7] 316 | (dressUp 317 | |> Graph.bfs (Graph.ignorePath (::)) [] 318 | |> List.map (.node >> .id) 319 | |> List.reverse) 320 | ] 321 | 322 | sccTests = 323 | let 324 | components = 325 | Graph.stronglyConnectedComponents connectedComponents 326 | 327 | sg nodeIds = 328 | connectedComponents 329 | |> Graph.inducedSubgraph nodeIds 330 | |> Graph.toString' 331 | in 332 | suite "Strongly connected components" 333 | [ test "The expected SCCs in order" <| 334 | assertEqual 335 | [ sg [0, 1, 4] -- "abe" 336 | , sg [2, 3] -- "cd" 337 | , sg [5, 6] -- "ef" 338 | , sg [7] -- "h" 339 | ] 340 | (List.map Graph.toString' components) 341 | ] 342 | 343 | 344 | unitTests = 345 | suite "unit tests" 346 | [ emptyTests 347 | , memberTests 348 | , getTests 349 | , nodeIdRangeTests 350 | , listRepTests 351 | , focusTests 352 | , insertTests 353 | , removeTests 354 | , updateTests 355 | , inducedSubgraphTests 356 | , foldTests 357 | , mapTests 358 | , characterizationTests 359 | , graphOpsTests 360 | , topologicalSortTests 361 | , bfsTests 362 | , sccTests 363 | ] 364 | 365 | examples = 366 | suite "examples" 367 | [ test "README - iWantToWearShoes" <| 368 | assertEqual 369 | ["Pants", "Undershorts", "Socks", "Shoes"] 370 | iWantToWearShoes 371 | , test "insert" <| 372 | assert insertExample 373 | , test "fold" <| 374 | assert foldExample 375 | , test "mapContexts" <| 376 | assert mapContextsExample 377 | ] 378 | 379 | in 380 | suite "Graph tests" 381 | [ unitTests 382 | , examples 383 | ] 384 | 385 | 386 | -- EXAMPLE SECTION 387 | -- The code of the more complex examples is exercised here 388 | 389 | -- This is from the README 390 | iWantToWearShoes : List String 391 | iWantToWearShoes = 392 | Graph.guidedDfs 393 | Graph.alongIncomingEdges -- which edges to follow 394 | (Graph.onDiscovery (\ctx list -> -- append node labels on finish 395 | ctx.node.label :: list)) 396 | [3 {- "Shoes" NodeId -}] -- start with the node labelled "Shoes" 397 | [] -- accumulate starting with the empty list 398 | dressUp -- traverse our dressUp graph from above 399 | |> fst -- ignores the untraversed rest of the graph 400 | 401 | 402 | insertExample : Bool 403 | insertExample = 404 | let 405 | graph1 = Graph.fromNodesAndEdges [Node 1 "1"] [] 406 | newNode = 407 | { node = Node 2 "2" 408 | , incoming = IntDict.singleton 1 () -- so there will be an edge from 1 to 2 409 | , outgoing = IntDict.empty 410 | } 411 | graph2 = Graph.insert newNode graph1 412 | in 413 | Graph.size graph2 == 2 414 | 415 | 416 | foldExample : Bool 417 | foldExample = 418 | let 419 | hasLoop ctx = 420 | IntDict.member ctx.node.id ctx.incoming 421 | graph = 422 | Graph.fromNodesAndEdges [Node 1 "1", Node 2 "2"] [Edge 1 2 "->"] 423 | -- The graph should not have any loop. 424 | in 425 | Graph.fold (\ctx acc -> acc || hasLoop ctx) False graph == False 426 | 427 | 428 | mapContextsExample : Bool 429 | mapContextsExample = 430 | let 431 | flipEdges ctx = { ctx | incoming = ctx.outgoing, outgoing = ctx.incoming } 432 | graph = Graph.fromNodesAndEdges [Node 1 "1", Node 2 "2"] [Edge 1 2 "->"] 433 | in 434 | Graph.reverseEdges graph == Graph.mapContexts flipEdges graph 435 | 436 | 437 | symmetricClosureExample : Bool 438 | symmetricClosureExample = 439 | let 440 | graph = Graph.fromNodesAndEdges [Node 1 "1", Node 2 "2"] [Edge 1 2 "->"] 441 | onlyUndirectedEdges ctx = 442 | ctx.incoming == ctx.outgoing 443 | merger from to outgoingLabel incomingLabel = 444 | outgoingLabel -- quite arbitrary, will not be called for the above graph 445 | in 446 | Graph.fold 447 | (\ctx acc -> acc && onlyUndirectedEdges ctx) 448 | True 449 | (Graph.symmetricClosure merger graph) 450 | == True 451 | 452 | 453 | onDiscoveryExample : () -- Just let it compile 454 | onDiscoveryExample = 455 | let 456 | dfsPostOrder : Graph n e -> List (NodeContext n e) 457 | dfsPostOrder graph = 458 | Graph.dfs (Graph.onDiscovery (::)) [] graph 459 | in 460 | dfsPostOrder Graph.empty |> \_ -> () 461 | 462 | 463 | onFinishExample : () -- Just let it compile 464 | onFinishExample = 465 | let 466 | dfsPreOrder : Graph n e -> List (NodeContext n e) 467 | dfsPreOrder graph = 468 | Graph.dfs (Graph.onFinish (::)) [] graph 469 | in 470 | dfsPreOrder Graph.empty |> \_ -> () 471 | 472 | 473 | ignorePathExample : () -- Just let it compile 474 | ignorePathExample = 475 | let 476 | bfsLevelOrder : Graph n e -> List (NodeContext n e) 477 | bfsLevelOrder graph = 478 | graph 479 | |> Graph.bfs (Graph.ignorePath (::)) [] 480 | |> List.reverse 481 | in 482 | bfsLevelOrder Graph.empty |> \_ -> () 483 | -------------------------------------------------------------------------------- /src/Graph.elm: -------------------------------------------------------------------------------- 1 | module Graph exposing 2 | -- Data 3 | ( NodeId, Node, Edge, Adjacency, NodeContext, Graph 4 | -- Building 5 | , empty, update, insert, remove, inducedSubgraph 6 | -- Query 7 | , isEmpty, size, member, get, nodeIdRange 8 | -- List representations 9 | , nodeIds, nodes, edges, fromNodesAndEdges, fromNodeLabelsAndEdgePairs 10 | -- Foci 11 | , id, label, from, to, node, incoming, outgoing 12 | , nodeById, anyNode 13 | 14 | -- Transforms 15 | , fold, mapContexts, mapNodes, mapEdges 16 | , symmetricClosure, reverseEdges 17 | 18 | -- Characterization 19 | 20 | -- Traversals 21 | , NeighborSelector, alongOutgoingEdges, alongIncomingEdges, SimpleNodeVisitor 22 | -- DFS 23 | , DfsNodeVisitor, onDiscovery, onFinish, dfs, dfsTree, dfsForest, guidedDfs 24 | -- BFS 25 | , BfsNodeVisitor, ignorePath, bfs, guidedBfs 26 | 27 | -- Topological sort 28 | , heightLevels, topologicalSort 29 | -- Strongly connected components 30 | , stronglyConnectedComponents 31 | 32 | -- String representation 33 | , toString' 34 | ) 35 | 36 | {-| This module contains the primitives to build, update and traverse graphs. 37 | If you find that this module is hard to use or the documentation 38 | is insufficient, consider opening an issue for that (and possibly even a 39 | pull request :)). 40 | 41 | Internally, we use the `elm-intdict` package for efficient dynamic graph 42 | representation. 43 | 44 | # Data 45 | @docs NodeId, Node, Edge, Adjacency, NodeContext, Graph 46 | 47 | # Building 48 | @docs empty, update, insert, remove, inducedSubgraph 49 | 50 | # Query 51 | @docs isEmpty, size, member, get, nodeIdRange 52 | 53 | # List representations 54 | @docs nodeIds, nodes, edges, fromNodesAndEdges, fromNodeLabelsAndEdgePairs 55 | 56 | # Foci 57 | @docs id, label, from, to, node, incoming, outgoing, nodeById, anyNode 58 | 59 | # Transforms 60 | @docs fold, mapContexts, mapNodes, mapEdges, reverseEdges, symmetricClosure 61 | 62 | # Characterization 63 | 64 | # Traversals 65 | ## Neighbor selectors and node visitors 66 | @docs NeighborSelector, alongOutgoingEdges, alongIncomingEdges, SimpleNodeVisitor 67 | ## Depth-first 68 | @docs DfsNodeVisitor, onDiscovery, onFinish, dfs, dfsTree, dfsForest, guidedDfs 69 | ## Breadth-first 70 | @docs BfsNodeVisitor, ignorePath, bfs, guidedBfs 71 | 72 | # Topological Sort 73 | @docs topologicalSort, heightLevels 74 | 75 | # Strongly Connected Components 76 | @docs stronglyConnectedComponents 77 | 78 | # String representation 79 | @docs toString' 80 | 81 | -} 82 | 83 | import Graph.Tree as Tree exposing (Tree, Forest) 84 | import IntDict as IntDict exposing (IntDict) 85 | import Maybe as Maybe exposing (Maybe) 86 | import Focus as Focus exposing (Focus, (=>)) 87 | import Queue as Queue exposing (Queue) 88 | import Debug 89 | 90 | 91 | {-| The type used for identifying nodes, an integer. 92 | -} 93 | type alias NodeId = 94 | Int 95 | 96 | 97 | {-| The type representing a node: An identifier with 98 | a label. 99 | -} 100 | type alias Node n = 101 | { id : NodeId 102 | , label : n 103 | } 104 | 105 | 106 | {-| Represents a directd edge in the graph. In addition 107 | to start and end node identifiers, a label value can 108 | be attached to an edge. 109 | -} 110 | type alias Edge e = 111 | { from : NodeId 112 | , to : NodeId 113 | , label : e 114 | } 115 | 116 | 117 | {-| Adjacency is represented as an ordered dictionary 118 | rather than as an ordered list. This enables more dynamic 119 | graphs with efficient edge removal and insertion on the run. 120 | -} 121 | type alias Adjacency e = 122 | IntDict e 123 | 124 | 125 | {-| Represents a node with its incoming and outgoing edges 126 | (predecessors and successors). 127 | -} 128 | type alias NodeContext n e = 129 | { node : Node n 130 | , incoming : Adjacency e 131 | , outgoing : Adjacency e 132 | } 133 | 134 | 135 | -- We will only have the Patricia trie based DynGraph implementation for simplicity. 136 | -- Also, there is no real practical reason to separate that or to allow other implementations 137 | -- which would justify the complexity. 138 | 139 | type alias GraphRep n e = 140 | IntDict (NodeContext n e) 141 | 142 | {-| The central graph type. It is parameterized both over the node label type `n` 143 | and the edge label type `e`. 144 | 145 | One can build such a graph with the primitives under *Build*. Most of the time 146 | `fromNodesAndEdges` works fairly well. 147 | 148 | For simplicity, this library just uses a patricia trie based graph representation, which means 149 | it is just an efficient version of `Dict NodeId (NodeContext n e)`. This allows efficient insertion and 150 | removal of nodes of the graph after building. 151 | -} 152 | type Graph n e = 153 | Graph (GraphRep n e) 154 | 155 | 156 | unGraph : Graph n e -> GraphRep n e 157 | unGraph graph = 158 | case graph of Graph rep -> rep 159 | 160 | 161 | {- BUILD -} 162 | 163 | {-| An empty graph. 164 | 165 | size empty == 0 166 | -} 167 | empty : Graph n e 168 | empty = 169 | Graph IntDict.empty 170 | 171 | 172 | type EdgeUpdate e = 173 | Insert e 174 | | Remove e 175 | 176 | 177 | type alias EdgeDiff e = 178 | { incoming : IntDict (EdgeUpdate e) 179 | , outgoing : IntDict (EdgeUpdate e) 180 | } 181 | 182 | 183 | emptyDiff : EdgeDiff e 184 | emptyDiff = 185 | { incoming = IntDict.empty 186 | , outgoing = IntDict.empty 187 | } 188 | 189 | 190 | computeEdgeDiff : Maybe (NodeContext n e) -> Maybe (NodeContext n e) -> EdgeDiff e 191 | computeEdgeDiff old new = 192 | let 193 | collectUpdates edgeUpdate updatedId label = 194 | let 195 | replaceUpdate old = 196 | case (old, edgeUpdate label) of 197 | (Just (Remove oldLbl), (Insert newLbl)) -> 198 | if oldLbl == newLbl 199 | then Nothing 200 | else Just (Insert newLbl) 201 | (Just (Remove _), (Remove _)) -> 202 | Debug.crash "Graph.computeEdgeDiff: Collected two removals for the same edge. This is an error in the implementation of Graph and you should file a bug report!" 203 | (Just (Insert _), _) -> 204 | Debug.crash "Graph.computeEdgeDiff: Collected inserts before removals. This is an error in the implementation of Graph and you should file a bug report!" 205 | (Nothing, eu) -> 206 | Just eu 207 | in 208 | IntDict.update updatedId replaceUpdate 209 | 210 | collect edgeUpdate adj updates = 211 | IntDict.foldl (collectUpdates edgeUpdate) updates adj 212 | in 213 | case (old, new) of 214 | (Nothing, Nothing) -> 215 | emptyDiff 216 | (Just rem, Nothing) -> 217 | { outgoing = IntDict.empty |> collect Remove rem.incoming 218 | , incoming = IntDict.empty |> collect Remove rem.outgoing 219 | } 220 | (Nothing, Just ins) -> 221 | { outgoing = IntDict.empty |> collect Insert ins.incoming 222 | , incoming = IntDict.empty |> collect Insert ins.outgoing 223 | } 224 | (Just rem, Just ins) -> 225 | if rem == ins 226 | then emptyDiff 227 | else 228 | { outgoing = IntDict.empty |> collect Remove rem.incoming |> collect Insert ins.incoming 229 | , incoming = IntDict.empty |> collect Remove rem.outgoing |> collect Insert ins.outgoing 230 | } 231 | 232 | 233 | applyEdgeDiff : NodeId -> EdgeDiff e -> GraphRep n e -> GraphRep n e 234 | applyEdgeDiff nodeId diff graphRep = 235 | let 236 | foldl' f dict acc = 237 | IntDict.foldl f acc dict 238 | 239 | edgeUpdateToMaybe edgeUpdate = 240 | case edgeUpdate of 241 | Insert lbl -> Just lbl 242 | Remove _ -> Nothing 243 | 244 | updateAdjacency edgeFocus updatedId edgeUpdate = 245 | let 246 | updateLbl = 247 | Focus.set edgeFocus (edgeUpdateToMaybe edgeUpdate) 248 | in 249 | IntDict.update updatedId (Maybe.map updateLbl) -- ignores edges to nodes not in the graph 250 | 251 | in 252 | graphRep 253 | |> foldl' (updateAdjacency (incoming => lookup nodeId)) diff.incoming 254 | |> foldl' (updateAdjacency (outgoing => lookup nodeId)) diff.outgoing 255 | 256 | 257 | {-| Analogous to `Dict.update`, `update nodeId updater graph` will find 258 | the node context of the node with id `nodeId` in `graph`. It will then call `updater` 259 | with `Just` that node context if that node was found and `Nothing` 260 | otherwise. `updater` can then return `Just` an updated node context 261 | (modifying edges is also permitted!) or delete the node by returning 262 | `Nothing`. The updated `graph` is returned. 263 | 264 | This is the most powerful building function since all possible per-node 265 | operations are possible (node removal, insertion and updating of context 266 | properties). 267 | 268 | The other operations can be implemented in terms of `update` like this: 269 | 270 | remove nodeId graph = 271 | update nodeId (always Nothing) graph 272 | insert nodeContext graph = 273 | update nodeContext.node.id (always (Just nodeContext)) graph 274 | -} 275 | update : NodeId -> (Maybe (NodeContext n e) -> Maybe (NodeContext n e)) -> Graph n e -> Graph n e 276 | update nodeId updater = 277 | -- This basically wraps updater so that the edges are consistent. 278 | -- This is, it cannot use the lookup focus, because it needs to update other contexts, too. 279 | let 280 | updater' rep = 281 | let 282 | old = 283 | IntDict.get nodeId rep 284 | 285 | filterInvalidEdges ctx = 286 | IntDict.filter (\id _ -> id == ctx.node.id || IntDict.member id rep) 287 | 288 | cleanUpEdges ctx = 289 | ctx 290 | |> Focus.update incoming (filterInvalidEdges ctx) 291 | |> Focus.update outgoing (filterInvalidEdges ctx) 292 | 293 | new = 294 | old 295 | |> updater 296 | |> Maybe.map cleanUpEdges 297 | 298 | diff = 299 | computeEdgeDiff old new 300 | in 301 | rep 302 | |> applyEdgeDiff nodeId diff 303 | |> IntDict.update nodeId (always new) 304 | in 305 | Focus.update graphRep updater' 306 | 307 | 308 | {-| Analogous to `Dict.insert`, `insert nodeContext graph` inserts a fresh node 309 | with its context (label, id and edges) into `graph`. If there was already a node 310 | with the same id, it will be replaced by the new node context. 311 | 312 | graph1 = fromNodesAndEdges [Node 1 "1"] [] 313 | newNode = 314 | { node = Node 2 "2" 315 | , incoming = IntDict.singleton 1 () -- so there will be an edge from 1 to 2 316 | , outgoing = IntDict.empty 317 | } 318 | graph2 = insert newNode graph1 319 | size graph2 == 2 320 | 321 | It's possible to build up whole graphs this way, but a lot less tedious way would 322 | be simply to use `fromNodesAndEdges`. 323 | -} 324 | insert : NodeContext n e -> Graph n e -> Graph n e 325 | insert nodeContext graph = 326 | update nodeContext.node.id (always (Just nodeContext)) graph 327 | 328 | 329 | {-| Analogous to `Dict.remove`, `remove nodeId graph` returns a version of `graph` 330 | without a node with id `nodeId`. If there was no node with that id, then remove 331 | is a no-op: 332 | 333 | graph = fromNodesAndEdges [Node 1 "1", Node 2 "2"] [Edge 1 2 ()] 334 | graph == remove 42 graph 335 | graph |> remove 2 |> size == 1 336 | -} 337 | remove : NodeId -> Graph n e -> Graph n e 338 | remove nodeId graph = 339 | update nodeId (always Nothing) graph 340 | 341 | 342 | {-| The [induced subgraph](http://mathworld.wolfram.com/Edge-InducedSubgraph.html) 343 | of a number of node ids. 344 | -} 345 | inducedSubgraph : List NodeId -> Graph n e -> Graph n e 346 | inducedSubgraph nodeIds graph = 347 | let 348 | insertContextById nodeId acc = 349 | case get nodeId graph of 350 | Just ctx -> 351 | insert ctx acc 352 | Nothing -> 353 | acc 354 | in 355 | List.foldl insertContextById empty nodeIds 356 | 357 | 358 | {- QUERY -} 359 | 360 | 361 | {-| `isEmpty graph` is true if and only if there are no nodes in the graph. 362 | Some properties to reason about in code, which hold for any `graph`: 363 | 364 | isEmpty graph = 365 | graph == empty 366 | isEmpty graph = 367 | size graph == 0 368 | -} 369 | isEmpty : Graph n e -> Bool 370 | isEmpty graph = 371 | graph == empty 372 | 373 | 374 | {-| `size graph` returns the number of nodes in `graph`. 375 | 376 | size empty == 0 377 | graph = fromNodesAndEdges [Node 1 "1", Node 2 "2"] [] 378 | size graph == 2 379 | -} 380 | size : Graph n e -> Int 381 | size = 382 | Focus.get graphRep >> IntDict.size 383 | 384 | 385 | {-| Analogous to `Dict.member`, `member nodeId graph` is true, if and only if 386 | there is a node with id `nodeId` in `graph`. 387 | 388 | graph = fromNodesAndEdges [Node 1 "1", Node 2 "2"] [] 389 | member 42 graph == False 390 | member 1 graph == True 391 | -} 392 | member : NodeId -> Graph n e -> Bool 393 | member nodeId = 394 | Focus.get graphRep >> IntDict.member nodeId 395 | 396 | 397 | {-| Analogous to `Dict.get`, `get nodeId graph` returns the `Just` the node 398 | context with id `nodeId` in `graph` if there is one and `Nothing` otherwise. 399 | 400 | graph = fromNodesAndEdges [Node 1 "1", Node 2 "2"] [] 401 | get 42 graph == Nothing 402 | get 1 graph == Just 403 | -} 404 | get : NodeId -> Graph n e -> Maybe (NodeContext n e) 405 | get nodeId = 406 | Focus.get (graphRep => lookup nodeId) 407 | 408 | 409 | {-| `nodeIdRange graph` returns `Just (minNodeId, maxNodeId)` if `graph` is not empty and `Nothing` 410 | otherwise. 411 | 412 | This is useful for finding unoccupied node ids without trial and error. 413 | 414 | nodeIdRange empty == Nothing 415 | graph = fromNodesAndEdges [Node 1 "1", Node 2 "2"] [] 416 | nodeIdRange graph == Just (1, 2) 417 | -} 418 | nodeIdRange : Graph n e -> Maybe (NodeId, NodeId) 419 | nodeIdRange graph = 420 | let 421 | rep = 422 | Focus.get graphRep graph 423 | in 424 | IntDict.findMin rep `Maybe.andThen` \(min, _) -> 425 | IntDict.findMax rep `Maybe.andThen` \(max, _) -> 426 | Just (min, max) 427 | 428 | 429 | {- LIST REPRESENTATIONS -} 430 | 431 | 432 | {-| `nodes graph` returns a list of all `Node`s (e.g. `id` and `label`) in 433 | `graph`. 434 | 435 | nodes empty == [] 436 | graph = fromNodesAndEdges [Node 1 "1", Node 2 "2"] [] 437 | nodes graph == [Node 1 "1", Node 2 "2"] 438 | -} 439 | nodes : Graph n e -> List (Node n) 440 | nodes = 441 | Focus.get graphRep >> IntDict.values >> List.map .node 442 | 443 | 444 | {-| `nodeIds graph` returns a list of all nodes' ids in `graph`. 445 | 446 | nodeIds empty == [] 447 | graph = fromNodesAndEdges [Node 1 "1", Node 2 "2"] [] 448 | nodeIds graph == [1, 2] 449 | -} 450 | nodeIds : Graph n e -> List (NodeId) 451 | nodeIds = 452 | Focus.get graphRep >> IntDict.keys 453 | 454 | 455 | {-| `edges graph` returns a list of all `Edge`s (e.g. a record of `from` and `to` ids 456 | and a `label`) in `graph`. 457 | 458 | edges empty == [] 459 | graph = fromNodesAndEdges [Node 1 "1", Node 2 "2"] [Edge 1 2 "->"] 460 | edges graph == [Edge 1 2 "->"] 461 | -} 462 | edges : Graph n e -> List (Edge e) 463 | edges graph = 464 | let 465 | foldl' f dict list = 466 | IntDict.foldl f list dict -- dict and list flipped, so that we can use pointfree notation 467 | 468 | prependEdges node1 ctx = 469 | foldl' (\node2 e -> (::) { to = node2, from = node1, label = e }) ctx.outgoing 470 | in 471 | foldl' prependEdges (unGraph graph) [] 472 | 473 | 474 | {-| `fromNodesAndEdges nodes edges` constructs a graph from the supplied `nodes` 475 | and `edges`. This is the most comfortable way to construct a graph as a whole. 476 | Oftentimes it is even more convenient to use `fromNodeLabelsAndEdgePairs` when 477 | edges are unlabeled anyway and auto incremented node ids are OK. 478 | 479 | The following constructs a graph with 2 nodes with a string label, connected 480 | by an edge labeled "->". 481 | 482 | graph = fromNodesAndEdges [Node 1 "1", Node 2 "2"] [Edge 1 2 "->"] 483 | -} 484 | fromNodesAndEdges : List (Node n) -> List (Edge e) -> Graph n e 485 | fromNodesAndEdges nodes edges = 486 | let 487 | nodeRep = 488 | List.foldl 489 | (\n -> 490 | IntDict.insert n.id (NodeContext n IntDict.empty IntDict.empty)) 491 | IntDict.empty 492 | nodes 493 | 494 | addEdge edge rep = 495 | let 496 | updateOutgoing ctx = 497 | { ctx | outgoing = IntDict.insert edge.to edge.label ctx.outgoing } 498 | 499 | updateIncoming ctx = 500 | { ctx | incoming = IntDict.insert edge.from edge.label ctx.incoming } 501 | in 502 | rep 503 | |> IntDict.update edge.from (Maybe.map updateOutgoing) 504 | |> IntDict.update edge.to (Maybe.map updateIncoming) 505 | in 506 | Graph (List.foldl addEdge nodeRep edges) 507 | 508 | 509 | {-| A more convenient version of `fromNodesAndEdges`, when edges are unlabeled 510 | and there are no special requirements on node ids. 511 | 512 | `fromNodeLabelsAndEdgePairs labels edges` implicitly assigns node ids according 513 | to the label's index in `labels` and the list of edge pairs is converted to 514 | unlabeled `Edge`s. 515 | 516 | graph = fromNodeLabelsAndEdgePairs ['a', 'b'] [(0, 1)] 517 | -} 518 | fromNodeLabelsAndEdgePairs : List n -> List (NodeId, NodeId) -> Graph n () 519 | fromNodeLabelsAndEdgePairs labels edges = 520 | let 521 | nodes = 522 | labels 523 | |> List.foldl 524 | (\lbl (id, nodes) -> (id + 1, Node id lbl :: nodes)) 525 | (0, []) 526 | |> snd 527 | 528 | edges' = 529 | List.map (\(from, to) -> Edge from to ()) edges 530 | in 531 | fromNodesAndEdges nodes edges' 532 | 533 | 534 | 535 | {- FOCI -} 536 | 537 | 538 | {-| Focus for the `id` field of `Node`. 539 | -} 540 | id : Focus { record | id : field } field 541 | id = 542 | Focus.create .id (\update record -> { record | id = update record.id }) 543 | 544 | 545 | {-| Focus for the `label` field of `Node` and `Edge`. 546 | -} 547 | label : Focus { record | label : field } field 548 | label = 549 | Focus.create .label (\update record -> { record | label = update record.label }) 550 | 551 | 552 | {-| Focus for the `from` field of `Edge`. 553 | -} 554 | from : Focus { record | from : field } field 555 | from = 556 | Focus.create .from (\update record -> { record | from = update record.from }) 557 | 558 | 559 | {-| Focus for the `to` field of `Edge`. 560 | -} 561 | to : Focus { record | to : field } field 562 | to = 563 | Focus.create .to (\update record -> { record | to = update record.to }) 564 | 565 | 566 | {-| Focus for the `node` field of `NodeContext`. 567 | -} 568 | node : Focus { record | node : field } field 569 | node = 570 | Focus.create .node (\update record -> { record | node = update record.node }) 571 | 572 | 573 | {-| Focus for the `incoming` field of `NodeContext`. 574 | -} 575 | incoming : Focus { record | incoming : field } field 576 | incoming = 577 | Focus.create .incoming (\update record -> { record | incoming = update record.incoming }) 578 | 579 | 580 | {-| Focus for the `outgoing` field of `NodeContext`. 581 | -} 582 | outgoing : Focus { record | outgoing : field } field 583 | outgoing = 584 | Focus.create .outgoing (\update record -> { record | outgoing = update record.outgoing }) 585 | 586 | 587 | graphRep : Focus (Graph n e) (GraphRep n e) 588 | graphRep = 589 | Focus.create unGraph (\update -> unGraph >> update >> Graph) 590 | 591 | 592 | lookup : NodeId -> Focus (IntDict v) (Maybe v) 593 | lookup nodeId = 594 | Focus.create (IntDict.get nodeId) (IntDict.update nodeId) 595 | 596 | 597 | {-| `nodeById nodeId` focuses on the node with id `nodeId` with a `Graph`. 598 | Since the node might or might not exist, the small part on which we focus wraps 599 | the `NodeContext` in a `Maybe`. 600 | 601 | This is a combination of the `get` and `update` functions which is handy for 602 | composition of foci deep into a graph. Unfortunately, we need a combinator which 603 | would get rid of the `Maybe` wrapping (that would be the task of a prism I think), 604 | but suppose we have something like `Focus.withDefault : a -> Focus (Maybe a) a`, 605 | then we could define 606 | 607 | ctx = NodeContext (Node 2 "2") IntDict.empty IntDict.empty 608 | focus = nodeById 2 => Focus.withDefault ctx => node => label 609 | graph = fromNodesAndEdges [Node 1 "1", Node 2 "2"] [Edge 1 2 "->"] 610 | graph1 = Focus.set focus graph "=" 611 | Focus.get focus graph1 == "=" 612 | 613 | Well, I hope I could bring over the point. 614 | -} 615 | nodeById : NodeId -> Focus (Graph n e) (Maybe (NodeContext n e)) 616 | nodeById nodeId = 617 | Focus.create (get nodeId) (update nodeId) 618 | 619 | 620 | {-| Focuses on an arbitrary `NodeContext` of a `Graph`. 621 | This exists for the same purposes as `nodeById`, but this focuses on an 622 | arbitrary node rather than on a node with a specific id. 623 | -} 624 | anyNode : Focus (Graph n e) (Maybe (NodeContext n e)) 625 | anyNode = 626 | let 627 | getMinId = 628 | Focus.get graphRep >> IntDict.findMin >> Maybe.map fst 629 | 630 | get graph = 631 | getMinId graph `Maybe.andThen` \id -> Focus.get (nodeById id) graph 632 | 633 | update upd graph = 634 | let 635 | nodeId = 636 | Maybe.withDefault 0 (getMinId graph) 637 | in 638 | Focus.update (nodeById nodeId) upd graph 639 | in 640 | Focus.create get update 641 | 642 | 643 | {- TRANSFORMS -} 644 | 645 | 646 | {-| A fold over all node contexts. The accumulated value is computed lazily, 647 | so that the fold can exit early when the suspended accumulator is not forced. 648 | 649 | hasLoop ctx = IntDict.member ctx.node.id ctx.incoming 650 | graph = fromNodesAndEdges [Node 1 "1", Node 2 "2"] [Edge 1 2 "->"] 651 | -- The graph should not have any loop. 652 | fold (\ctx acc -> acc || hasLoop ctx) False graph == False 653 | -} 654 | fold : (NodeContext n e -> acc -> acc) -> acc -> Graph n e -> acc 655 | fold f acc graph = 656 | let 657 | go acc graph1 = 658 | let 659 | maybeContext = 660 | graph1 661 | |> nodeIdRange 662 | |> Maybe.map fst 663 | |> flip Maybe.andThen (\id -> get id graph) -- get should never return Nothing 664 | in 665 | case maybeContext of 666 | Just ctx -> 667 | go (f ctx acc) (remove ctx.node.id graph1) 668 | Nothing -> 669 | acc 670 | in 671 | go acc graph 672 | 673 | 674 | {-| Maps each node context to another one. This may change edge and node labels 675 | (including their types), possibly the node ids and also add or remove edges 676 | entirely through modifying the adjacency lists. 677 | 678 | The following is a specification for reverseEdges: 679 | 680 | flipEdges ctx = { ctx | incoming = ctx.outgoing, outgoing = ctx.incoming } 681 | graph = fromNodesAndEdges [Node 1 "1", Node 2 "2"] [Edge 1 2 "->"] 682 | reverseEdges graph == mapContexts flipEdges graph 683 | -} 684 | mapContexts : (NodeContext n1 e1 -> NodeContext n2 e2) -> Graph n1 e1 -> Graph n2 e2 685 | mapContexts f = 686 | fold (\ctx -> insert (f ctx)) empty 687 | 688 | 689 | {-| Maps over node labels, possibly changing their types. Leaves the graph 690 | topology intact. 691 | -} 692 | mapNodes : (n1 -> n2) -> Graph n1 e -> Graph n2 e 693 | mapNodes f = 694 | fold 695 | (\ctx -> 696 | insert 697 | { ctx 698 | | node = { id = ctx.node.id, label = f ctx.node.label } 699 | }) 700 | empty 701 | 702 | 703 | {-| Maps over edge labels, possibly chaing their types. Leaves the graph 704 | topology intact. 705 | -} 706 | mapEdges : (e1 -> e2) -> Graph n e1 -> Graph n e2 707 | mapEdges f = 708 | fold 709 | (\ctx -> 710 | insert 711 | { ctx 712 | | outgoing = IntDict.map (\n e -> f e) ctx.outgoing 713 | , incoming = IntDict.map (\n e -> f e) ctx.incoming 714 | }) 715 | empty 716 | 717 | 718 | {- CHARACTERIZATION -} 719 | 720 | 721 | 722 | {- GRAPH OPS -} 723 | 724 | 725 | {-| `symmetricClosure edgeMerger graph` is the 726 | [symmetric closure](https://en.wikipedia.org/wiki/Symmetric_closure) of `graph`, 727 | e.g. the undirected equivalent, where for every edge in `graph` there is also 728 | a corresponding reverse edge. This implies that `ctx.incoming` == `ctx.outgoing` 729 | for each node context `ctx`. 730 | 731 | `edgeMerger` resolves conflicts for when there are already edges in both 732 | directions, e.g. the graph isn't truly directed. It is guaranteed that 733 | `edgeMerger` will only be called with the smaller node id passed in first 734 | to enforce consitency of merging decisions. 735 | 736 | graph = fromNodesAndEdges [Node 1 "1", Node 2 "2"] [Edge 1 2 "->"] 737 | onlyUndirectedEdges ctx = 738 | ctx.incoming == ctx.outgoing 739 | merger from to outgoingLabel incomingLabel = 740 | outgoingLabel -- quite arbitrary, will not be called for the above graph 741 | fold 742 | (\ctx acc -> acc && onlyUndirectedEdges ctx) 743 | True 744 | (symmetricClosure merger graph) 745 | == True 746 | -} 747 | symmetricClosure : (NodeId -> NodeId -> e -> e -> e) -> Graph n e -> Graph n e 748 | symmetricClosure edgeMerger = 749 | -- We could use mapContexts, but this will be more efficient. 750 | let 751 | orderedEdgeMerger from to outgoing incoming = 752 | if from <= to 753 | then edgeMerger from to outgoing incoming 754 | else edgeMerger to from incoming outgoing 755 | updateContext nodeId ctx = 756 | let 757 | edges = IntDict.uniteWith (orderedEdgeMerger nodeId) ctx.outgoing ctx.incoming 758 | in 759 | { ctx | outgoing = edges, incoming = edges } 760 | in 761 | Focus.update graphRep (IntDict.map updateContext) 762 | 763 | 764 | {-| Reverses the direction of every edge in the graph. 765 | -} 766 | reverseEdges : Graph n e -> Graph n e 767 | reverseEdges = 768 | let 769 | updateContext nodeId ctx = 770 | { ctx 771 | | outgoing = ctx.incoming 772 | , incoming = ctx.outgoing 773 | } 774 | in 775 | Focus.update graphRep (IntDict.map updateContext) 776 | 777 | 778 | {- TRAVERSALS -} 779 | 780 | 781 | {-| Selects the next neighbors for the currently visited node in the traversal. 782 | -} 783 | type alias NeighborSelector n e = 784 | NodeContext n e 785 | -> List NodeId 786 | 787 | 788 | {-| A good default for selecting neighbors is to just go along outgoing edges: 789 | 790 | alongOutgoingEdges ctx = 791 | IntDict.keys (ctx.outgoing) 792 | 793 | `dfs`/`bfs` use this as their selecting strategy. 794 | -} 795 | alongOutgoingEdges : NeighborSelector n e 796 | alongOutgoingEdges ctx = 797 | IntDict.keys (ctx.outgoing) 798 | 799 | 800 | {-| A less common way for selecting neighbors is to follow incoming edges: 801 | 802 | alongIncomingEdges ctx = 803 | IntDict.keys (ctx.incoming) 804 | -} 805 | alongIncomingEdges : NeighborSelector n e 806 | alongIncomingEdges ctx = 807 | IntDict.keys (ctx.incoming) 808 | 809 | 810 | {-| A generic node visitor just like that in the ordinary `fold` function. 811 | There are combinators that make these usable for both depth-first traversal 812 | (`onDiscovery`, `onFinish`) and breadth-first traversal (`ignorePath`). 813 | -} 814 | type alias SimpleNodeVisitor n e acc = 815 | NodeContext n e 816 | -> acc 817 | -> acc 818 | 819 | 820 | {- DFS -} 821 | 822 | 823 | {-| A node visitor specialized for depth-first traversal. Along with the node 824 | context of the currently visited node, the current accumulated value is passed. 825 | The visitor then has the chance to both modify the value at discovery of the 826 | node through the first return value and also provide a finishing 827 | transformation which is called with the value after all children were processed 828 | and the node is about to be finished. 829 | 830 | In the cases where you don't need access to the value both at dicovery and at 831 | finish, look into `onDiscovery` and `onFinish`. 832 | -} 833 | type alias DfsNodeVisitor n e acc = 834 | NodeContext n e 835 | -> acc 836 | -> (acc, acc -> acc) 837 | 838 | 839 | {-| Transform a `SimpleNodeVisitor` into an equivalent `DfsNodeVisitor`, which 840 | will be called upon node discovery. This eases providing `DfsNodeVisitor`s in 841 | the default case: 842 | 843 | dfsPostOrder : Graph n e -> List (NodeContext n e) 844 | dfsPostOrder graph = 845 | dfs (onDiscovery (::)) [] graph 846 | -} 847 | onDiscovery : SimpleNodeVisitor n e acc -> DfsNodeVisitor n e acc 848 | onDiscovery visitor ctx acc = 849 | (visitor ctx acc, identity) 850 | 851 | 852 | {-| Transform a `SimpleNodeVisitor` into an equivalent `DfsNodeVisitor`, which 853 | will be called upon node finish. This eases providing `DfsNodeVisitor`s in 854 | the default case: 855 | 856 | dfsPreOrder : Graph n e -> List (NodeContext n e) 857 | dfsPreOrder graph = 858 | dfs (onFinish (::)) [] graph 859 | -} 860 | onFinish : SimpleNodeVisitor n e acc -> DfsNodeVisitor n e acc 861 | onFinish visitor ctx acc = 862 | (acc, visitor ctx) 863 | 864 | 865 | {-| The `dfs*` functions are not powerful enough? Go for this beast. 866 | 867 | `guidedDfs selectNeighbors visitNode seeds acc graph` will perform a depth-first 868 | traversal on `graph` starting with a stack of `seeds`. The children of each node 869 | will be selected with `selectNeighbors` (see `NeighborSelector`), the visiting 870 | of nodes is handled by `visitNode` (c.f. `DfsNodeVisitor`), folding `acc` over 871 | the graph. 872 | 873 | When there are not any more nodes to be visited, the function will return the 874 | accumulated value together with the unvisited rest of `graph`. 875 | 876 | dfsPreOrder graph = 877 | -- NodeId 1 is just a wild guess here 878 | guidedDfs alongOutgoingEdges (onDiscovery (::)) [1] [] graph 879 | -} 880 | guidedDfs 881 | : NeighborSelector n e 882 | -> DfsNodeVisitor n e acc 883 | -> List NodeId 884 | -> acc 885 | -> Graph n e 886 | -> (acc, Graph n e) 887 | guidedDfs selectNeighbors visitNode seeds acc graph = 888 | let 889 | go seeds acc graph = 890 | case seeds of 891 | [] -> -- We are done with this connected component, so we return acc and the rest of the graph 892 | (acc, graph) 893 | next :: seeds' -> 894 | case get next graph of 895 | -- This can actually happen since we don't filter for already visited nodes. 896 | -- That would be an opportunity for time-memory-tradeoff. 897 | -- E.g. Passing along a set of visited nodeIds. 898 | Nothing -> 899 | go seeds' acc graph 900 | Just ctx -> 901 | let 902 | (accAfterDiscovery, finishNode) = 903 | visitNode ctx acc 904 | 905 | (accBeforeFinish, graph1) = 906 | go (selectNeighbors ctx) accAfterDiscovery (remove next graph) 907 | 908 | accAfterFinish = 909 | finishNode accBeforeFinish 910 | in 911 | go seeds' accAfterFinish graph1 912 | in 913 | go seeds acc graph 914 | 915 | 916 | {-| An off-the-shelf depth-first traversal. It will visit all components of the 917 | graph in no guaranteed order, discovering nodes `alongOutgoingEdges`. 918 | See the docs of `DfsNodeVisitor` on how to supply such a beast. There are also 919 | examples on how to use `dfs`. 920 | -} 921 | dfs : DfsNodeVisitor n e acc -> acc -> Graph n e -> acc 922 | dfs visitNode acc graph = 923 | guidedDfs alongOutgoingEdges visitNode (nodeIds graph) acc graph |> fst 924 | 925 | 926 | {-| `dfsTree seed graph` computes a depth-first [spanning tree](https://en.wikipedia.org/wiki/Spanning_tree) of the component 927 | in `graph` starting from `seed` `alongOutgoingEdges`. This function is exemplary for needing to 928 | utilize the whole power of `DfsNodeVisitor`. 929 | -} 930 | dfsTree : NodeId -> Graph n e -> Tree (NodeContext n e) 931 | dfsTree seed graph = 932 | case dfsForest [seed] graph of 933 | [] -> 934 | Tree.empty 935 | [tree] -> 936 | tree 937 | _ -> 938 | Debug.crash "dfsTree: There can't be more than one DFS tree. This invariant is violated, please report this bug." 939 | 940 | 941 | {-| `dfsForest seeds graph` computes a depth-first spanning `Forest` of the 942 | components in `graph` spanned by `seeds` `alongOutgoingEdges`. 943 | 944 | A traversal over this forest would be equivalent to a depth-first traversal 945 | over the original graph. 946 | -} 947 | dfsForest : List NodeId -> Graph n e -> Forest (NodeContext n e) 948 | dfsForest seeds graph = 949 | let 950 | visitNode ctx trees = 951 | ([], \children -> Tree.inner ctx children :: trees) 952 | in 953 | guidedDfs alongOutgoingEdges visitNode seeds [] graph 954 | |> fst 955 | |> List.reverse 956 | 957 | 958 | {- BFS -} 959 | 960 | 961 | {-| A specialized node visitor for breadth-first traversal. Compared to a 962 | `SimpleNodeVisitor`, the path of contexts from the root to the current 963 | node is passed instead of just the current node's context. Additionally, the 964 | distance from the root is passed as an `Int` (the root has distance 0 and it 965 | holds always that `length path == distance - 1`). 966 | 967 | If you don't need the additional information, you can turn a `SimpleNodeVisitor` 968 | into a `BfsNodeVisitor` by calling `ignorePath`. 969 | -} 970 | type alias BfsNodeVisitor n e acc = 971 | List (NodeContext n e) 972 | -> Int 973 | -> acc 974 | -> acc 975 | 976 | 977 | {-| Turns a `SimpleNodeVisitor` into a `BfsNodeVisitor` by ignoring the path 978 | and distance parameters. 979 | This is useful for when the visitor should be agnostic of the 980 | traversal (breadth-first or depth-first or even just `fold`). 981 | 982 | bfsLevelOrder : List (NodeContext n e) 983 | bfsLevelOrder graph = 984 | graph 985 | |> bfs (ignorePath (::)) [] 986 | |> List.reverse 987 | -} 988 | ignorePath : SimpleNodeVisitor n e acc -> BfsNodeVisitor n e acc 989 | ignorePath visit path _ acc = 990 | case path of 991 | [] -> 992 | Debug.crash "Graph.ignorePath: No algorithm should ever pass an empty path into this BfsNodeVisitor." 993 | ctx :: path' -> 994 | visit ctx acc 995 | 996 | 997 | {-| The `bfs` function is not powerful enough? Go for this beast. 998 | 999 | `guidedBfs selectNeighbors visitNode seeds acc graph` will perform a breadth-first 1000 | traversal on `graph` starting with a queue of `seeds`. The children of each node 1001 | will be selected with `selectNeighbors` (see `NeighborSelector`), the visiting 1002 | of nodes is handled by `visitNode` (c.f. `BfsNodeVisitor`), folding `acc` over 1003 | the graph. 1004 | 1005 | When there are not any more nodes to be visited, the function will return the 1006 | accumulated value together with the unvisited rest of `graph`. 1007 | 1008 | bfsLevelOrder graph = 1009 | -- NodeId 1 is just a wild guess here 1010 | guidedBfs alongOutgoingEdges (ignorePath (::)) [1] [] graph 1011 | -} 1012 | guidedBfs 1013 | : NeighborSelector n e 1014 | -> BfsNodeVisitor n e acc 1015 | -> List NodeId 1016 | -> acc 1017 | -> Graph n e 1018 | -> (acc, Graph n e) 1019 | guidedBfs selectNeighbors visitNode seeds acc graph = 1020 | let 1021 | enqueueMany distance parentPath nodeIds queue = 1022 | nodeIds 1023 | |> List.map (\id -> (id, parentPath, distance)) 1024 | |> List.foldl Queue.push queue 1025 | go seeds acc graph = 1026 | case Queue.pop seeds of 1027 | Nothing -> -- We are done with this connected component, so we return acc and the rest of the graph 1028 | (acc, graph) 1029 | Just ((next, parentPath, distance), seeds') -> 1030 | case get next graph of 1031 | -- This can actually happen since we don't filter for already visited nodes. 1032 | -- That would be an opportunity for time-memory-tradeoff. 1033 | -- E.g. Passing along a set of visited nodeIds. 1034 | Nothing -> 1035 | go seeds' acc graph 1036 | Just ctx -> 1037 | let 1038 | path = 1039 | ctx :: parentPath 1040 | 1041 | acc' = 1042 | visitNode path distance acc 1043 | 1044 | seeds'' = 1045 | enqueueMany (distance + 1) path (selectNeighbors ctx) seeds' 1046 | in 1047 | go seeds'' acc' (remove next graph) 1048 | in 1049 | go (enqueueMany 0 [] seeds Queue.empty) acc graph 1050 | 1051 | 1052 | {-| An off-the-shelf breadth-first traversal. It will visit all components of the 1053 | graph in no guaranteed order, discovering nodes `alongOutgoingEdges`. 1054 | See the docs of `BfsNodeVisitor` on how to supply such a beast. There are also 1055 | examples on how to use `bfs`. 1056 | -} 1057 | bfs : BfsNodeVisitor n e acc -> acc -> Graph n e -> acc 1058 | bfs visitNode acc graph = 1059 | let 1060 | (acc', restgraph1) = 1061 | guidedBfs alongOutgoingEdges visitNode (nodeIds graph) acc graph 1062 | in 1063 | case nodeIdRange graph of 1064 | Nothing -> 1065 | acc 1066 | Just (id, _) -> 1067 | let 1068 | (acc', restgraph1) = 1069 | guidedBfs alongOutgoingEdges visitNode [id] acc graph 1070 | in 1071 | bfs visitNode acc' restgraph1 1072 | 1073 | 1074 | {-| Computes the height function of a given graph. This is a more general 1075 | [topological sort](https://en.wikipedia.org/wiki/Topological_sorting), 1076 | where independent nodes are in the same height level (e.g. the same list 1077 | index). A valid topological sort is trivially obtained by flattening the 1078 | result of this function. 1079 | 1080 | The height function is useful for solving the maximal clique problem for 1081 | certain [perfect graphs](https://en.wikipedia.org/wiki/Perfect_graph) 1082 | ([comparability graphs](https://en.wikipedia.org/wiki/Comparability_graph)). 1083 | There is the excellent reference 1084 | [Algorithmic Graph Theory and Perfect Graphs](http://dl.acm.org/citation.cfm?id=984029). 1085 | -} 1086 | heightLevels : Graph n e -> List (List (NodeContext n e)) 1087 | heightLevels graph = 1088 | let 1089 | sources = 1090 | fold 1091 | (\ctx acc -> 1092 | if IntDict.isEmpty ctx.incoming 1093 | then ctx :: acc 1094 | else acc) 1095 | [] 1096 | graph 1097 | 1098 | countIndegrees = 1099 | fold 1100 | (\ctx -> 1101 | IntDict.insert 1102 | ctx.node.id 1103 | (IntDict.size ctx.incoming)) 1104 | IntDict.empty 1105 | 1106 | subtract a b = 1107 | b - a 1108 | 1109 | decrementAndNoteSources id _ (nextLevel, indegrees) = 1110 | let 1111 | indegrees' = IntDict.update id (Maybe.map (subtract 1)) indegrees 1112 | in 1113 | case IntDict.get id indegrees' of 1114 | Just 0 -> 1115 | case get id graph of 1116 | Just ctx -> (ctx :: nextLevel, indegrees') 1117 | Nothing -> Debug.crash "Graph.heightLevels: Could not get a node of a graph which should be there by invariants. Please file a bug report!" 1118 | _ -> 1119 | (nextLevel, indegrees') 1120 | 1121 | decrementIndegrees source nextLevel indegrees = 1122 | IntDict.foldl decrementAndNoteSources (nextLevel, indegrees) source.outgoing 1123 | 1124 | go currentLevel nextLevel indegrees graph = 1125 | case (currentLevel, nextLevel) of 1126 | ([], []) -> 1127 | [[]] 1128 | ([], _) -> 1129 | [] :: go nextLevel [] indegrees graph 1130 | (source :: currentLevel', _) -> 1131 | let 1132 | (nextLevel', indegrees') = decrementIndegrees source nextLevel indegrees 1133 | in 1134 | case go currentLevel' nextLevel' indegrees' (remove source.node.id graph) of 1135 | [] -> 1136 | Debug.crash "Graph.heightLevels: Reached a branch which is impossible by invariants. Please file a bug report!" 1137 | level :: levels -> 1138 | (source :: level) :: levels 1139 | in 1140 | go sources [] (countIndegrees graph) graph 1141 | 1142 | 1143 | {-| Computes a 1144 | [topological ordering](https://en.wikipedia.org/wiki/Topological_sorting) of the 1145 | given graph. 1146 | -} 1147 | topologicalSort : Graph n e -> List (NodeContext n e) 1148 | topologicalSort graph = 1149 | graph 1150 | |> dfsForest (nodeIds graph) 1151 | |> List.reverse 1152 | |> List.concatMap Tree.preOrderList 1153 | 1154 | 1155 | {-| Decomposes a graph into its strongly connected components. The resulting 1156 | list is a topological ordering of the component graph. 1157 | -} 1158 | stronglyConnectedComponents : Graph n e -> List (Graph n e) 1159 | stronglyConnectedComponents graph = 1160 | -- Based on Cormen, using 2 DFS 1161 | let 1162 | timestamps = 1163 | dfs (onFinish (.node >> .id >> (::))) [] graph 1164 | 1165 | forest = 1166 | dfsForest timestamps (reverseEdges graph) -- We could optimize out reverseEdges 1167 | 1168 | components = 1169 | List.map (Tree.preOrderList >> List.foldr insert empty >> reverseEdges) forest 1170 | in 1171 | components 1172 | 1173 | 1174 | 1175 | 1176 | {- toString -} 1177 | 1178 | {-| Returns a string representation of the graph in the format of 1179 | `Graph.fromNodesAndEdges [] []`. 1180 | -} 1181 | toString' : Graph n e -> String 1182 | toString' graph = 1183 | let 1184 | nodeList = nodes graph 1185 | edgeList = edges graph 1186 | in 1187 | "Graph.fromNodesAndEdges " ++ toString nodeList ++ " " ++ toString edgeList 1188 | --------------------------------------------------------------------------------