├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── containers-good-graph.cabal ├── package.yaml ├── src └── Data │ └── Graph │ └── Good.hs ├── stack.yaml ├── stack.yaml.lock └── test └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for containers-good-graph 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Sandy Maguire (c) 2021 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Sandy Maguire nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # containers-good-graph 2 | 3 | ## Dedication 4 | 5 | > That's a real [Parker Square](https://www.youtube.com/watch?v=aOT_bG-vWyg) kind of move. 6 | > 7 | > --Matt Parker 8 | 9 | 10 | ## Overview 11 | 12 | It's just `Data.Graph` from `containers`, except that it isn't *complete ass.* 13 | `Data.Graph.Good` is a drop-in replacement, except that it makes everything 14 | typesafe and means you can stop faffing about with partial maps to and from the 15 | damn integers. 16 | 17 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /containers-good-graph.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.33.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 857114263d69b9e7870870870d1b345ff250004d2e623bff57f203a6a11239f2 8 | 9 | name: containers-good-graph 10 | version: 0.1.0.0 11 | description: Please see the README on GitHub at 12 | homepage: https://github.com/isovector/containers-good-graph#readme 13 | bug-reports: https://github.com/isovector/containers-good-graph/issues 14 | author: Sandy Maguire 15 | maintainer: sandy@sandymaguire.me 16 | copyright: Sandy Maguire 17 | license: BSD3 18 | license-file: LICENSE 19 | build-type: Simple 20 | extra-source-files: 21 | README.md 22 | ChangeLog.md 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/isovector/containers-good-graph 27 | 28 | library 29 | exposed-modules: 30 | Data.Graph.Good 31 | other-modules: 32 | Paths_containers_good_graph 33 | hs-source-dirs: 34 | src 35 | build-depends: 36 | array 37 | , base >=4.7 && <5 38 | , containers 39 | , deepseq 40 | default-language: Haskell2010 41 | 42 | test-suite containers-good-graph-test 43 | type: exitcode-stdio-1.0 44 | main-is: Spec.hs 45 | other-modules: 46 | Paths_containers_good_graph 47 | hs-source-dirs: 48 | test 49 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 50 | build-depends: 51 | array 52 | , base >=4.7 && <5 53 | , containers 54 | , containers-good-graph 55 | , deepseq 56 | default-language: Haskell2010 57 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: containers-good-graph 2 | version: 0.6.4.1 3 | github: "isovector/containers-good-graph" 4 | license: BSD3 5 | author: "Sandy Maguire" 6 | maintainer: "sandy@sandymaguire.me" 7 | copyright: "Sandy Maguire" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | synopsis: "Data.Graph, but it doesn't suck!" 14 | category: Data Structures 15 | 16 | description: Please see the README on GitHub at 17 | 18 | dependencies: 19 | - base >= 4.7 && < 5 20 | - containers 21 | - array 22 | - deepseq 23 | 24 | library: 25 | source-dirs: src 26 | 27 | tests: 28 | containers-good-graph-test: 29 | main: Spec.hs 30 | source-dirs: test 31 | ghc-options: 32 | - -threaded 33 | - -rtsopts 34 | - -with-rtsopts=-N 35 | dependencies: 36 | - containers-good-graph 37 | -------------------------------------------------------------------------------- /src/Data/Graph/Good.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | module Data.Graph.Good 4 | ( Graph 5 | , graphFromEdges 6 | , vertices 7 | , edges 8 | , outdegree 9 | , indegree 10 | , transposeG 11 | , dfs 12 | , dff 13 | , topSort 14 | , reverseTopSort 15 | , components 16 | , scc 17 | , bcc 18 | , reachable 19 | , path 20 | ) where 21 | 22 | import Control.Applicative (empty) 23 | import Control.Arrow ((***)) 24 | import Control.Monad ((<=<)) 25 | import Data.Array (Ix, Array) 26 | import qualified Data.Array as A 27 | import qualified Data.Graph as G 28 | import Data.Maybe (mapMaybe, fromMaybe) 29 | 30 | 31 | data Graph v = Graph 32 | { g_graph :: G.Graph 33 | , g_from_vert :: G.Vertex -> v 34 | , g_to_vert :: v -> Maybe G.Vertex 35 | } 36 | 37 | 38 | graphFromEdges :: Ord v => [(v, [v])] -> Graph v 39 | graphFromEdges vs = 40 | let (g, v_func, l) = G.graphFromEdges $ fmap (\(v, es) -> (v, v, es)) vs 41 | in Graph g (\vert -> let (v, _, _) = v_func vert in v) l 42 | 43 | 44 | vertices :: Graph v -> [v] 45 | vertices g = fromVertices g $ overGraph G.vertices g 46 | 47 | 48 | edges :: Graph v -> [(v, v)] 49 | edges g = fmap (g_from_vert g *** g_from_vert g) $ overGraph G.edges g 50 | 51 | 52 | overGraph :: (G.Graph -> r) -> Graph v -> r 53 | overGraph f = f . g_graph 54 | 55 | 56 | lookupArr :: Ix k => Array k v -> k -> Maybe v 57 | lookupArr arr ix = 58 | let (lo, hi) = A.bounds arr 59 | in case (lo <= ix && ix <= hi) of 60 | True -> Just $ arr A.! ix 61 | False -> Nothing 62 | 63 | 64 | outdegree :: Graph v -> v -> Maybe Int 65 | outdegree g = lookupArr arr <=< g_to_vert g 66 | where 67 | arr = overGraph G.outdegree g 68 | 69 | 70 | indegree :: Graph v -> v -> Maybe Int 71 | indegree g = lookupArr arr <=< g_to_vert g 72 | where 73 | arr = overGraph G.indegree g 74 | 75 | 76 | transposeG :: Graph v -> Graph v 77 | transposeG g = g { g_graph = overGraph G.transposeG g } 78 | 79 | 80 | fromVertices :: Functor f => Graph v -> f G.Vertex -> f v 81 | fromVertices = fmap . g_from_vert 82 | 83 | 84 | dfs :: Graph v -> [v] -> G.Forest v 85 | dfs g vs = 86 | let verts = mapMaybe (g_to_vert g) vs 87 | in fmap (fromVertices g) $ overGraph G.dfs g verts 88 | 89 | 90 | dff :: Graph v -> G.Forest v 91 | dff g = fmap (fromVertices g) $ overGraph G.dff g 92 | 93 | 94 | topSort :: Graph v -> [v] 95 | topSort g = fromVertices g $ overGraph G.topSort g 96 | 97 | 98 | reverseTopSort :: Graph v -> [v] 99 | reverseTopSort = reverse . topSort 100 | 101 | 102 | components :: Graph v -> G.Forest v 103 | components g = fmap (fromVertices g) $ overGraph G.components g 104 | 105 | 106 | scc :: Graph v -> G.Forest v 107 | scc g = fmap (fromVertices g) $ overGraph G.scc g 108 | 109 | 110 | bcc :: Graph v -> G.Forest [v] 111 | bcc g = fmap (fmap $ fromVertices g) $ overGraph G.bcc g 112 | 113 | 114 | reachable :: Graph v -> v -> [v] 115 | reachable g v = case g_to_vert g v of 116 | Nothing -> empty 117 | Just vert -> fromVertices g $ overGraph G.reachable g vert 118 | 119 | 120 | path :: Graph v -> v -> v -> Bool 121 | path g v1 v2 = fromMaybe False $ do 122 | vert1 <- g_to_vert g v1 123 | vert2 <- g_to_vert g v2 124 | pure $ overGraph G.path g vert1 vert2 125 | 126 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-16.31 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # subdirs: 29 | # - auto-update 30 | # - wai 31 | packages: 32 | - . 33 | # Dependency packages to be pulled from upstream that are not in the resolver. 34 | # These entries can reference officially published versions as well as 35 | # forks / in-progress versions pinned to a git hash. For example: 36 | # 37 | # extra-deps: 38 | # - acme-missiles-0.3 39 | # - git: https://github.com/commercialhaskell/stack.git 40 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 41 | # 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=2.3" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 534126 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/31.yaml 11 | sha256: 637fb77049b25560622a224845b7acfe81a09fdb6a96a3c75997a10b651667f6 12 | original: lts-16.31 13 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | --------------------------------------------------------------------------------