├── .gitignore ├── .travis.yml ├── elm.json ├── LICENSE ├── src ├── Graph │ ├── TGF.elm │ ├── DOT.elm │ └── Tree.elm └── Graph.elm ├── README.md └── tests └── Tests ├── Graph ├── TGF.elm ├── Tree.elm └── DOT.elm └── Graph.elm /.gitignore: -------------------------------------------------------------------------------- 1 | elm.js 2 | elm-stuff/ 3 | repl-temp-000.* 4 | tests/elm-io.sh 5 | tests/*.js 6 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: node_js 2 | node_js: 3 | - "5" 4 | install: 5 | - npm install -g elm 6 | - npm install -g elm-format@0.8.0 7 | - npm install -g elm-test@beta 8 | - elm-format --validate src/ tests/ 9 | script: 10 | - elm-test 11 | -------------------------------------------------------------------------------- /elm.json: -------------------------------------------------------------------------------- 1 | { 2 | "type": "package", 3 | "name": "elm-community/graph", 4 | "summary": "Handling graphs the functional way.", 5 | "license": "MIT", 6 | "version": "7.0.0", 7 | "exposed-modules": [ 8 | "Graph", 9 | "Graph.Tree", 10 | "Graph.DOT", 11 | "Graph.TGF" 12 | ], 13 | "elm-version": "0.19.0 <= v < 0.20.0", 14 | "dependencies": { 15 | "avh4/elm-fifo": "1.0.4 <= v < 2.0.0", 16 | "elm/core": "1.0.0 <= v < 2.0.0", 17 | "elm/json": "1.0.0 <= v < 2.0.0", 18 | "elm-community/intdict": "3.0.0 <= v < 4.0.0" 19 | }, 20 | "test-dependencies": { 21 | "elm-explorations/test": "2.0.0 <= v < 3.0.0" 22 | } 23 | } 24 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 Sebastian Graf 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /src/Graph/TGF.elm: -------------------------------------------------------------------------------- 1 | module Graph.TGF exposing (output) 2 | 3 | {-| This module provides a means of converting the `Graph` data type into a 4 | valid [TGF](https://en.wikipedia.org/wiki/Trivial_Graph_Format) string for 5 | visualizing your graph structure. 6 | 7 | You can preview your graph by inserting the generated string into 8 | [yEd](http://www.yworks.com/products/yed) or other compatible software. 9 | 10 | 11 | # Conversion 12 | 13 | @docs output 14 | 15 | -} 16 | 17 | import Graph exposing (Graph, edges, nodes) 18 | 19 | 20 | {-| Converts a `Graph` into a valid TGF string. 21 | -} 22 | output : (node -> String) -> (edge -> String) -> Graph node edge -> String 23 | output mapNode mapEdge graph = 24 | let 25 | nodes = 26 | Graph.nodes graph 27 | |> List.map 28 | (\{ id, label } -> 29 | String.fromInt id ++ " " ++ mapNode label 30 | ) 31 | |> List.sort 32 | 33 | edges = 34 | Graph.edges graph 35 | |> List.map 36 | (\{ from, to, label } -> 37 | String.fromInt from ++ " " ++ String.fromInt to ++ " " ++ mapEdge label 38 | ) 39 | |> List.sort 40 | in 41 | (nodes ++ "#" :: edges) 42 | -- trimming is questionable; little info about the format exists. 43 | -- yEd imports it fine though. 44 | |> List.map String.trim 45 | |> String.join "\n" 46 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Graph [![Build Status](https://travis-ci.org/elm-community/graph.svg)](https://travis-ci.org/elm-community/graph) 2 | An neat graph library for Elm. 3 | 4 | Got confused about what to wear when putting on shoes? This will help you out: 5 | 6 | ```elm 7 | dressUp : Graph String () -- node labels are strings, edge labels are empty 8 | dressUp = 9 | let 10 | nodes = 11 | [ Node 0 "Socks" 12 | , Node 1 "Undershirt" 13 | , Node 2 "Pants" 14 | , Node 3 "Shoes" 15 | , Node 4 "Watch" 16 | , Node 5 "Shirt" 17 | , Node 6 "Belt" 18 | , Node 7 "Tie" 19 | , Node 8 "Jacket" 20 | ] 21 | 22 | e from to = 23 | Edge from to () 24 | 25 | edges = 26 | [ e 0 3 -- socks before shoes 27 | , e 1 2 -- undershorts before pants 28 | , e 1 3 -- undershorts before shoes 29 | , e 2 3 -- pants before shoes 30 | , e 2 6 -- pants before belt 31 | , e 5 6 -- shirt before belt 32 | , e 5 7 -- shirt before tie 33 | , e 6 8 -- belt before jacket 34 | , e 7 8 -- tie before jacket 35 | ] 36 | in 37 | Graph.fromNodesAndEdges nodes edges 38 | 39 | 40 | iWantToWearShoes: List String 41 | iWantToWearShoes = 42 | Graph.guidedDfs 43 | Graph.alongIncomingEdges -- which edges to follow 44 | (Graph.onDiscovery (\ctx list -> -- append node labels on discovery 45 | ctx.node.label :: list)) 46 | [3 {- "Shoes" NodeId -}] -- start with the node labelled "Shoes" 47 | [] -- accumulate starting with the empty list 48 | dressUp -- traverse our dressUp graph from above 49 | |> Tuple.first -- ignores the untraversed rest of the graph 50 | 51 | 52 | iWantToWearShoes == ["Pants", "Undershorts", "Socks", "Shoes"] 53 | ``` 54 | 55 | So better wear pants, undershorts, pants and socks with your shoes. 56 | (In case you wonder: There is also a `topologicalSort` function which can compute 57 | valid linear orderings) 58 | 59 | # Credits 60 | 61 | I was inspired by Martin Erwig's original idea realized in the 62 | [functional graph library](http://hackage.haskell.org/package/fgl-5.5.2.1), but 63 | I also tried to keep it as simple as possible, bringing the neatness of Elm to 64 | graph libraries. 65 | -------------------------------------------------------------------------------- /tests/Tests/Graph/TGF.elm: -------------------------------------------------------------------------------- 1 | module Tests.Graph.TGF exposing (all) 2 | 3 | import Expect 4 | import Graph exposing (Edge, Node) 5 | import Graph.TGF exposing (..) 6 | import Test exposing (..) 7 | 8 | 9 | all : Test 10 | all = 11 | describe "TGF" 12 | [ describe "output" <| 13 | [ test "without edge labels" <| 14 | let 15 | nodes = 16 | [ Node 0 { text = "This" } 17 | , Node 1 { text = "Is" } 18 | , Node 2 { text = "TGF" } 19 | , Node 3 { text = "Trivial" } 20 | , Node 4 { text = "Graph" } 21 | , Node 5 { text = "Format" } 22 | ] 23 | 24 | e from to = 25 | Edge from to () 26 | 27 | edges = 28 | [ e 0 1 29 | , e 1 2 30 | , e 3 2 31 | , e 4 2 32 | , e 5 2 33 | ] 34 | 35 | g = 36 | Graph.fromNodesAndEdges nodes edges 37 | 38 | expected = 39 | """0 This 40 | 1 Is 41 | 2 TGF 42 | 3 Trivial 43 | 4 Graph 44 | 5 Format 45 | # 46 | 0 1 47 | 1 2 48 | 3 2 49 | 4 2 50 | 5 2""" 51 | 52 | actual = 53 | output .text (always "") g 54 | in 55 | \() -> Expect.equal expected actual 56 | , test "with edge labels" <| 57 | let 58 | nodes = 59 | [ Node 0 { text = "This" } 60 | , Node 1 { text = "Is" } 61 | , Node 2 { text = "TGF" } 62 | , Node 3 { text = "Trivial" } 63 | , Node 4 { text = "Graph" } 64 | , Node 5 { text = "Format" } 65 | ] 66 | 67 | e from to label = 68 | Edge from to { text = label } 69 | 70 | edges = 71 | [ e 0 1 "a" 72 | , e 1 2 "b" 73 | , e 3 2 "c" 74 | , e 4 2 "d" 75 | , e 5 2 "e" 76 | ] 77 | 78 | g = 79 | Graph.fromNodesAndEdges nodes edges 80 | 81 | expected = 82 | """0 This 83 | 1 Is 84 | 2 TGF 85 | 3 Trivial 86 | 4 Graph 87 | 5 Format 88 | # 89 | 0 1 a 90 | 1 2 b 91 | 3 2 c 92 | 4 2 d 93 | 5 2 e""" 94 | 95 | actual = 96 | output .text .text g 97 | in 98 | \() -> Expect.equal expected actual 99 | ] 100 | ] 101 | -------------------------------------------------------------------------------- /tests/Tests/Graph/Tree.elm: -------------------------------------------------------------------------------- 1 | module Tests.Graph.Tree exposing (all) 2 | 3 | import Expect 4 | import Graph.Tree as Tree exposing (Tree) 5 | import Test exposing (..) 6 | 7 | 8 | size : Tree a -> Int 9 | size tree = 10 | tree 11 | |> Tree.preOrderList 12 | |> List.length 13 | 14 | 15 | all : Test 16 | all = 17 | let 18 | innerExample1 = 19 | Tree.inner 1 [ Tree.leaf 2, Tree.leaf 3, Tree.leaf 4 ] 20 | 21 | innerExample2 = 22 | Tree.inner 1 [ Tree.leaf 2, Tree.leaf 3, Tree.leaf 4, Tree.empty ] 23 | 24 | buildingTests = 25 | describe "building" 26 | [ test "empty has no nodes" <| \() -> Expect.equal 0 (size Tree.empty) 27 | , test "leaf has one node" <| \() -> Expect.equal 1 (size (Tree.leaf 42)) 28 | , test "inner with 3 children has 3 nodes" <| 29 | \() -> 30 | Expect.equal 4 (size innerExample1) 31 | , test "inner removes empty children" <| 32 | \() -> 33 | Expect.equal innerExample1 innerExample2 34 | , test "unfoldTree" <| 35 | \() -> 36 | Expect.equal 37 | innerExample1 38 | (Tree.unfoldTree 39 | (\s -> 40 | ( s 41 | , if s == 1 then 42 | [ 2, 3, 4 ] 43 | 44 | else 45 | [] 46 | ) 47 | ) 48 | 1 49 | ) 50 | ] 51 | 52 | queryTests = 53 | describe "query" 54 | [ test "empty isEmpty" <| \() -> Expect.equal True (Tree.isEmpty Tree.empty) 55 | , test "leaf is not empty" <| \() -> Expect.equal False (Tree.isEmpty (Tree.leaf 42)) 56 | , test "inner with 2 children is not empty" <| 57 | \() -> 58 | Expect.equal False (Tree.isEmpty (Tree.leaf ())) 59 | , test "root of a non-empty tree" <| 60 | \() -> 61 | Expect.equal (Just ( 42, [] )) (Tree.root (Tree.leaf 42)) 62 | , test "root of an empty tree" <| 63 | \() -> 64 | Expect.equal Nothing (Tree.root Tree.empty) 65 | , test "size of a non-empty tree" <| 66 | \() -> 67 | Expect.equal (Tree.size traversedTree) 7 68 | , test "height of a non-empty tree" <| 69 | \() -> 70 | Expect.equal (Tree.height traversedTree) 3 71 | , test "height of an empty tree" <| 72 | \() -> 73 | Expect.equal (Tree.height Tree.empty) 0 74 | ] 75 | 76 | mapTests = 77 | let 78 | sample = 79 | Tree.inner 1 [ Tree.leaf 2, Tree.leaf 3, Tree.leaf 4, Tree.empty ] 80 | 81 | samplePlusOne = 82 | Tree.inner 10 [ Tree.leaf 20, Tree.leaf 30, Tree.leaf 40, Tree.empty ] 83 | in 84 | describe "map" 85 | [ test "does not change empty" <| 86 | \() -> 87 | Expect.equal True (Tree.isEmpty <| Tree.map identity Tree.empty) 88 | |> Expect.onFail "empty remains empty" 89 | , test "does not change structure of a tree" <| 90 | \() -> Expect.equal sample <| Tree.map identity sample 91 | , test "applies function to all nodes" <| 92 | \() -> Expect.equal samplePlusOne <| Tree.map (\x -> x * 10) sample 93 | ] 94 | 95 | traversedTree = 96 | Tree.inner 0 97 | [ Tree.inner 1 98 | [ Tree.leaf 2, Tree.leaf 3 ] 99 | , Tree.inner 4 100 | [ Tree.leaf 5, Tree.leaf 6 ] 101 | ] 102 | 103 | traversalTests = 104 | describe "traversal" 105 | [ test "levelOrderList" <| 106 | \() -> 107 | Expect.equal 108 | [ 0, 1, 4, 2, 3, 5, 6 ] 109 | (Tree.levelOrderList traversedTree) 110 | , test "postOrderList" <| 111 | \() -> 112 | Expect.equal 113 | [ 2, 3, 1, 5, 6, 4, 0 ] 114 | (Tree.postOrderList traversedTree) 115 | , test "preOrderList" <| 116 | \() -> 117 | Expect.equal 118 | [ 0, 1, 2, 3, 4, 5, 6 ] 119 | (Tree.preOrderList traversedTree) 120 | ] 121 | 122 | unitTests = 123 | describe "unit tests" 124 | [ buildingTests 125 | , queryTests 126 | , traversalTests 127 | , mapTests 128 | ] 129 | in 130 | describe "The Graph.Tree module" 131 | [ unitTests 132 | ] 133 | -------------------------------------------------------------------------------- /src/Graph/DOT.elm: -------------------------------------------------------------------------------- 1 | module Graph.DOT exposing 2 | ( output 3 | , Styles, Rankdir(..), defaultStyles, outputWithStyles, outputWithStylesAndAttributes 4 | ) 5 | 6 | {-| This module provides a means of converting the `Graph` data type into a 7 | valid [DOT](https://en.wikipedia.org/wiki/DOT_(graph_description_language)) 8 | string for visualizing your graph structure. 9 | 10 | You can easily preview your graph by inserting the generated string into an 11 | online GraphViz tool like . 12 | 13 | You can also dynamically draw your graph in your application by sending the 14 | string over a port to the javascript version of the GraphViz library, 15 | (see the examples there fore more 16 | specifics on how to embed the generated visualization). 17 | 18 | @docs output 19 | 20 | 21 | # Attrs 22 | 23 | GraphViz allows for customizing the graph's look via "Attrs." 24 | 25 | @docs Styles, Rankdir, defaultStyles, outputWithStyles, outputWithStylesAndAttributes 26 | 27 | -} 28 | 29 | import Dict exposing (Dict) 30 | import Graph exposing (Graph, edges, nodes) 31 | import Json.Encode 32 | 33 | 34 | {-| Converts a `Graph` into a valid DOT string. 35 | Note that you must supply conversion functions for node labels and edge labels 36 | to `Maybe String`s. 37 | 38 | When a conversion function returns `Nothing`, no _label_ attribute is output. 39 | For nodes, GraphViz falls back to displaying node ids. 40 | For edges, no label is displayed. 41 | 42 | -} 43 | output : (n -> Maybe String) -> (e -> Maybe String) -> Graph n e -> String 44 | output = 45 | outputWithStyles defaultStyles 46 | 47 | 48 | {-| A type representing the attrs to apply at the graph, node, and edge 49 | entities (subgraphs and cluster subgraphs are not supported). 50 | 51 | Note that `Styles` is made up of strings, which loses type safety, but 52 | allows you to use any GraphViz attrs without having to model them out in 53 | entirety in this module. It is up to you to make sure you provide valid 54 | attr strings. See for available 55 | options. 56 | 57 | -} 58 | type alias Styles = 59 | { rankdir : Rankdir 60 | , graph : String 61 | , node : String 62 | , edge : String 63 | } 64 | 65 | 66 | {-| Values to control the direction of the graph 67 | -} 68 | type Rankdir 69 | = TB 70 | | LR 71 | | BT 72 | | RL 73 | 74 | 75 | {-| A blank `Styles` record to build from to define your own styles. 76 | 77 | myStyles = 78 | { defaultStyles 79 | | node = "shape=box, color=blue, style=\"rounded, filled\"" 80 | } 81 | 82 | -} 83 | defaultStyles : Styles 84 | defaultStyles = 85 | Styles TB "" "" "" 86 | 87 | 88 | {-| Same as `output`, but allows you to add attrs to the graph. 89 | These attrs will be applied to the entire graph. 90 | -} 91 | outputWithStyles : Styles -> (n -> Maybe String) -> (e -> Maybe String) -> Graph n e -> String 92 | outputWithStyles styles mapNode mapEdge graph = 93 | let 94 | labelOnly maybeLabel = 95 | case maybeLabel of 96 | Nothing -> 97 | Dict.empty 98 | 99 | Just l -> 100 | Dict.singleton "label" l 101 | in 102 | outputWithStylesAndAttributes styles (labelOnly << mapNode) (labelOnly << mapEdge) graph 103 | 104 | 105 | {-| Same as `outputWithStyles`, but allows each node and edge to include its 106 | own attrs. Note that you must supply a conversion function for node and edge 107 | labels that return a `Dict String String` of the attribute mappings. 108 | 109 | Note that you have to take care of setting the appropriate node and edge labels 110 | yourself. 111 | 112 | -} 113 | outputWithStylesAndAttributes : 114 | Styles 115 | -> (n -> Dict String String) 116 | -> (e -> Dict String String) 117 | -> Graph n e 118 | -> String 119 | outputWithStylesAndAttributes styles nodeAttrs edgeAttrs graph = 120 | let 121 | encode : String -> String 122 | encode = 123 | Json.Encode.string 124 | >> Json.Encode.encode 0 125 | 126 | attrAssocs : Dict String String -> String 127 | attrAssocs = 128 | Dict.toList 129 | >> List.map (\( k, v ) -> k ++ "=" ++ encode v) 130 | >> String.join ", " 131 | 132 | makeAttrs : Dict String String -> String 133 | makeAttrs d = 134 | if Dict.isEmpty d then 135 | "" 136 | 137 | else 138 | " [" ++ attrAssocs d ++ "]" 139 | 140 | edges = 141 | let 142 | compareEdge a b = 143 | case compare a.from b.from of 144 | LT -> 145 | LT 146 | 147 | GT -> 148 | GT 149 | 150 | EQ -> 151 | compare a.to b.to 152 | in 153 | Graph.edges graph 154 | |> List.sortWith compareEdge 155 | 156 | nodes = 157 | Graph.nodes graph 158 | 159 | edgesString = 160 | List.map edge edges 161 | |> String.join "\n" 162 | 163 | edge e = 164 | " " 165 | ++ String.fromInt e.from 166 | ++ " -> " 167 | ++ String.fromInt e.to 168 | ++ makeAttrs (edgeAttrs e.label) 169 | 170 | nodesString = 171 | List.map node nodes 172 | |> String.join "\n" 173 | 174 | node n = 175 | " " 176 | ++ String.fromInt n.id 177 | ++ makeAttrs (nodeAttrs n.label) 178 | 179 | rankDirToString r = 180 | case r of 181 | TB -> 182 | "TB" 183 | 184 | LR -> 185 | "LR" 186 | 187 | BT -> 188 | "BT" 189 | 190 | RL -> 191 | "RL" 192 | in 193 | String.join "\n" 194 | [ "digraph G {" 195 | , " rankdir=" ++ rankDirToString styles.rankdir 196 | , " graph [" ++ styles.graph ++ "]" 197 | , " node [" ++ styles.node ++ "]" 198 | , " edge [" ++ styles.edge ++ "]" 199 | , "" 200 | , edgesString 201 | , "" 202 | , nodesString 203 | , "}" 204 | ] 205 | -------------------------------------------------------------------------------- /tests/Tests/Graph/DOT.elm: -------------------------------------------------------------------------------- 1 | module Tests.Graph.DOT exposing (all) 2 | 3 | import Dict 4 | import Expect 5 | import Graph exposing (Edge, Node) 6 | import Graph.DOT as DOT exposing (defaultStyles) 7 | import Test exposing (..) 8 | 9 | 10 | all : Test 11 | all = 12 | describe "DOT" 13 | [ describe "output" <| 14 | [ test "basic" <| 15 | let 16 | nodes = 17 | [ Node 0 "Welcome" 18 | , Node 1 "To" 19 | , Node 2 "Web" 20 | , Node 3 "\"GraphViz\"!" 21 | ] 22 | 23 | e from to = 24 | Edge from to () 25 | 26 | edges = 27 | [ e 0 1 28 | , e 1 2 29 | , e 1 3 30 | ] 31 | 32 | g = 33 | Graph.fromNodesAndEdges nodes edges 34 | 35 | expected = 36 | """digraph G { 37 | rankdir=TB 38 | graph [] 39 | node [] 40 | edge [] 41 | 42 | 0 -> 1 43 | 1 -> 2 44 | 1 -> 3 45 | 46 | 0 [label="Welcome"] 47 | 1 [label="To"] 48 | 2 [label="Web"] 49 | 3 [label="\\"GraphViz\\"!"] 50 | }""" 51 | 52 | actual = 53 | DOT.output Just (always Nothing) g 54 | in 55 | \() -> Expect.equal expected actual 56 | , test "with edge labels" <| 57 | let 58 | nodes = 59 | [ Node 0 "Welcome" 60 | , Node 1 "To" 61 | , Node 2 "Web" 62 | , Node 3 "GraphViz!" 63 | ] 64 | 65 | e from to l = 66 | Edge from to l 67 | 68 | edges = 69 | [ e 0 1 Nothing 70 | , e 1 2 (Just "wait for it") 71 | , e 1 3 (Just "ok") 72 | ] 73 | 74 | g = 75 | Graph.fromNodesAndEdges nodes edges 76 | 77 | expected = 78 | """digraph G { 79 | rankdir=TB 80 | graph [] 81 | node [] 82 | edge [] 83 | 84 | 0 -> 1 85 | 1 -> 2 [label="wait for it"] 86 | 1 -> 3 [label="ok"] 87 | 88 | 0 [label="Welcome"] 89 | 1 [label="To"] 90 | 2 [label="Web"] 91 | 3 [label="GraphViz!"] 92 | }""" 93 | 94 | actual = 95 | DOT.output Just identity g 96 | in 97 | \() -> Expect.equal expected actual 98 | , test "with styles" <| 99 | let 100 | nodes = 101 | [ Node 0 { text = "Welcome" } 102 | , Node 1 { text = "To" } 103 | , Node 2 { text = "Web" } 104 | , Node 3 { text = "GraphViz!" } 105 | ] 106 | 107 | e from to = 108 | Edge from to () 109 | 110 | edges = 111 | [ e 0 1 112 | , e 1 2 113 | , e 1 3 114 | ] 115 | 116 | g = 117 | Graph.fromNodesAndEdges nodes edges 118 | 119 | expected = 120 | """digraph G { 121 | rankdir=LR 122 | graph [bgcolor=red] 123 | node [shape=box, color=blue, style="rounded, filled"] 124 | edge [] 125 | 126 | 0 -> 1 127 | 1 -> 2 128 | 1 -> 3 129 | 130 | 0 [label="Welcome"] 131 | 1 [label="To"] 132 | 2 [label="Web"] 133 | 3 [label="GraphViz!"] 134 | }""" 135 | 136 | myStyles = 137 | { defaultStyles 138 | | rankdir = DOT.LR 139 | , graph = "bgcolor=red" 140 | , node = "shape=box, color=blue, style=\"rounded, filled\"" 141 | } 142 | 143 | actual = 144 | DOT.outputWithStyles myStyles (Just << .text) (always Nothing) g 145 | in 146 | \() -> Expect.equal expected actual 147 | , test "with styles with overrides" <| 148 | let 149 | n id text style = 150 | Node id { text = text, style = style } 151 | 152 | nodes = 153 | [ n 0 "Welcome" Nothing 154 | , n 1 "To" Nothing 155 | , n 2 "Web" Nothing 156 | , n 3 "GraphViz!" (Just "bold,filled") 157 | ] 158 | 159 | e from to pw = 160 | Edge from to { penwidth = pw } 161 | 162 | edges = 163 | [ e 0 1 Nothing 164 | , e 1 2 Nothing 165 | , e 1 3 (Just 5) 166 | ] 167 | 168 | myStyles = 169 | { defaultStyles 170 | | node = "style=rounded" 171 | } 172 | 173 | g = 174 | Graph.fromNodesAndEdges nodes edges 175 | 176 | nodeAttrs node = 177 | case node.style of 178 | Nothing -> 179 | Dict.singleton "label" node.text 180 | 181 | Just st -> 182 | Dict.fromList [ ( "label", node.text ), ( "style", st ) ] 183 | 184 | edgeAttrs edge = 185 | case edge.penwidth of 186 | Nothing -> 187 | Dict.empty 188 | 189 | Just pw -> 190 | Dict.singleton "penwidth" (Debug.toString pw) 191 | 192 | expected = 193 | """digraph G { 194 | rankdir=TB 195 | graph [] 196 | node [style=rounded] 197 | edge [] 198 | 199 | 0 -> 1 200 | 1 -> 2 201 | 1 -> 3 [penwidth="5"] 202 | 203 | 0 [label="Welcome"] 204 | 1 [label="To"] 205 | 2 [label="Web"] 206 | 3 [label="GraphViz!", style="bold,filled"] 207 | }""" 208 | 209 | actual = 210 | DOT.outputWithStylesAndAttributes myStyles nodeAttrs edgeAttrs g 211 | in 212 | \() -> Expect.equal expected actual 213 | , test "empty graph" <| 214 | let 215 | g = 216 | Graph.empty 217 | 218 | expected = 219 | """digraph G { 220 | rankdir=TB 221 | graph [] 222 | node [] 223 | edge [] 224 | 225 | 226 | 227 | 228 | }""" 229 | 230 | actual = 231 | DOT.output Just (always Nothing) g 232 | in 233 | \() -> Expect.equal expected actual 234 | , test "graph with nodes but no edges" <| 235 | let 236 | nodes = 237 | [ Node 0 "Hello" 238 | , Node 1 "Bye" 239 | ] 240 | 241 | edges = 242 | [] 243 | 244 | g = 245 | Graph.fromNodesAndEdges nodes edges 246 | 247 | expected = 248 | """digraph G { 249 | rankdir=TB 250 | graph [] 251 | node [] 252 | edge [] 253 | 254 | 255 | 256 | 0 [label="Hello"] 257 | 1 [label="Bye"] 258 | }""" 259 | 260 | actual = 261 | DOT.output Just (always Nothing) g 262 | in 263 | \() -> Expect.equal expected actual 264 | ] 265 | ] 266 | -------------------------------------------------------------------------------- /src/Graph/Tree.elm: -------------------------------------------------------------------------------- 1 | module Graph.Tree exposing 2 | ( Tree, Forest 3 | , empty, leaf, inner, unfoldTree, unfoldForest 4 | , map 5 | , isEmpty, root, size, height 6 | , levelOrder, levelOrderList, preOrder, preOrderList, postOrder, postOrderList 7 | ) 8 | 9 | {-| This module provides a simple tree data type of arbitrary arity (a rose tree). 10 | There are primitives for building and traversing such a tree. 11 | 12 | 13 | # Data 14 | 15 | @docs Tree, Forest 16 | 17 | 18 | # Building 19 | 20 | @docs empty, leaf, inner, unfoldTree, unfoldForest 21 | 22 | 23 | # Transforming 24 | 25 | @docs map 26 | 27 | 28 | # Query 29 | 30 | @docs isEmpty, root, size, height 31 | 32 | 33 | # Traversal 34 | 35 | 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. 36 | 37 | @docs levelOrder, levelOrderList, preOrder, preOrderList, postOrder, postOrderList 38 | 39 | -} 40 | 41 | import Fifo exposing (Fifo) 42 | 43 | 44 | {-| Data type representing an n-ary tree with node labels of type `a` 45 | Building such a tree is done with the `empty`, `leaf` and `inner` smart 46 | constructors. An example for a tree with three leafs and a root node: 47 | 48 | tree = 49 | inner 1 [ leaf 2, leaf 3, leaf 4 ] 50 | 51 | -} 52 | type Tree label 53 | = MkTree Int (Maybe ( label, List (Tree label) )) 54 | 55 | 56 | {-| This is just an alias for a list of trees, called a forest in the 57 | literature. 58 | -} 59 | type alias Forest label = 60 | List (Tree label) 61 | 62 | 63 | 64 | {- BUILDING -} 65 | 66 | 67 | {-| Construct an empty tree with no nodes. 68 | -} 69 | empty : Tree label 70 | empty = 71 | MkTree 0 Nothing 72 | 73 | 74 | {-| Construct a tree with a single node from a value for the node's label. 75 | 76 | tree : Tree Int 77 | tree = 78 | leaf 42 79 | 80 | -} 81 | leaf : label -> Tree label 82 | leaf val = 83 | inner val [] 84 | 85 | 86 | {-| Construct a new tree by `inner label children`, combining a number of 87 | subtrees `children` with a `label` for the new inner node which will be 88 | the root of the tree. Empty subtrees are filtered out. An example: 89 | 90 | tree1 = inner 1 [leaf 2, leaf 3, leaf 4] 91 | tree2 = inner 1 [leaf 2, leaf 3, leaf 4, empty] 92 | tree1 == tree2 93 | 94 | -} 95 | inner : label -> List (Tree label) -> Tree label 96 | inner label children = 97 | let 98 | nonEmptyChildren = 99 | List.filter (not << isEmpty) children 100 | 101 | totalSize = 102 | List.foldl ((+) << size) 1 nonEmptyChildren 103 | in 104 | MkTree totalSize (Just ( label, nonEmptyChildren )) 105 | 106 | 107 | {-| Construct a new tree with `unfoldTree next seed`, top to bottom. `next` will be 108 | called repeatedly with seeds, from which it should construct a label for 109 | the current tree node but also a list of seeds from which to unfold 110 | child nodes. This sort of works top to bottom compared to creating a 111 | tree bottom up by using the other primitives. 112 | 113 | tree1 = inner 1 [leaf 2, leaf 3, leaf 4] 114 | next seed = (seed, if seed == 1 then [2, 3, 4] else []) 115 | tree2 = unfoldTree next 1 116 | tree1 == tree2 117 | 118 | -} 119 | unfoldTree : (seed -> ( label, List seed )) -> seed -> Tree label 120 | unfoldTree next seed = 121 | let 122 | ( label, seeds ) = 123 | next seed 124 | in 125 | inner label (List.map (unfoldTree next) seeds) 126 | 127 | 128 | {-| Construct a new forest with `unfoldForest next seeds` by `unfoldTree next seed` 129 | for each `seed` in `seeds`. A simple specification would be 130 | 131 | unfoldForest next seeds = 132 | List.map (unfoldTree next) seeds 133 | 134 | -} 135 | unfoldForest : (seed -> ( label, List seed )) -> List seed -> Forest label 136 | unfoldForest next seeds = 137 | List.map (unfoldTree next) seeds 138 | 139 | 140 | 141 | {- TRANSFORMING -} 142 | 143 | 144 | {-| `map f tree` applies supplied function f to every label in a tree, without changing the structure of the tree 145 | 146 | map (\x -> x + 1) empty == empty 147 | 148 | map (\x -> x * 10) (inner 1 [ leaf 2, leaf 3 ]) == inner 10 [ leaf 20, leaf 30 ] 149 | 150 | -} 151 | map : (a -> b) -> Tree a -> Tree b 152 | map f (MkTree totalSize maybeLabelAndChildren) = 153 | MkTree totalSize <| 154 | Maybe.map 155 | (\( label, children ) -> ( f label, List.map (map f) children )) 156 | maybeLabelAndChildren 157 | 158 | 159 | 160 | {- QUERY -} 161 | 162 | 163 | {-| `isEmpty tree` returns true if and only if `tree` is `empty`. 164 | 165 | isEmpty empty == True 166 | 167 | isEmpty (leaf 42) == False 168 | 169 | -} 170 | isEmpty : Tree label -> Bool 171 | isEmpty tree = 172 | tree == empty 173 | 174 | 175 | {-| `root tree` returns `Nothing` if `tree` is `empty`, otherwise 176 | it returns `Just (label, childForest)` of the root node. 177 | 178 | tree = inner 1 [leaf 2, leaf 3, leaf 4] 179 | root tree == Just (1, [leaf 2, leaf 3, leaf 4]) 180 | root empty == Nothing 181 | 182 | -} 183 | root : Tree label -> Maybe ( label, Forest label ) 184 | root tree = 185 | case tree of 186 | MkTree _ maybe -> 187 | maybe 188 | 189 | 190 | {-| The size of the tree, e.g. the number of nodes. 191 | 192 | tree = inner 0 [inner 1 [leaf 2, leaf 3], inner 4 [leaf 5, leaf 6]] 193 | size tree == 7 194 | 195 | -} 196 | size : Tree label -> Int 197 | size tree = 198 | case tree of 199 | MkTree n _ -> 200 | n 201 | 202 | 203 | {-| Computes the height of the tree in O(n) time. 204 | 205 | tree = inner 0 [inner 1 [leaf 2, leaf 3], inner 4 [leaf 5, leaf 6]] 206 | height tree == 3 207 | 208 | -} 209 | height : Tree label -> Int 210 | height tree = 211 | let 212 | go h t = 213 | case root t of 214 | Just ( _, children ) -> 215 | children 216 | |> List.foldl (go (h + 1) >> max) (h + 1) 217 | 218 | Nothing -> 219 | h 220 | in 221 | go 0 tree 222 | 223 | 224 | 225 | {- TRAVERSAL -} 226 | -- This is private. No type annotation for this, traversal is quite daunting. 227 | 228 | 229 | listForTraversal traversal tree = 230 | -- we will compute a DList that we then can turn into a List. 231 | let 232 | f label children rest = 233 | (::) label >> rest 234 | 235 | acc = 236 | identity 237 | 238 | -- the call to postOrder returns a DList ([a] -> [a]), so [] turns it into a list 239 | in 240 | traversal f acc tree [] 241 | 242 | 243 | 244 | -- This is also not exported. 245 | 246 | 247 | pushMany : List a -> Fifo a -> Fifo a 248 | pushMany vals queue = 249 | List.foldl Fifo.insert queue vals 250 | 251 | 252 | {-| `levelOrder visit acc tree` is a breadth-first fold over `tree`, 253 | visiting each node and accumulating results with `visit`. Nodes are visited 254 | in level-order, e.g. for a tree like 255 | 256 | tree = 257 | inner 0 [ inner 1 [ leaf 2, leaf 3 ], inner 4 [ leaf 5, leaf 6 ] ] 258 | 259 | nodes would be visited in order `[0, 1, 4, 2, 3, 5, 6]`. This is in fact the 260 | list produced by `levelOrderList`, but through `levelOrder` you also get access 261 | to the children of the current node via the second parameter of visit. 262 | 263 | -} 264 | levelOrder : (label -> Forest label -> acc -> acc) -> acc -> Tree label -> acc 265 | levelOrder visit acc tree = 266 | let 267 | go acc_ toVisit = 268 | case Fifo.remove toVisit of 269 | ( Nothing, _ ) -> 270 | acc_ 271 | 272 | ( Just tree_, othersToVisit ) -> 273 | case root tree_ of 274 | Nothing -> 275 | go acc_ othersToVisit 276 | 277 | Just ( label, children ) -> 278 | go (visit label children acc_) (pushMany children othersToVisit) 279 | in 280 | go acc (Fifo.empty |> Fifo.insert tree) 281 | 282 | 283 | {-| See the documentation on `levelOrder`. `levelOrderList tree` produces 284 | a list of the nodes of the tree visited in level-order, e.g. breadth-first. 285 | So: 286 | 287 | tree = inner 0 [inner 1 [leaf 2, leaf 3], inner 4 [leaf 5, leaf 6]] 288 | levelOrderList tree == [0, 1, 4, 2, 3, 5, 6] 289 | 290 | If you also need information on child trees instead of just the node labels, 291 | use `levelOrder`. 292 | 293 | -} 294 | levelOrderList : Tree label -> List label 295 | levelOrderList = 296 | listForTraversal levelOrder 297 | 298 | 299 | {-| `postOrder visit acc tree` is a (depth-first) post-order traversal (fold) 300 | over `tree` where `visit` is called with the label and the child sub-forest of 301 | the current node in addition to a supplied accumulator value. 302 | 303 | When `visit` is called for some node, `acc` already contains the value of all 304 | sub-trees, so post-order traversal is a kind of bottom-up traversal, where 305 | all children are visited prior to their parent. 306 | See `postOrderList` for an example on the order in which nodes are visited. 307 | 308 | -} 309 | postOrder : (label -> Forest label -> acc -> acc) -> acc -> Tree label -> acc 310 | postOrder visit acc tree = 311 | let 312 | folder = 313 | \b a -> postOrder visit a b 314 | in 315 | case root tree of 316 | Nothing -> 317 | acc 318 | 319 | Just ( label, children ) -> 320 | visit label children (List.foldl folder acc children) 321 | 322 | 323 | {-| See `postOrder` for an explanation of how post-order traversals work. 324 | Here is an example on visit order: 325 | 326 | tree = inner 0 [inner 1 [leaf 2, leaf 3], inner 4 [leaf 5, leaf 6]] 327 | postOrderList tree == [2, 3, 1, 5, 6, 4, 0] 328 | 329 | If you also need information on child trees instead of just the node labels, 330 | use `postOrder`. 331 | 332 | -} 333 | postOrderList : Tree label -> List label 334 | postOrderList = 335 | listForTraversal postOrder 336 | 337 | 338 | {-| `preOrder visit acc tree` is a (depth-first) pre-order traversal (fold) 339 | over `tree` where `visit` is called with the label and the child sub-forest of 340 | the current node in addition to a supplied accumulator value. 341 | 342 | Pre-order traversals work top-down: When `visit` is called for some node, 343 | `acc` already contains the value of all ancestral nodes. 344 | See `preOrderList` for an example on the order in which nodes are visited. 345 | 346 | -} 347 | preOrder : (label -> Forest label -> acc -> acc) -> acc -> Tree label -> acc 348 | preOrder visit acc tree = 349 | let 350 | folder = 351 | \b a -> preOrder visit a b 352 | in 353 | case root tree of 354 | Nothing -> 355 | acc 356 | 357 | Just ( label, children ) -> 358 | List.foldl folder (visit label children acc) children 359 | 360 | 361 | {-| See `preOrder` for an explanation of how post-order traversals work. 362 | Here is an example on visit order: 363 | 364 | tree = inner 0 [inner 1 [leaf 2, leaf 3], inner 4 [leaf 5, leaf 6]] 365 | preOrderList tree == [0, 1, 2, 3, 4, 5, 6] 366 | 367 | If you also need information on child trees instead of just the node labels, 368 | use `preOrder`. 369 | 370 | -} 371 | preOrderList : Tree label -> List label 372 | preOrderList = 373 | listForTraversal preOrder 374 | -------------------------------------------------------------------------------- /tests/Tests/Graph.elm: -------------------------------------------------------------------------------- 1 | module Tests.Graph exposing (all) 2 | 3 | import Expect 4 | import Graph exposing (Edge, Graph, Node, NodeContext, NodeId) 5 | import IntDict 6 | import Test exposing (..) 7 | 8 | 9 | isJust : Maybe a -> Bool 10 | isJust m = 11 | case m of 12 | Just _ -> 13 | True 14 | 15 | _ -> 16 | False 17 | 18 | 19 | expectEqualComparing : (a -> b) -> a -> a -> Expect.Expectation 20 | expectEqualComparing f a b = 21 | Expect.equal (f a) (f b) 22 | 23 | 24 | edgeTriples : Graph n e -> List ( NodeId, NodeId, e ) 25 | edgeTriples = 26 | Graph.edges >> List.map (\e -> ( e.from, e.to, e.label )) 27 | 28 | 29 | dressUp : Graph String () 30 | dressUp = 31 | let 32 | nodes = 33 | [ Node 0 "Socks" 34 | , Node 1 "Undershorts" 35 | , Node 2 "Pants" 36 | , Node 3 "Shoes" 37 | , Node 4 "Watch" 38 | , Node 5 "Shirt" 39 | , Node 6 "Belt" 40 | , Node 7 "Tie" 41 | , Node 8 "Jacket" 42 | ] 43 | 44 | e from to = 45 | Edge from to () 46 | 47 | edges = 48 | [ e 0 3 -- socks before shoes 49 | , e 1 2 -- undershorts before pants 50 | , e 1 3 -- undershorts before shoes 51 | , e 2 3 -- pants before shoes 52 | , e 2 6 -- pants before belt 53 | , e 5 6 -- shirt before belt 54 | , e 5 7 -- shirt before tie 55 | , e 4 8 -- watch before jacket 56 | , e 6 8 -- belt before jacket 57 | , e 7 8 -- tie before jacket 58 | ] 59 | in 60 | Graph.fromNodesAndEdges nodes edges 61 | 62 | 63 | simple : Graph String (Maybe String) 64 | simple = 65 | let 66 | nodes = 67 | [ Node 0 "first" 68 | , Node 1 "second" 69 | , Node 2 "third" 70 | ] 71 | 72 | edges = 73 | [ Edge 0 1 Nothing 74 | , Edge 0 2 (Just "relationship") 75 | ] 76 | in 77 | Graph.fromNodesAndEdges nodes edges 78 | 79 | 80 | dressUpWithCycle : Graph String () 81 | dressUpWithCycle = 82 | let 83 | nodes = 84 | [ Node 0 "Socks" 85 | , Node 1 "Undershorts" 86 | , Node 2 "Pants" 87 | ] 88 | 89 | e from to = 90 | Edge from to () 91 | 92 | edges = 93 | [ e 0 1 94 | , e 1 2 95 | , e 2 0 96 | ] 97 | in 98 | Graph.fromNodesAndEdges nodes edges 99 | 100 | 101 | connectedComponents : Graph Char () 102 | connectedComponents = 103 | let 104 | nodes = 105 | [ 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h' ] 106 | 107 | edges = 108 | [ ( 0, 1 ) 109 | , ( 1, 2 ) 110 | , ( 1, 4 ) 111 | , ( 1, 5 ) 112 | , ( 2, 3 ) 113 | , ( 2, 6 ) 114 | , ( 3, 2 ) 115 | , ( 3, 7 ) 116 | , ( 4, 0 ) 117 | , ( 4, 5 ) 118 | , ( 5, 6 ) 119 | , ( 6, 5 ) 120 | , ( 6, 7 ) 121 | ] 122 | in 123 | Graph.fromNodeLabelsAndEdgePairs nodes edges 124 | 125 | 126 | noNeighbors : Node String -> NodeContext String () 127 | noNeighbors node = 128 | NodeContext node IntDict.empty IntDict.empty 129 | 130 | 131 | isValidTopologicalOrderingOf : Graph n e -> List (NodeContext n e) -> Bool 132 | isValidTopologicalOrderingOf graph ordering = 133 | ordering 134 | |> List.foldl 135 | (\ctx maybeIds -> 136 | maybeIds 137 | |> Maybe.andThen 138 | (\ids -> 139 | if List.all (\i -> IntDict.member i ids) (IntDict.keys ctx.incoming) then 140 | ids |> IntDict.insert ctx.node.id () |> Just 141 | 142 | else 143 | Nothing 144 | ) 145 | ) 146 | (Just IntDict.empty) 147 | |> isJust 148 | |> (&&) (List.length ordering == Graph.size graph) 149 | 150 | 151 | expectTopologicalOrderingOf : Graph String e -> List (NodeContext String e) -> Expect.Expectation 152 | expectTopologicalOrderingOf graph ordering = 153 | let 154 | message = 155 | String.join "\n" 156 | [ "Expected a valid topological ordering of " 157 | , " " ++ Graph.toString Just (always <| Just "") graph 158 | , "but got" 159 | , " " ++ Debug.toString ordering 160 | ] 161 | in 162 | Expect.equal True (isValidTopologicalOrderingOf graph ordering) 163 | |> Expect.onFail message 164 | 165 | 166 | all : Test 167 | all = 168 | let 169 | emptyTests = 170 | describe "empty" 171 | [ test "has size 0" <| \() -> Expect.equal 0 (Graph.size Graph.empty) 172 | , test "isEmpty" <| \() -> Expect.equal True (Graph.isEmpty Graph.empty) 173 | ] 174 | 175 | memberTests = 176 | describe "member" 177 | [ test "True" <| \() -> Expect.equal True (Graph.member 0 dressUp) 178 | , test "False" <| \() -> Expect.equal False (Graph.member 99 dressUp) 179 | ] 180 | 181 | getTests = 182 | describe "get" 183 | [ test "id 0, the socks" <| 184 | \() -> 185 | Expect.equal 186 | (Just "Socks") 187 | (dressUp |> Graph.get 0 |> Maybe.map (.node >> .label)) 188 | , test "id 99, Nothing" <| \() -> Expect.equal Nothing (Graph.get 99 dressUp) 189 | ] 190 | 191 | nodeIdRangeTests = 192 | describe "nodeIdRange" 193 | [ test "dressUp: [0, 8]" <| 194 | \() -> 195 | Expect.equal 196 | (Just ( 0, 8 )) 197 | (Graph.nodeIdRange dressUp) 198 | , test "dressUp - 0: [1, 8]" <| 199 | \() -> 200 | Expect.equal 201 | (Just ( 1, 8 )) 202 | (dressUp |> Graph.remove 0 |> Graph.nodeIdRange) 203 | , test "dressUp - 8: [0, 7]" <| 204 | \() -> 205 | Expect.equal 206 | (Just ( 0, 7 )) 207 | (dressUp |> Graph.remove 8 |> Graph.nodeIdRange) 208 | ] 209 | 210 | listRepTests = 211 | describe "list conversions" 212 | [ test "nodeIds" <| 213 | \() -> 214 | Expect.equal 215 | [ 0, 1, 2, 3, 4, 5, 6, 7, 8 ] 216 | (dressUp |> Graph.nodeIds) 217 | , test "nodes" <| 218 | \() -> 219 | Expect.equal 220 | [ 0, 1, 2, 3, 4, 5, 6, 7, 8 ] 221 | (dressUp |> Graph.nodes |> List.map .id) 222 | , test "edges" <| 223 | \() -> 224 | Expect.equal 225 | [ ( 0, 3 ), ( 1, 2 ), ( 1, 3 ), ( 2, 3 ), ( 2, 6 ), ( 4, 8 ), ( 5, 6 ), ( 5, 7 ), ( 6, 8 ), ( 7, 8 ) ] 226 | (dressUp 227 | |> Graph.edges 228 | |> List.map (\e -> ( e.from, e.to )) 229 | |> List.sort 230 | ) 231 | ] 232 | 233 | insertTests = 234 | describe "insert" 235 | [ test "new node - size" <| 236 | \() -> 237 | Expect.equal 238 | (dressUp |> Graph.size |> (+) 1) 239 | (dressUp |> Graph.insert (noNeighbors (Node 99 "Ring")) |> Graph.size) 240 | , test "new node - can get it" <| 241 | \() -> 242 | Expect.equal 243 | (Just "Ring") 244 | (dressUp 245 | |> Graph.insert (noNeighbors (Node 99 "Ring")) 246 | |> Graph.get 99 247 | |> Maybe.map (.node >> .label) 248 | ) 249 | , test "replace node - size" <| 250 | \() -> 251 | Expect.equal 252 | (dressUp |> Graph.size) 253 | (dressUp |> Graph.insert (noNeighbors (Node 0 "Ring")) |> Graph.size) 254 | , test "replace node - can get it" <| 255 | \() -> 256 | Expect.equal 257 | (Just "Ring") 258 | (dressUp 259 | |> Graph.insert (noNeighbors (Node 0 "Ring")) 260 | |> Graph.get 0 261 | |> Maybe.map (.node >> .label) 262 | ) 263 | , test "replace node - replaces adjacency" <| 264 | \() -> 265 | Expect.equal 266 | (Just True) 267 | (dressUp 268 | |> Graph.insert (noNeighbors (Node 0 "Ring")) 269 | |> Graph.get 0 270 | |> Maybe.map (\ctx -> IntDict.isEmpty ctx.incoming && IntDict.isEmpty ctx.outgoing) 271 | ) 272 | ] 273 | 274 | removeTests = 275 | describe "remove" 276 | [ test "nonexistent node" <| 277 | \() -> 278 | Expect.equal 279 | dressUp 280 | (dressUp |> Graph.remove 99) 281 | , test "existing node - size" <| 282 | \() -> 283 | Expect.equal 284 | (dressUp |> Graph.size |> (\i -> i - 1)) 285 | (dressUp |> Graph.remove 0 |> Graph.size) 286 | , test "existing node - can't get it" <| 287 | \() -> 288 | Expect.equal 289 | Nothing 290 | (dressUp |> Graph.remove 0 |> Graph.get 0) 291 | ] 292 | 293 | updateTests = 294 | describe "update" 295 | [ test "remove outgoing edges" <| 296 | \() -> 297 | Expect.equal 298 | (Just True) 299 | (dressUp 300 | |> Graph.update 0 301 | -- "Shorts" has outgoing edges 302 | (Maybe.map (\n -> { n | outgoing = IntDict.empty })) 303 | |> Graph.get 0 304 | |> Maybe.map (.outgoing >> IntDict.isEmpty) 305 | ) 306 | ] 307 | 308 | inducedSubgraphTests = 309 | describe "inducedSubgraph" 310 | [ test "should not have any dangling edges" <| 311 | \() -> 312 | expectEqualComparing 313 | (edgeTriples >> List.sortBy (\( f, t, _ ) -> ( f, t ))) 314 | (Graph.fromNodesAndEdges 315 | [ Node 0 'a', Node 1 'b', Node 4 'e' ] 316 | [ Edge 0 1 (), Edge 1 4 (), Edge 4 0 () ] 317 | ) 318 | (Graph.inducedSubgraph [ 0, 1, 4 ] connectedComponents) 319 | ] 320 | 321 | fromNodesAndEdgesTests = 322 | describe "fromNodesAndEdges" 323 | [ test "should not have any dangling edges" <| 324 | \() -> 325 | Expect.equal 326 | [ Edge 0 0 () ] 327 | (Graph.edges 328 | (Graph.fromNodesAndEdges 329 | [ Node 0 'a' ] 330 | [ Edge 0 0 (), Edge 0 1 (), Edge 1 0 (), Edge 1 1 () ] 331 | ) 332 | ) 333 | ] 334 | 335 | foldTests = 336 | describe "fold" 337 | [ test "sum up ids" <| 338 | \() -> 339 | Expect.equal 340 | 36 341 | (dressUp 342 | |> Graph.fold (\ctx -> (+) ctx.node.id) 0 343 | ) 344 | ] 345 | 346 | mapTests = 347 | describe "map*" 348 | [ test "mapContexts over id is the id" <| 349 | \() -> 350 | Expect.equal 351 | dressUp 352 | (dressUp |> Graph.mapContexts identity) 353 | , test "mapNodes over id is the id" <| 354 | \() -> 355 | Expect.equal 356 | dressUp 357 | (dressUp |> Graph.mapNodes identity) 358 | , test "mapEdges over id is the id" <| 359 | \() -> 360 | Expect.equal 361 | dressUp 362 | (dressUp |> Graph.mapNodes identity) 363 | 364 | -- This should be backed by more tests, but I'm not in the mood for that :/ 365 | ] 366 | 367 | toStringTests = 368 | describe "toString" 369 | [ test "works as expected" <| 370 | \() -> 371 | Expect.equal 372 | (Graph.toString Just identity simple) 373 | "Graph [Node 0 (first), Node 1 (second), Node 2 (third)] [Edge 0->2 (relationship), Edge 0->1]" 374 | ] 375 | 376 | graphOpsTests = 377 | describe "Graph ops" 378 | [ test "symmetricClosure is symmetric" <| 379 | \() -> 380 | Expect.equal True 381 | (dressUp 382 | |> Graph.symmetricClosure (\_ _ e _ -> e) 383 | |> Graph.fold 384 | (\ctx acc -> 385 | ctx.incoming == ctx.outgoing && acc 386 | ) 387 | True 388 | ) 389 | |> Expect.onFail 390 | "expected all incoming edges to also be outgoing and vice versa" 391 | , test "reverseEdges" <| 392 | \() -> 393 | Expect.equal 394 | (dressUp 395 | |> Graph.edges 396 | |> List.map (\e -> ( e.from, e.to )) 397 | |> List.sort 398 | ) 399 | (dressUp 400 | |> Graph.reverseEdges 401 | |> Graph.edges 402 | |> List.map (\e -> ( e.to, e.from )) 403 | |> List.sort 404 | ) 405 | ] 406 | 407 | checkAcyclicTests = 408 | describe "checkAcyclicTests" <| 409 | [ test "Ok for graph with no cycles" <| 410 | \() -> 411 | Expect.ok 412 | (Graph.checkAcyclic dressUp) 413 | , test "Err for cyclic graph" <| 414 | \() -> 415 | Expect.err 416 | (Graph.checkAcyclic dressUpWithCycle) 417 | , test "Err for connectedComponents" <| 418 | \() -> 419 | Expect.err 420 | (Graph.checkAcyclic connectedComponents) 421 | ] 422 | 423 | forgetAcyclicTests = 424 | describe "forgetAcyclic" <| 425 | [ test "returns corresponding Graph" <| 426 | \() -> 427 | case Graph.checkAcyclic dressUp of 428 | Ok acyclic -> 429 | Expect.equal dressUp (Graph.forgetAcyclic acyclic) 430 | |> Expect.onFail "graphs are not equal" 431 | 432 | Err _ -> 433 | Expect.fail "could not test - failed to produce AcyclicGraph" 434 | ] 435 | 436 | topologicalSortTests = 437 | describe "topologicalSort" 438 | [ test "valid topological ordering" <| 439 | \() -> 440 | case Graph.checkAcyclic dressUp of 441 | Err e -> 442 | Expect.fail 443 | ("dressUp should be acylic, but returned edge " ++ Debug.toString e) 444 | 445 | Ok acyclic -> 446 | acyclic 447 | |> Graph.topologicalSort 448 | |> expectTopologicalOrderingOf dressUp 449 | , test "heightLevels" <| 450 | \() -> 451 | case Graph.checkAcyclic dressUp of 452 | Err e -> 453 | Expect.fail 454 | ("dressUp should be acylic, but returned edge " ++ Debug.toString e) 455 | 456 | Ok acyclic -> 457 | acyclic 458 | |> Graph.heightLevels 459 | |> List.concat 460 | |> expectTopologicalOrderingOf dressUp 461 | ] 462 | 463 | bfsTests = 464 | describe "BFS" 465 | [ test "breadth-first node order" <| 466 | \() -> 467 | Expect.equal 468 | [ 0, 3, 1, 2, 6, 8, 4, 5, 7 ] 469 | (dressUp 470 | |> Graph.bfs (Graph.ignorePath (::)) [] 471 | |> List.map (.node >> .id) 472 | |> List.reverse 473 | ) 474 | ] 475 | 476 | graphWithLoop = 477 | Graph.fromNodeLabelsAndEdgePairs [ 0 ] [ ( 0, 0 ) ] 478 | 479 | sccTests = 480 | let 481 | result = 482 | Graph.stronglyConnectedComponents connectedComponents 483 | 484 | sg nodeIds = 485 | connectedComponents 486 | |> Graph.inducedSubgraph nodeIds 487 | |> Graph.toString (Just << String.fromChar) (always <| Just "") 488 | in 489 | describe "Strongly connected components" 490 | [ test "The input graph was acyclic" <| 491 | \() -> 492 | Expect.err 493 | result 494 | , test "The expected SCCs in order" <| 495 | \() -> 496 | Expect.equal 497 | [ sg [ 0, 1, 4 ] -- "abe" 498 | , sg [ 2, 3 ] -- "cd" 499 | , sg [ 5, 6 ] -- "ef" 500 | , sg [ 7 ] -- "h" 501 | ] 502 | (case result of 503 | Err components -> 504 | List.map (Graph.toString (Just << String.fromChar) (always <| Just "")) components 505 | 506 | Ok _ -> 507 | [] 508 | -- should never happen oO 509 | ) 510 | , test "dressUp is acyclic" <| 511 | \() -> 512 | Expect.ok 513 | (Graph.stronglyConnectedComponents dressUp) 514 | , test "The input graph has loops" <| 515 | \() -> 516 | Expect.err 517 | (Graph.stronglyConnectedComponents graphWithLoop) 518 | ] 519 | 520 | dfsTests = 521 | describe "DFS traversal" 522 | [ test "depth-first node order on discovery" <| 523 | \() -> 524 | Expect.equal 525 | [ 0, 3, 1, 2, 6, 8, 4, 5, 7 ] 526 | (dressUp 527 | |> Graph.dfs (Graph.onDiscovery (::)) [] 528 | |> List.map (.node >> .id) 529 | |> List.reverse 530 | ) 531 | , test "depth-first node order on finish" <| 532 | \() -> 533 | Expect.equal 534 | [ 3, 0, 8, 6, 2, 1, 4, 7, 5 ] 535 | (dressUp 536 | |> Graph.dfs (Graph.onFinish (::)) [] 537 | |> List.map (.node >> .id) 538 | |> List.reverse 539 | ) 540 | , test "access to incoming context" <| 541 | \() -> 542 | let 543 | incoming = 544 | Graph.fold 545 | (\ctx acc -> 546 | ( ctx.node.id, IntDict.keys ctx.incoming ) 547 | :: acc 548 | ) 549 | [] 550 | dressUp 551 | |> List.sortBy Tuple.first 552 | in 553 | Expect.equal 554 | incoming 555 | (dressUp 556 | |> Graph.dfs (Graph.onDiscovery (::)) [] 557 | |> List.map 558 | (\ctx -> 559 | ( ctx.node.id, IntDict.keys ctx.incoming ) 560 | ) 561 | |> List.sortBy Tuple.first 562 | ) 563 | , test "access to outgoing context" <| 564 | \() -> 565 | let 566 | outgoing = 567 | Graph.fold 568 | (\ctx acc -> 569 | ( ctx.node.id, IntDict.keys ctx.outgoing ) 570 | :: acc 571 | ) 572 | [] 573 | dressUp 574 | |> List.sortBy Tuple.first 575 | in 576 | Expect.equal 577 | outgoing 578 | (dressUp 579 | |> Graph.dfs (Graph.onDiscovery (::)) [] 580 | |> List.map 581 | (\ctx -> 582 | ( ctx.node.id, IntDict.keys ctx.outgoing ) 583 | ) 584 | |> List.sortBy Tuple.first 585 | ) 586 | ] 587 | 588 | unitTests = 589 | describe "unit tests" 590 | [ emptyTests 591 | , memberTests 592 | , getTests 593 | , nodeIdRangeTests 594 | , listRepTests 595 | , insertTests 596 | , removeTests 597 | , updateTests 598 | , inducedSubgraphTests 599 | , fromNodesAndEdgesTests 600 | , foldTests 601 | , mapTests 602 | , toStringTests 603 | , graphOpsTests 604 | , checkAcyclicTests 605 | , forgetAcyclicTests 606 | , topologicalSortTests 607 | , bfsTests 608 | , sccTests 609 | , dfsTests 610 | ] 611 | 612 | examples = 613 | describe "examples" 614 | [ test "README - iWantToWearShoes" <| 615 | \() -> 616 | Expect.equal 617 | [ "Pants", "Undershorts", "Socks", "Shoes" ] 618 | iWantToWearShoes 619 | , test "insert" <| 620 | \() -> 621 | Expect.equal True insertExample 622 | |> Expect.onFail "Graph size wasn't 2" 623 | , test "fold" <| 624 | \() -> 625 | Expect.equal True foldExample 626 | |> Expect.onFail "The graph had a loop." 627 | , test "mapContexts" <| 628 | \() -> 629 | Expect.equal True mapContextsExample 630 | |> Expect.onFail 631 | "Mapped edge flip should've reversed edges" 632 | , test "symmetricClosureExample" <| 633 | \() -> 634 | Expect.equal True symmetricClosureExample 635 | |> Expect.onFail 636 | "Symmetric closure should only contain undirected edges" 637 | ] 638 | in 639 | describe "The Graph module" 640 | [ unitTests 641 | , examples 642 | ] 643 | 644 | 645 | 646 | -- EXAMPLE SECTION 647 | -- The code of the more complex examples is exercised here 648 | -- This is from the README 649 | 650 | 651 | iWantToWearShoes : List String 652 | iWantToWearShoes = 653 | Graph.guidedDfs 654 | Graph.alongIncomingEdges 655 | -- which edges to follow 656 | (Graph.onDiscovery 657 | (\ctx list -> 658 | -- append node labels on finish 659 | ctx.node.label :: list 660 | ) 661 | ) 662 | [ 3 663 | 664 | {- "Shoes" NodeId -} 665 | ] 666 | -- start with the node labelled "Shoes" 667 | [] 668 | -- accumulate starting with the empty list 669 | dressUp 670 | -- traverse our dressUp graph from above 671 | |> Tuple.first 672 | 673 | 674 | 675 | -- ignores the untraversed rest of the graph 676 | 677 | 678 | insertExample : Bool 679 | insertExample = 680 | let 681 | graph1 = 682 | Graph.fromNodesAndEdges [ Node 1 "1" ] [] 683 | 684 | newNode = 685 | { node = Node 2 "2" 686 | , incoming = IntDict.singleton 1 () -- so there will be an edge from 1 to 2 687 | , outgoing = IntDict.empty 688 | } 689 | 690 | graph2 = 691 | Graph.insert newNode graph1 692 | in 693 | Graph.size graph2 == 2 694 | 695 | 696 | foldExample : Bool 697 | foldExample = 698 | let 699 | hasLoop ctx = 700 | IntDict.member ctx.node.id ctx.incoming 701 | 702 | graph = 703 | Graph.fromNodesAndEdges [ Node 1 "1", Node 2 "2" ] [ Edge 1 2 "->" ] 704 | 705 | -- The graph should not have any loop. 706 | in 707 | Graph.fold (\ctx acc -> acc || hasLoop ctx) False graph == False 708 | 709 | 710 | mapContextsExample : Bool 711 | mapContextsExample = 712 | let 713 | flipEdges ctx = 714 | { ctx | incoming = ctx.outgoing, outgoing = ctx.incoming } 715 | 716 | graph = 717 | Graph.fromNodesAndEdges [ Node 1 "1", Node 2 "2" ] [ Edge 1 2 "->" ] 718 | in 719 | Graph.reverseEdges graph == Graph.mapContexts flipEdges graph 720 | 721 | 722 | symmetricClosureExample : Bool 723 | symmetricClosureExample = 724 | let 725 | graph = 726 | Graph.fromNodesAndEdges [ Node 1 "1", Node 2 "2" ] [ Edge 1 2 "->" ] 727 | 728 | onlyUndirectedEdges ctx = 729 | ctx.incoming == ctx.outgoing 730 | 731 | merger from to outgoingLabel incomingLabel = 732 | outgoingLabel 733 | 734 | -- quite arbitrary, will not be called for the above graph 735 | in 736 | Graph.fold 737 | (\ctx acc -> acc && onlyUndirectedEdges ctx) 738 | True 739 | (Graph.symmetricClosure merger graph) 740 | == True 741 | 742 | 743 | 744 | -- Just let it compile 745 | 746 | 747 | onDiscoveryExample : () 748 | onDiscoveryExample = 749 | let 750 | dfsPostOrder : Graph n e -> List (NodeContext n e) 751 | dfsPostOrder graph = 752 | Graph.dfs (Graph.onDiscovery (::)) [] graph 753 | in 754 | dfsPostOrder Graph.empty |> (\_ -> ()) 755 | 756 | 757 | 758 | -- Just let it compile 759 | 760 | 761 | onFinishExample : () 762 | onFinishExample = 763 | let 764 | dfsPreOrder : Graph n e -> List (NodeContext n e) 765 | dfsPreOrder graph = 766 | Graph.dfs (Graph.onFinish (::)) [] graph 767 | in 768 | dfsPreOrder Graph.empty |> (\_ -> ()) 769 | 770 | 771 | 772 | -- Just let it compile 773 | 774 | 775 | ignorePathExample : () 776 | ignorePathExample = 777 | let 778 | bfsLevelOrder : Graph n e -> List (NodeContext n e) 779 | bfsLevelOrder graph = 780 | graph 781 | |> Graph.bfs (Graph.ignorePath (::)) [] 782 | |> List.reverse 783 | in 784 | bfsLevelOrder Graph.empty |> (\_ -> ()) 785 | -------------------------------------------------------------------------------- /src/Graph.elm: -------------------------------------------------------------------------------- 1 | module Graph exposing 2 | ( NodeId, Node, Edge, Adjacency, NodeContext, Graph 3 | , empty, update, insert, remove, inducedSubgraph 4 | , isEmpty, size, member, get, nodeIdRange 5 | , nodeIds, nodes, edges, fromNodesAndEdges, fromNodeLabelsAndEdgePairs 6 | , fold, mapContexts, mapNodes, mapEdges, reverseEdges, symmetricClosure 7 | , AcyclicGraph, checkAcyclic, forgetAcyclic 8 | , NeighborSelector, alongOutgoingEdges, alongIncomingEdges, SimpleNodeVisitor 9 | , DfsNodeVisitor, onDiscovery, onFinish, dfs, dfsTree, dfsForest, guidedDfs 10 | , BfsNodeVisitor, ignorePath, bfs, guidedBfs 11 | , topologicalSort, heightLevels 12 | , stronglyConnectedComponents 13 | , toString 14 | ) 15 | 16 | {-| This module contains the primitives to build, update and traverse graphs. 17 | If you find that this module is hard to use or the documentation 18 | is insufficient, consider opening an issue for that (and possibly even a 19 | pull request :)). 20 | 21 | Internally, we use the `elm-intdict` package for efficient dynamic graph 22 | representation. 23 | 24 | 25 | # Data 26 | 27 | @docs NodeId, Node, Edge, Adjacency, NodeContext, Graph 28 | 29 | 30 | # Building 31 | 32 | @docs empty, update, insert, remove, inducedSubgraph 33 | 34 | 35 | # Query 36 | 37 | @docs isEmpty, size, member, get, nodeIdRange 38 | 39 | 40 | # List representations 41 | 42 | @docs nodeIds, nodes, edges, fromNodesAndEdges, fromNodeLabelsAndEdgePairs 43 | 44 | 45 | # Transforms 46 | 47 | @docs fold, mapContexts, mapNodes, mapEdges, reverseEdges, symmetricClosure 48 | 49 | 50 | # Characterization 51 | 52 | @docs AcyclicGraph, checkAcyclic, forgetAcyclic 53 | 54 | 55 | # Traversals 56 | 57 | 58 | ## Neighbor selectors and node visitors 59 | 60 | @docs NeighborSelector, alongOutgoingEdges, alongIncomingEdges, SimpleNodeVisitor 61 | 62 | 63 | ## Depth-first 64 | 65 | @docs DfsNodeVisitor, onDiscovery, onFinish, dfs, dfsTree, dfsForest, guidedDfs 66 | 67 | 68 | ## Breadth-first 69 | 70 | @docs BfsNodeVisitor, ignorePath, bfs, guidedBfs 71 | 72 | 73 | # Topological Sort 74 | 75 | @docs topologicalSort, heightLevels 76 | 77 | 78 | # Strongly Connected Components 79 | 80 | @docs stronglyConnectedComponents 81 | 82 | 83 | # String representation 84 | 85 | @docs toString 86 | 87 | -} 88 | 89 | import Fifo 90 | import Graph.Tree as Tree exposing (Forest, Tree) 91 | import IntDict exposing (IntDict) 92 | import Maybe exposing (Maybe) 93 | import Set exposing (Set) 94 | 95 | 96 | {-| The type used for identifying nodes, an integer. 97 | -} 98 | type alias NodeId = 99 | Int 100 | 101 | 102 | {-| The type representing a node: An identifier with 103 | a label. 104 | -} 105 | type alias Node n = 106 | { id : NodeId 107 | , label : n 108 | } 109 | 110 | 111 | {-| Represents a directd edge in the graph. In addition 112 | to start and end node identifiers, a label value can 113 | be attached to an edge. 114 | -} 115 | type alias Edge e = 116 | { from : NodeId 117 | , to : NodeId 118 | , label : e 119 | } 120 | 121 | 122 | {-| Adjacency is represented as an ordered dictionary 123 | rather than as an ordered list. This enables more dynamic 124 | graphs with efficient edge removal and insertion on the run. 125 | -} 126 | type alias Adjacency e = 127 | IntDict e 128 | 129 | 130 | {-| Represents a node with its incoming and outgoing edges 131 | (predecessors and successors). 132 | -} 133 | type alias NodeContext n e = 134 | { node : Node n 135 | , incoming : Adjacency e 136 | , outgoing : Adjacency e 137 | } 138 | 139 | 140 | 141 | -- We will only have the Patricia trie based DynGraph implementation for simplicity. 142 | -- Also, there is no real practical reason to separate that or to allow other implementations 143 | -- which would justify the complexity. 144 | 145 | 146 | type alias GraphRep n e = 147 | IntDict (NodeContext n e) 148 | 149 | 150 | {-| The central graph type. It is parameterized both over the node label type `n` 151 | and the edge label type `e`. 152 | 153 | One can build such a graph with the primitives under _Build_. Most of the time 154 | `fromNodesAndEdges` works fairly well. 155 | 156 | For simplicity, this library just uses a patricia trie based graph representation, which means 157 | it is just an efficient version of `Dict NodeId (NodeContext n e)`. This allows efficient insertion and 158 | removal of nodes of the graph after building. 159 | 160 | -} 161 | type Graph n e 162 | = Graph (GraphRep n e) 163 | 164 | 165 | unGraph : Graph n e -> GraphRep n e 166 | unGraph graph = 167 | case graph of 168 | Graph rep -> 169 | rep 170 | 171 | 172 | 173 | {- BUILD -} 174 | 175 | 176 | {-| An empty graph. 177 | 178 | size empty == 0 179 | 180 | -} 181 | empty : Graph n e 182 | empty = 183 | Graph IntDict.empty 184 | 185 | 186 | type EdgeUpdate e 187 | = Insert e 188 | | Remove e 189 | 190 | 191 | type alias EdgeDiff e = 192 | { incoming : IntDict (EdgeUpdate e) 193 | , outgoing : IntDict (EdgeUpdate e) 194 | } 195 | 196 | 197 | emptyDiff : EdgeDiff e 198 | emptyDiff = 199 | { incoming = IntDict.empty 200 | , outgoing = IntDict.empty 201 | } 202 | 203 | 204 | computeEdgeDiff : Maybe (NodeContext n e) -> Maybe (NodeContext n e) -> EdgeDiff e 205 | computeEdgeDiff old new = 206 | let 207 | collectUpdates edgeUpdate updatedId label = 208 | let 209 | replaceUpdate old_ = 210 | case ( old_, edgeUpdate label ) of 211 | ( Just (Remove oldLbl), Insert newLbl ) -> 212 | if oldLbl == newLbl then 213 | Nothing 214 | 215 | else 216 | Just (Insert newLbl) 217 | 218 | ( Just (Remove _), Remove _ ) -> 219 | crashHack "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!" 220 | 221 | ( Just (Insert _), _ ) -> 222 | crashHack "Graph.computeEdgeDiff: Collected inserts before removals. This is an error in the implementation of Graph and you should file a bug report!" 223 | 224 | ( Nothing, eu ) -> 225 | Just eu 226 | in 227 | IntDict.update updatedId replaceUpdate 228 | 229 | collect edgeUpdate adj updates = 230 | IntDict.foldl (collectUpdates edgeUpdate) updates adj 231 | in 232 | case ( old, new ) of 233 | ( Nothing, Nothing ) -> 234 | emptyDiff 235 | 236 | ( Just rem, Nothing ) -> 237 | { outgoing = IntDict.empty |> collect Remove rem.incoming 238 | , incoming = IntDict.empty |> collect Remove rem.outgoing 239 | } 240 | 241 | ( Nothing, Just ins ) -> 242 | { outgoing = IntDict.empty |> collect Insert ins.incoming 243 | , incoming = IntDict.empty |> collect Insert ins.outgoing 244 | } 245 | 246 | ( Just rem, Just ins ) -> 247 | if rem == ins then 248 | emptyDiff 249 | 250 | else 251 | { outgoing = IntDict.empty |> collect Remove rem.incoming |> collect Insert ins.incoming 252 | , incoming = IntDict.empty |> collect Remove rem.outgoing |> collect Insert ins.outgoing 253 | } 254 | 255 | 256 | 257 | -- applies an EdgeDiff to the graphRep, where nodeId is adjacent 258 | -- to all touched edges. incoming and outgoing is wrt. to the node set (e.g. 259 | -- flipped wrt. nodeId). This is the most critical function, as it can mess up 260 | -- the internal invariants of the graph. 261 | 262 | 263 | applyEdgeDiff : NodeId -> EdgeDiff e -> GraphRep n e -> GraphRep n e 264 | applyEdgeDiff nodeId diff graphRep = 265 | let 266 | flippedFoldl f dict acc = 267 | IntDict.foldl f acc dict 268 | 269 | edgeUpdateToMaybe edgeUpdate = 270 | case edgeUpdate of 271 | Insert lbl -> 272 | Just lbl 273 | 274 | Remove _ -> 275 | Nothing 276 | 277 | updateAdjacency updateEdge updatedId edgeUpdate = 278 | let 279 | updateLbl = 280 | updateEdge (always (edgeUpdateToMaybe edgeUpdate)) 281 | in 282 | IntDict.update updatedId (Maybe.map updateLbl) 283 | 284 | -- ignores edges to nodes not in the graph 285 | updateIncomingEdge upd node = 286 | { node | incoming = IntDict.update nodeId upd node.incoming } 287 | 288 | updateOutgoingEdge upd node = 289 | { node | outgoing = IntDict.update nodeId upd node.outgoing } 290 | in 291 | graphRep 292 | |> flippedFoldl (updateAdjacency updateIncomingEdge) diff.incoming 293 | |> flippedFoldl (updateAdjacency updateOutgoingEdge) diff.outgoing 294 | 295 | 296 | {-| Analogous to `Dict.update`, `update nodeId updater graph` will find 297 | the node context of the node with id `nodeId` in `graph`. It will then call `updater` 298 | with `Just` that node context if that node was found and `Nothing` 299 | otherwise. `updater` can then return `Just` an updated node context 300 | (modifying edges is also permitted!) or delete the node by returning 301 | `Nothing`. The updated `graph` is returned. 302 | 303 | This is the most powerful building function since all possible per-node 304 | operations are possible (node removal, insertion and updating of context 305 | properties). 306 | 307 | The other operations can be implemented in terms of `update` like this: 308 | 309 | remove nodeId graph = 310 | update nodeId (always Nothing) graph 311 | 312 | insert nodeContext graph = 313 | update nodeContext.node.id (always (Just nodeContext)) graph 314 | 315 | -} 316 | update : NodeId -> (Maybe (NodeContext n e) -> Maybe (NodeContext n e)) -> Graph n e -> Graph n e 317 | update nodeId updater = 318 | -- This basically wraps updater so that the edges are consistent. 319 | -- This is, it cannot use the lookup focus, because it needs to update other contexts, too. 320 | let 321 | wrappedUpdater rep = 322 | let 323 | old = 324 | IntDict.get nodeId rep 325 | 326 | filterInvalidEdges ctx = 327 | IntDict.filter (\id _ -> id == ctx.node.id || IntDict.member id rep) 328 | 329 | cleanUpEdges ctx = 330 | { ctx 331 | | incoming = filterInvalidEdges ctx ctx.incoming 332 | , outgoing = filterInvalidEdges ctx ctx.outgoing 333 | } 334 | 335 | new = 336 | old 337 | |> updater 338 | |> Maybe.map cleanUpEdges 339 | 340 | diff = 341 | computeEdgeDiff old new 342 | in 343 | rep 344 | |> applyEdgeDiff nodeId diff 345 | |> IntDict.update nodeId (always new) 346 | in 347 | unGraph >> wrappedUpdater >> Graph 348 | 349 | 350 | {-| Analogous to `Dict.insert`, `insert nodeContext graph` inserts a fresh node 351 | with its context (label, id and edges) into `graph`. If there was already a node 352 | with the same id, it will be replaced by the new node context. 353 | 354 | graph1 = fromNodesAndEdges [Node 1 "1"] [] 355 | newNode = 356 | { node = Node 2 "2" 357 | , incoming = IntDict.singleton 1 () -- so there will be an edge from 1 to 2 358 | , outgoing = IntDict.empty 359 | } 360 | graph2 = insert newNode graph1 361 | size graph2 == 2 362 | 363 | It's possible to build up whole graphs this way, but a lot less tedious way would 364 | be simply to use `fromNodesAndEdges`. 365 | 366 | -} 367 | insert : NodeContext n e -> Graph n e -> Graph n e 368 | insert nodeContext graph = 369 | update nodeContext.node.id (always (Just nodeContext)) graph 370 | 371 | 372 | {-| Analogous to `Dict.remove`, `remove nodeId graph` returns a version of `graph` 373 | without a node with id `nodeId`. If there was no node with that id, then remove 374 | is a no-op: 375 | 376 | graph = fromNodesAndEdges [Node 1 "1", Node 2 "2"] [Edge 1 2 ()] 377 | graph == remove 42 graph 378 | graph |> remove 2 |> size == 1 379 | 380 | -} 381 | remove : NodeId -> Graph n e -> Graph n e 382 | remove nodeId graph = 383 | update nodeId (always Nothing) graph 384 | 385 | 386 | {-| The [induced subgraph](http://mathworld.wolfram.com/Edge-InducedSubgraph.html) 387 | of a number of node ids. 388 | -} 389 | inducedSubgraph : List NodeId -> Graph n e -> Graph n e 390 | inducedSubgraph nodeIds_ graph = 391 | let 392 | insertContextById nodeId acc = 393 | case get nodeId graph of 394 | Just ctx -> 395 | insert ctx acc 396 | 397 | Nothing -> 398 | acc 399 | in 400 | List.foldl insertContextById empty nodeIds_ 401 | 402 | 403 | 404 | {- QUERY -} 405 | 406 | 407 | {-| `isEmpty graph` is true if and only if there are no nodes in the graph. 408 | Some properties to reason about in code, which hold for any `graph`: 409 | 410 | isEmpty graph = 411 | graph == empty 412 | isEmpty graph = 413 | size graph == 0 414 | 415 | -} 416 | isEmpty : Graph n e -> Bool 417 | isEmpty graph = 418 | graph == empty 419 | 420 | 421 | {-| `size graph` returns the number of nodes in `graph`. 422 | 423 | size empty == 0 424 | graph = fromNodesAndEdges [Node 1 "1", Node 2 "2"] [] 425 | size graph == 2 426 | 427 | -} 428 | size : Graph n e -> Int 429 | size = 430 | unGraph >> IntDict.size 431 | 432 | 433 | {-| Analogous to `Dict.member`, `member nodeId graph` is true, if and only if 434 | there is a node with id `nodeId` in `graph`. 435 | 436 | graph = fromNodesAndEdges [Node 1 "1", Node 2 "2"] [] 437 | member 42 graph == False 438 | member 1 graph == True 439 | 440 | -} 441 | member : NodeId -> Graph n e -> Bool 442 | member nodeId = 443 | unGraph >> IntDict.member nodeId 444 | 445 | 446 | {-| Analogous to `Dict.get`, `get nodeId graph` returns the `Just` the node 447 | context with id `nodeId` in `graph` if there is one and `Nothing` otherwise. 448 | 449 | graph = fromNodesAndEdges [Node 1 "1", Node 2 "2"] [] 450 | get 42 graph == Nothing 451 | get 1 graph == Just 452 | 453 | -} 454 | get : NodeId -> Graph n e -> Maybe (NodeContext n e) 455 | get nodeId = 456 | unGraph >> IntDict.get nodeId 457 | 458 | 459 | {-| `nodeIdRange graph` returns `Just (minNodeId, maxNodeId)` if `graph` is not empty and `Nothing` 460 | otherwise. 461 | 462 | This is useful for finding unoccupied node ids without trial and error. 463 | 464 | nodeIdRange empty == Nothing 465 | graph = fromNodesAndEdges [Node 1 "1", Node 2 "2"] [] 466 | nodeIdRange graph == Just (1, 2) 467 | 468 | -} 469 | nodeIdRange : Graph n e -> Maybe ( NodeId, NodeId ) 470 | nodeIdRange graph = 471 | IntDict.findMin (unGraph graph) 472 | |> Maybe.andThen 473 | (\( min, _ ) -> 474 | IntDict.findMax (unGraph graph) 475 | |> Maybe.andThen (\( max, _ ) -> Just ( min, max )) 476 | ) 477 | 478 | 479 | 480 | {- LIST REPRESENTATIONS -} 481 | 482 | 483 | {-| `nodes graph` returns a list of all `Node`s (e.g. `id` and `label`) in 484 | `graph`. 485 | 486 | nodes empty == [] 487 | graph = fromNodesAndEdges [Node 1 "1", Node 2 "2"] [] 488 | nodes graph == [Node 1 "1", Node 2 "2"] 489 | 490 | -} 491 | nodes : Graph n e -> List (Node n) 492 | nodes = 493 | unGraph >> IntDict.values >> List.map .node 494 | 495 | 496 | {-| `nodeIds graph` returns a list of all nodes' ids in `graph`. 497 | 498 | nodeIds empty == [] 499 | graph = fromNodesAndEdges [Node 1 "1", Node 2 "2"] [] 500 | nodeIds graph == [1, 2] 501 | 502 | -} 503 | nodeIds : Graph n e -> List NodeId 504 | nodeIds = 505 | unGraph >> IntDict.keys 506 | 507 | 508 | {-| `edges graph` returns a list of all `Edge`s (e.g. a record of `from` and `to` ids 509 | and a `label`) in `graph`. 510 | 511 | edges empty == [] 512 | graph = fromNodesAndEdges [Node 1 "1", Node 2 "2"] [Edge 1 2 "->"] 513 | edges graph == [Edge 1 2 "->"] 514 | 515 | -} 516 | edges : Graph n e -> List (Edge e) 517 | edges graph = 518 | let 519 | flippedFoldl f dict list = 520 | IntDict.foldl f list dict 521 | 522 | -- dict and list flipped, so that we can use pointfree notation 523 | prependEdges node1 ctx = 524 | flippedFoldl (\node2 e -> (::) { to = node2, from = node1, label = e }) ctx.outgoing 525 | in 526 | flippedFoldl prependEdges (unGraph graph) [] 527 | 528 | 529 | {-| `fromNodesAndEdges nodes edges` constructs a graph from the supplied `nodes` 530 | and `edges`. This is the most comfortable way to construct a graph as a whole. 531 | Oftentimes it is even more convenient to use `fromNodeLabelsAndEdgePairs` when 532 | edges are unlabeled anyway and auto incremented node ids are OK. 533 | 534 | The following constructs a graph with 2 nodes with a string label, connected 535 | by an edge labeled "->". 536 | 537 | graph = 538 | fromNodesAndEdges [ Node 1 "1", Node 2 "2" ] [ Edge 1 2 "->" ] 539 | 540 | -} 541 | fromNodesAndEdges : List (Node n) -> List (Edge e) -> Graph n e 542 | fromNodesAndEdges nodes_ edges_ = 543 | let 544 | nodeRep = 545 | List.foldl 546 | (\n -> 547 | IntDict.insert n.id (NodeContext n IntDict.empty IntDict.empty) 548 | ) 549 | IntDict.empty 550 | nodes_ 551 | 552 | addEdge edge rep = 553 | let 554 | updateOutgoing ctx = 555 | { ctx | outgoing = IntDict.insert edge.to edge.label ctx.outgoing } 556 | 557 | updateIncoming ctx = 558 | { ctx | incoming = IntDict.insert edge.from edge.label ctx.incoming } 559 | in 560 | rep 561 | |> IntDict.update edge.from (Maybe.map updateOutgoing) 562 | |> IntDict.update edge.to (Maybe.map updateIncoming) 563 | 564 | addEdgeIfValid edge rep = 565 | if IntDict.member edge.from rep && IntDict.member edge.to rep then 566 | addEdge edge rep 567 | 568 | else 569 | rep 570 | in 571 | Graph (List.foldl addEdgeIfValid nodeRep edges_) 572 | 573 | 574 | {-| A more convenient version of `fromNodesAndEdges`, when edges are unlabeled 575 | and there are no special requirements on node ids. 576 | 577 | `fromNodeLabelsAndEdgePairs labels edges` implicitly assigns node ids according 578 | to the label's index in `labels` and the list of edge pairs is converted to 579 | unlabeled `Edge`s. 580 | 581 | graph = 582 | fromNodeLabelsAndEdgePairs [ 'a', 'b' ] [ ( 0, 1 ) ] 583 | 584 | -} 585 | fromNodeLabelsAndEdgePairs : List n -> List ( NodeId, NodeId ) -> Graph n () 586 | fromNodeLabelsAndEdgePairs labels edgePairs = 587 | let 588 | nodes_ = 589 | labels 590 | |> List.foldl 591 | (\lbl ( id, nodes__ ) -> ( id + 1, Node id lbl :: nodes__ )) 592 | ( 0, [] ) 593 | |> Tuple.second 594 | 595 | edges_ = 596 | List.map (\( from, to ) -> Edge from to ()) edgePairs 597 | in 598 | fromNodesAndEdges nodes_ edges_ 599 | 600 | 601 | 602 | {- TRANSFORMS -} 603 | 604 | 605 | {-| A fold over all node contexts. The accumulated value is computed lazily, 606 | so that the fold can exit early when the suspended accumulator is not forced. 607 | 608 | hasLoop ctx = IntDict.member ctx.node.id ctx.incoming 609 | graph = fromNodesAndEdges [Node 1 "1", Node 2 "2"] [Edge 1 2 "->"] 610 | -- The graph should not have any loop. 611 | fold (\ctx acc -> acc || hasLoop ctx) False graph == False 612 | 613 | -} 614 | fold : (NodeContext n e -> acc -> acc) -> acc -> Graph n e -> acc 615 | fold f acc graph = 616 | let 617 | go acc1 graph1 = 618 | let 619 | maybeContext = 620 | graph1 621 | |> nodeIdRange 622 | |> Maybe.map Tuple.first 623 | |> Maybe.andThen (\id -> get id graph) 624 | 625 | -- get should never return Nothing 626 | in 627 | case maybeContext of 628 | Just ctx -> 629 | go (f ctx acc1) (remove ctx.node.id graph1) 630 | 631 | Nothing -> 632 | acc1 633 | in 634 | go acc graph 635 | 636 | 637 | {-| Maps each node context to another one. This may change edge and node labels 638 | (including their types), possibly the node ids and also add or remove edges 639 | entirely through modifying the adjacency lists. 640 | 641 | The following is a specification for reverseEdges: 642 | 643 | flipEdges ctx = { ctx | incoming = ctx.outgoing, outgoing = ctx.incoming } 644 | graph = fromNodesAndEdges [Node 1 "1", Node 2 "2"] [Edge 1 2 "->"] 645 | reverseEdges graph == mapContexts flipEdges graph 646 | 647 | Info: Make sure you are applying changes both to `incoming` and `outgoing`. 648 | The `Graph` data structure has inherent redundancy -- every edge in the incoming `IntDict` for a given node shows up again in the outgoing `IntDict` for the node on the other end of the edge and vice-versa. 649 | So you can use mapContexts to modify graphs, but you have to make consistent edge changes between each pair of nodes during the mapping. 650 | Otherwise you'll get order-dependent results. 651 | This may not be the ideal way to "rewire" a graph. 652 | 653 | -} 654 | mapContexts : (NodeContext n1 e1 -> NodeContext n2 e2) -> Graph n1 e1 -> Graph n2 e2 655 | mapContexts f = 656 | fold (\ctx -> insert (f ctx)) empty 657 | 658 | 659 | {-| Maps over node labels, possibly changing their types. Leaves the graph 660 | topology intact. 661 | -} 662 | mapNodes : (n1 -> n2) -> Graph n1 e -> Graph n2 e 663 | mapNodes f = 664 | fold 665 | (\{ node, incoming, outgoing } -> 666 | insert 667 | { incoming = incoming 668 | , outgoing = outgoing 669 | , node = { id = node.id, label = f node.label } 670 | } 671 | ) 672 | empty 673 | 674 | 675 | {-| Maps over edge labels, possibly chaing their types. Leaves the graph 676 | topology intact. 677 | -} 678 | mapEdges : (e1 -> e2) -> Graph n e1 -> Graph n e2 679 | mapEdges f = 680 | fold 681 | (\{ node, incoming, outgoing } -> 682 | insert 683 | { node = node 684 | , outgoing = IntDict.map (\_ e -> f e) outgoing 685 | , incoming = IntDict.map (\_ e -> f e) incoming 686 | } 687 | ) 688 | empty 689 | 690 | 691 | 692 | {- CHARACTERIZATION -} 693 | 694 | 695 | {-| `AcyclicGraph` wraps a `Graph` and witnesses the fact that 696 | it is acyclic. 697 | 698 | This can be passed on to functions that only work on acyclic graphs, 699 | like `topologicalSort` and `heightLevels`. 700 | 701 | -} 702 | type AcyclicGraph n e 703 | = AcyclicGraph (Graph n e) (List NodeId) 704 | 705 | 706 | 707 | {- This is a **really** ugly hack since Elm 0.19 doesn't allow `Debug.crash` any more. 708 | Hopefully this will never get executed, but if it does, it will make your browser 709 | hang (or hopefully give a stack overflow error). 710 | 711 | The only justification for this is that it *should* never get called, and there are 712 | no sensible default cases if we do get there. 713 | -} 714 | 715 | 716 | crashHack : String -> a 717 | crashHack msg = 718 | crashHack msg 719 | 720 | 721 | unsafeGet : String -> NodeId -> Graph n e -> NodeContext n e 722 | unsafeGet msg id graph = 723 | case get id graph of 724 | Nothing -> 725 | crashHack msg 726 | 727 | Just ctx -> 728 | ctx 729 | 730 | 731 | checkForBackEdges : List NodeId -> Graph n e -> Result (Edge e) (AcyclicGraph n e) 732 | checkForBackEdges ordering graph = 733 | let 734 | check id ( backSet, _ ) = 735 | let 736 | backSetWithId = 737 | IntDict.insert id () backSet 738 | 739 | error = 740 | "Graph.checkForBackEdges: `ordering` didn't contain `id`" 741 | 742 | ctx = 743 | unsafeGet error id graph 744 | 745 | backEdges = 746 | IntDict.intersect ctx.outgoing backSetWithId 747 | in 748 | case IntDict.findMin backEdges of 749 | Nothing -> 750 | Ok ( backSetWithId, () ) 751 | 752 | Just ( to, label ) -> 753 | Err (Edge id to label) 754 | 755 | success _ = 756 | AcyclicGraph graph ordering 757 | in 758 | ordering 759 | |> List.foldl 760 | (\id res -> res |> Result.andThen (check id)) 761 | (Ok ( IntDict.empty, () )) 762 | |> Result.map success 763 | 764 | 765 | {-| `checkAcyclic graph` checks `graph` for cycles. 766 | 767 | If there are any cycles, this will return `Err edge`, 768 | where `edge` is an `Edge` that is part of a cycle. 769 | If there aren't any cycles, this will return `Ok acyclic`, where 770 | `acyclic` is an `AcyclicGraph` that witnesses this fact. 771 | 772 | -} 773 | checkAcyclic : Graph n e -> Result (Edge e) (AcyclicGraph n e) 774 | checkAcyclic graph = 775 | let 776 | reversePostOrder = 777 | dfs (onFinish (.node >> .id >> (::))) [] graph 778 | in 779 | checkForBackEdges reversePostOrder graph 780 | 781 | 782 | {-| `forgetAcyclic acyclic` unwraps `AcyclicGraph` `acyclic` 783 | into its corresponding regular `Graph`. 784 | -} 785 | forgetAcyclic : AcyclicGraph n e -> Graph n e 786 | forgetAcyclic (AcyclicGraph graph _) = 787 | graph 788 | 789 | 790 | 791 | {- GRAPH OPS -} 792 | 793 | 794 | {-| `symmetricClosure edgeMerger graph` is the 795 | [symmetric closure](https://en.wikipedia.org/wiki/Symmetric_closure) of `graph`, 796 | e.g. the undirected equivalent, where for every edge in `graph` there is also 797 | a corresponding reverse edge. This implies that `ctx.incoming` == `ctx.outgoing` 798 | for each node context `ctx`. 799 | 800 | `edgeMerger` resolves conflicts for when there are already edges in both 801 | directions, e.g. the graph isn't truly directed. It is guaranteed that 802 | `edgeMerger` will only be called with the smaller node id passed in first 803 | to enforce consitency of merging decisions. 804 | 805 | graph = fromNodesAndEdges [Node 1 "1", Node 2 "2"] [Edge 1 2 "->"] 806 | onlyUndirectedEdges ctx = 807 | ctx.incoming == ctx.outgoing 808 | merger from to outgoingLabel incomingLabel = 809 | outgoingLabel -- quite arbitrary, will not be called for the above graph 810 | fold 811 | (\ctx acc -> acc && onlyUndirectedEdges ctx) 812 | True 813 | (symmetricClosure merger graph) 814 | == True 815 | 816 | -} 817 | symmetricClosure : (NodeId -> NodeId -> e -> e -> e) -> Graph n e -> Graph n e 818 | symmetricClosure edgeMerger = 819 | -- We could use mapContexts, but this will be more efficient. 820 | let 821 | orderedEdgeMerger from to outgoing incoming = 822 | if from <= to then 823 | edgeMerger from to outgoing incoming 824 | 825 | else 826 | edgeMerger to from incoming outgoing 827 | 828 | updateContext nodeId ctx = 829 | let 830 | edges_ = 831 | IntDict.uniteWith (orderedEdgeMerger nodeId) ctx.outgoing ctx.incoming 832 | in 833 | { ctx | outgoing = edges_, incoming = edges_ } 834 | in 835 | unGraph >> IntDict.map updateContext >> Graph 836 | 837 | 838 | {-| Reverses the direction of every edge in the graph. 839 | -} 840 | reverseEdges : Graph n e -> Graph n e 841 | reverseEdges = 842 | let 843 | updateContext _ ctx = 844 | { ctx 845 | | outgoing = ctx.incoming 846 | , incoming = ctx.outgoing 847 | } 848 | in 849 | unGraph >> IntDict.map updateContext >> Graph 850 | 851 | 852 | 853 | {- TRAVERSALS -} 854 | 855 | 856 | {-| Selects the next neighbors for the currently visited node in the traversal. 857 | -} 858 | type alias NeighborSelector n e = 859 | NodeContext n e 860 | -> List NodeId 861 | 862 | 863 | {-| A good default for selecting neighbors is to just go along outgoing edges: 864 | 865 | alongOutgoingEdges ctx = 866 | IntDict.keys ctx.outgoing 867 | 868 | `dfs`/`bfs` use this as their selecting strategy. 869 | 870 | -} 871 | alongOutgoingEdges : NeighborSelector n e 872 | alongOutgoingEdges ctx = 873 | IntDict.keys ctx.outgoing 874 | 875 | 876 | {-| A less common way for selecting neighbors is to follow incoming edges: 877 | 878 | alongIncomingEdges ctx = 879 | IntDict.keys ctx.incoming 880 | 881 | -} 882 | alongIncomingEdges : NeighborSelector n e 883 | alongIncomingEdges ctx = 884 | IntDict.keys ctx.incoming 885 | 886 | 887 | {-| A generic node visitor just like that in the ordinary `fold` function. 888 | There are combinators that make these usable for both depth-first traversal 889 | (`onDiscovery`, `onFinish`) and breadth-first traversal (`ignorePath`). 890 | -} 891 | type alias SimpleNodeVisitor n e acc = 892 | NodeContext n e 893 | -> acc 894 | -> acc 895 | 896 | 897 | 898 | {- DFS -} 899 | 900 | 901 | {-| A node visitor specialized for depth-first traversal. Along with the node 902 | context of the currently visited node, the current accumulated value is passed. 903 | The visitor then has the chance to both modify the value at discovery of the 904 | node through the first return value and also provide a finishing 905 | transformation which is called with the value after all children were processed 906 | and the node is about to be finished. 907 | 908 | In the cases where you don't need access to the value both at dicovery and at 909 | finish, look into `onDiscovery` and `onFinish`. 910 | 911 | -} 912 | type alias DfsNodeVisitor n e acc = 913 | NodeContext n e 914 | -> acc 915 | -> ( acc, acc -> acc ) 916 | 917 | 918 | {-| Transform a `SimpleNodeVisitor` into an equivalent `DfsNodeVisitor`, which 919 | will be called upon node discovery. This eases providing `DfsNodeVisitor`s in 920 | the default case: 921 | 922 | dfsPreOrder : Graph n e -> List (NodeContext n e) 923 | dfsPreOrder graph = 924 | List.reverse (dfs (onDiscovery (::)) [] graph) 925 | 926 | -} 927 | onDiscovery : SimpleNodeVisitor n e acc -> DfsNodeVisitor n e acc 928 | onDiscovery visitor ctx acc = 929 | ( visitor ctx acc, identity ) 930 | 931 | 932 | {-| Transform a `SimpleNodeVisitor` into an equivalent `DfsNodeVisitor`, which 933 | will be called upon node finish. This eases providing `DfsNodeVisitor`s in 934 | the default case: 935 | 936 | dfsPostOrder : Graph n e -> List (NodeContext n e) 937 | dfsPostOrder graph = 938 | List.reverse (dfs (onFinish (::)) [] graph) 939 | 940 | -} 941 | onFinish : SimpleNodeVisitor n e acc -> DfsNodeVisitor n e acc 942 | onFinish visitor ctx acc = 943 | ( acc, visitor ctx ) 944 | 945 | 946 | {-| The `dfs*` functions are not powerful enough? Go for this beast. 947 | 948 | `guidedDfs selectNeighbors visitNode seeds acc graph` will perform a depth-first 949 | traversal on `graph` starting with a stack of `seeds`. The children of each node 950 | will be selected with `selectNeighbors` (see `NeighborSelector`), the visiting 951 | of nodes is handled by `visitNode` (c.f. `DfsNodeVisitor`), folding `acc` over 952 | the graph. 953 | 954 | When there are not any more nodes to be visited, the function will return the 955 | accumulated value together with a set of ids of the visited nodes. 956 | 957 | dfsPreOrder graph = 958 | -- NodeId 1 is just a wild guess here 959 | guidedDfs alongOutgoingEdges (onDiscovery (::)) [ 1 ] [] graph 960 | 961 | -} 962 | guidedDfs : 963 | NeighborSelector n e 964 | -> DfsNodeVisitor n e acc 965 | -> List NodeId 966 | -> acc 967 | -> Graph n e 968 | -> ( acc, Set NodeId ) 969 | guidedDfs selectNeighbors visitNode startingSeeds startingAcc graph = 970 | let 971 | go : List NodeId -> Set NodeId -> acc -> ( acc, Set NodeId ) 972 | go seeds visited acc = 973 | case seeds of 974 | [] -> 975 | -- We are done with this connected component, so we return acc and the rest of the graph 976 | ( acc, visited ) 977 | 978 | next :: seeds1 -> 979 | if Set.member next visited then 980 | go seeds1 visited acc 981 | 982 | else 983 | case get next graph of 984 | Nothing -> 985 | -- skip `next` if it is not present 986 | go seeds1 visited acc 987 | 988 | Just ctx -> 989 | let 990 | ( accAfterDiscovery, finishNode ) = 991 | visitNode ctx acc 992 | 993 | ( accBeforeFinish, visited1 ) = 994 | go (selectNeighbors ctx) (Set.insert next visited) accAfterDiscovery 995 | 996 | accAfterFinish = 997 | finishNode accBeforeFinish 998 | in 999 | go seeds1 visited1 accAfterFinish 1000 | in 1001 | go startingSeeds Set.empty startingAcc 1002 | 1003 | 1004 | {-| An off-the-shelf depth-first traversal. It will visit all components of the 1005 | graph in no guaranteed order, discovering nodes `alongOutgoingEdges`. 1006 | See the docs of `DfsNodeVisitor` on how to supply such a beast. There are also 1007 | examples on how to use `dfs`. 1008 | -} 1009 | dfs : DfsNodeVisitor n e acc -> acc -> Graph n e -> acc 1010 | dfs visitNode acc graph = 1011 | guidedDfs alongOutgoingEdges visitNode (nodeIds graph) acc graph |> Tuple.first 1012 | 1013 | 1014 | {-| `dfsTree seed graph` computes a depth-first [spanning tree](https://en.wikipedia.org/wiki/Spanning_tree) of the component 1015 | in `graph` starting from `seed` `alongOutgoingEdges`. This function is exemplary for needing to 1016 | utilize the whole power of `DfsNodeVisitor`. 1017 | -} 1018 | dfsTree : NodeId -> Graph n e -> Tree (NodeContext n e) 1019 | dfsTree seed graph = 1020 | case dfsForest [ seed ] graph of 1021 | [] -> 1022 | Tree.empty 1023 | 1024 | [ tree ] -> 1025 | tree 1026 | 1027 | _ -> 1028 | crashHack "dfsTree: There can't be more than one DFS tree. This invariant is violated, please report this bug." 1029 | 1030 | 1031 | {-| `dfsForest seeds graph` computes a depth-first spanning `Forest` of the 1032 | components in `graph` spanned by `seeds` `alongOutgoingEdges`. 1033 | 1034 | A traversal over this forest would be equivalent to a depth-first traversal 1035 | over the original graph. 1036 | 1037 | -} 1038 | dfsForest : List NodeId -> Graph n e -> Forest (NodeContext n e) 1039 | dfsForest seeds graph = 1040 | let 1041 | visitNode ctx trees = 1042 | ( [], \children -> Tree.inner ctx children :: trees ) 1043 | in 1044 | guidedDfs alongOutgoingEdges visitNode seeds [] graph 1045 | |> Tuple.first 1046 | |> List.reverse 1047 | 1048 | 1049 | 1050 | {- BFS -} 1051 | 1052 | 1053 | {-| A specialized node visitor for breadth-first traversal. Compared to a 1054 | `SimpleNodeVisitor`, the path of contexts from the root to the current 1055 | node is passed instead of just the current node's context. Additionally, the 1056 | distance from the root is passed as an `Int` (the root has distance 0 and it 1057 | holds always that `length path == distance - 1`). 1058 | 1059 | If you don't need the additional information, you can turn a `SimpleNodeVisitor` 1060 | into a `BfsNodeVisitor` by calling `ignorePath`. 1061 | 1062 | -} 1063 | type alias BfsNodeVisitor n e acc = 1064 | List (NodeContext n e) 1065 | -> Int 1066 | -> acc 1067 | -> acc 1068 | 1069 | 1070 | {-| Turns a `SimpleNodeVisitor` into a `BfsNodeVisitor` by ignoring the path 1071 | and distance parameters. 1072 | This is useful for when the visitor should be agnostic of the 1073 | traversal (breadth-first or depth-first or even just `fold`). 1074 | 1075 | bfsLevelOrder : List (NodeContext n e) 1076 | bfsLevelOrder graph = 1077 | graph 1078 | |> bfs (ignorePath (::)) [] 1079 | |> List.reverse 1080 | 1081 | -} 1082 | ignorePath : SimpleNodeVisitor n e acc -> BfsNodeVisitor n e acc 1083 | ignorePath visit path _ acc = 1084 | case path of 1085 | [] -> 1086 | crashHack "Graph.ignorePath: No algorithm should ever pass an empty path into this BfsNodeVisitor." 1087 | 1088 | ctx :: _ -> 1089 | visit ctx acc 1090 | 1091 | 1092 | {-| The `bfs` function is not powerful enough? Go for this beast. 1093 | 1094 | `guidedBfs selectNeighbors visitNode seeds acc graph` will perform a breadth-first 1095 | traversal on `graph` starting with a queue of `seeds`. The children of each node 1096 | will be selected with `selectNeighbors` (see `NeighborSelector`), the visiting 1097 | of nodes is handled by `visitNode` (c.f. `BfsNodeVisitor`), folding `acc` over 1098 | the graph. 1099 | 1100 | When there are not any more nodes to be visited, the function will return the 1101 | accumulated value together with the unvisited rest of `graph`. 1102 | 1103 | bfsLevelOrder graph = 1104 | -- NodeId 1 is just a wild guess here 1105 | guidedBfs alongOutgoingEdges (ignorePath (::)) [ 1 ] [] graph 1106 | 1107 | -} 1108 | guidedBfs : 1109 | NeighborSelector n e 1110 | -> BfsNodeVisitor n e acc 1111 | -> List NodeId 1112 | -> acc 1113 | -> Graph n e 1114 | -> ( acc, Graph n e ) 1115 | guidedBfs selectNeighbors visitNode startingSeeds startingAcc startingGraph = 1116 | let 1117 | enqueueMany distance parentPath nodeIds_ queue = 1118 | nodeIds_ 1119 | |> List.map (\id -> ( id, parentPath, distance )) 1120 | |> List.foldl Fifo.insert queue 1121 | 1122 | go seeds acc graph = 1123 | case Fifo.remove seeds of 1124 | ( Nothing, _ ) -> 1125 | -- We are done with this connected component, so we return acc and the rest of the graph 1126 | ( acc, graph ) 1127 | 1128 | ( Just ( next, parentPath, distance ), seeds1 ) -> 1129 | case get next graph of 1130 | -- This can actually happen since we don't filter for already visited nodes. 1131 | -- That would be an opportunity for time-memory-tradeoff. 1132 | -- E.g. Passing along a set of visited nodeIds_. 1133 | Nothing -> 1134 | go seeds1 acc graph 1135 | 1136 | Just ctx -> 1137 | let 1138 | path = 1139 | ctx :: parentPath 1140 | 1141 | accAfterVisit = 1142 | visitNode path distance acc 1143 | 1144 | seeds2 = 1145 | enqueueMany (distance + 1) path (selectNeighbors ctx) seeds1 1146 | in 1147 | go seeds2 accAfterVisit (remove next graph) 1148 | in 1149 | go (enqueueMany 0 [] startingSeeds Fifo.empty) startingAcc startingGraph 1150 | 1151 | 1152 | {-| An off-the-shelf breadth-first traversal. It will visit all components of the 1153 | graph in no guaranteed order, discovering nodes `alongOutgoingEdges`. 1154 | See the docs of `BfsNodeVisitor` on how to supply such a beast. There are also 1155 | examples on how to use `bfs`. 1156 | -} 1157 | bfs : BfsNodeVisitor n e acc -> acc -> Graph n e -> acc 1158 | bfs visitNode acc graph = 1159 | case nodeIdRange graph of 1160 | Nothing -> 1161 | acc 1162 | 1163 | Just ( id, _ ) -> 1164 | let 1165 | ( finalAcc, restgraph1 ) = 1166 | guidedBfs alongOutgoingEdges visitNode [ id ] acc graph 1167 | in 1168 | bfs visitNode finalAcc restgraph1 1169 | 1170 | 1171 | {-| Computes the height function of a given `AcyclicGraph`. This is a more general 1172 | [topological sort](https://en.wikipedia.org/wiki/Topological_sorting), 1173 | where independent nodes are in the same height level (e.g. the same list 1174 | index). A valid topological sort is trivially obtained by flattening the 1175 | result of this function. 1176 | 1177 | The height function is useful for solving the maximal clique problem for 1178 | certain [perfect graphs](https://en.wikipedia.org/wiki/Perfect_graph) 1179 | ([comparability graphs](https://en.wikipedia.org/wiki/Comparability_graph)). 1180 | There is the excellent reference 1181 | [Algorithmic Graph Theory and Perfect Graphs](http://dl.acm.org/citation.cfm?id=984029). 1182 | 1183 | -} 1184 | heightLevels : AcyclicGraph n e -> List (List (NodeContext n e)) 1185 | heightLevels (AcyclicGraph startingGraph _) = 1186 | let 1187 | isSource ctx = 1188 | IntDict.isEmpty ctx.incoming 1189 | 1190 | sources = 1191 | fold 1192 | (\ctx acc -> 1193 | if isSource ctx then 1194 | ctx :: acc 1195 | 1196 | else 1197 | acc 1198 | ) 1199 | [] 1200 | startingGraph 1201 | 1202 | countIndegrees = 1203 | fold 1204 | (\ctx -> 1205 | IntDict.insert 1206 | ctx.node.id 1207 | (IntDict.size ctx.incoming) 1208 | ) 1209 | IntDict.empty 1210 | 1211 | subtract a b = 1212 | b - a 1213 | 1214 | decrementAndNoteSources id _ ( nextLevel, indegrees ) = 1215 | let 1216 | indegreesDec = 1217 | IntDict.update id (Maybe.map (subtract 1)) indegrees 1218 | in 1219 | case IntDict.get id indegreesDec of 1220 | Just 0 -> 1221 | case get id startingGraph of 1222 | Just ctx -> 1223 | ( ctx :: nextLevel, indegreesDec ) 1224 | 1225 | Nothing -> 1226 | crashHack "Graph.heightLevels: Could not get a node of a graph which should be there by invariants. Please file a bug report!" 1227 | 1228 | _ -> 1229 | ( nextLevel, indegreesDec ) 1230 | 1231 | decrementIndegrees source nextLevel indegrees = 1232 | IntDict.foldl decrementAndNoteSources ( nextLevel, indegrees ) source.outgoing 1233 | 1234 | go currentLevel nextLevel indegrees graph = 1235 | case ( currentLevel, nextLevel ) of 1236 | ( [], [] ) -> 1237 | [ [] ] 1238 | 1239 | ( [], _ ) -> 1240 | [] :: go nextLevel [] indegrees graph 1241 | 1242 | ( source :: currentLevel1, _ ) -> 1243 | let 1244 | ( nextLevel1, indegrees1 ) = 1245 | decrementIndegrees source nextLevel indegrees 1246 | in 1247 | case go currentLevel1 nextLevel1 indegrees1 (remove source.node.id graph) of 1248 | [] -> 1249 | crashHack "Graph.heightLevels: Reached a branch which is impossible by invariants. Please file a bug report!" 1250 | 1251 | level :: levels -> 1252 | (source :: level) :: levels 1253 | in 1254 | go sources [] (countIndegrees startingGraph) startingGraph 1255 | 1256 | 1257 | {-| Computes a 1258 | [topological ordering](https://en.wikipedia.org/wiki/Topological_sorting) 1259 | of the given `AcyclicGraph`. 1260 | -} 1261 | topologicalSort : AcyclicGraph n e -> List (NodeContext n e) 1262 | topologicalSort (AcyclicGraph graph ordering) = 1263 | let 1264 | error = 1265 | "Graph.topologicalSort: Invalid `AcyclicGraph`, where the ordering contained nodes not present in the graph" 1266 | in 1267 | List.map (\id -> unsafeGet error id graph) ordering 1268 | 1269 | 1270 | {-| Decomposes a graph into its strongly connected components. 1271 | 1272 | `Ok acyclic` means that the graph was acyclic (so every node in the 1273 | graph forms a single connected component). 1274 | 1275 | `Err components` means there were cycles in the graph. The resulting 1276 | list of `components` is a topological ordering of the _condensation_ (e.g. the 1277 | acyclic component graph) of the input graph. 1278 | 1279 | -} 1280 | stronglyConnectedComponents : Graph n e -> Result (List (Graph n e)) (AcyclicGraph n e) 1281 | stronglyConnectedComponents graph = 1282 | -- Based on Cormen, using 2 DFS 1283 | let 1284 | reversePostOrder = 1285 | dfs (onFinish (.node >> .id >> (::))) [] graph 1286 | in 1287 | checkForBackEdges reversePostOrder graph 1288 | |> Result.mapError 1289 | (\_ -> 1290 | let 1291 | forest = 1292 | dfsForest reversePostOrder (reverseEdges graph) 1293 | in 1294 | List.map (Tree.preOrderList >> List.foldr insert empty >> reverseEdges) forest 1295 | ) 1296 | 1297 | 1298 | 1299 | {- toString -} 1300 | 1301 | 1302 | {-| Returns a string representation of the graph. 1303 | -} 1304 | toString : (n -> Maybe String) -> (e -> Maybe String) -> Graph n e -> String 1305 | toString nodeToString edgeToString graph = 1306 | "Graph [" 1307 | ++ (String.join ", " <| 1308 | List.map 1309 | (\{ id, label } -> 1310 | "Node " 1311 | ++ String.fromInt id 1312 | ++ (case nodeToString label of 1313 | Nothing -> 1314 | "" 1315 | 1316 | Just text -> 1317 | " (" ++ text ++ ")" 1318 | ) 1319 | ) 1320 | <| 1321 | nodes graph 1322 | ) 1323 | ++ "] [" 1324 | ++ (String.join ", " <| 1325 | List.map 1326 | (\{ from, to, label } -> 1327 | "Edge " 1328 | ++ String.fromInt from 1329 | ++ "->" 1330 | ++ String.fromInt to 1331 | ++ (case edgeToString label of 1332 | Nothing -> 1333 | "" 1334 | 1335 | Just text -> 1336 | " (" ++ text ++ ")" 1337 | ) 1338 | ) 1339 | <| 1340 | edges graph 1341 | ) 1342 | ++ "]" 1343 | --------------------------------------------------------------------------------