packages feed

comfort-graph (empty) → 0.0

raw patch · 7 files changed

+930/−0 lines, 7 filesdep +QuickCheckdep +basedep +containerssetup-changed

Dependencies added: QuickCheck, base, containers, transformers, utility-ht

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Henning Thielemann++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Henning Thielemann nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ comfort-graph.cabal view
@@ -0,0 +1,78 @@+Name:                comfort-graph+Version:             0.0+Synopsis:            Graph structure with type parameters for nodes and edges+Description:+  This graph structure is based on "Data.Map"+  and allows any 'Ord' type for nodes+  and allows directed, undirected and more edge types.+  There is no need to map nodes to integer numbers.+  This makes handling in applications much more comfortable,+  thus the package name.+  .+  Currently the package does not contain any advanced algorithm,+  just the data structure and some manipulation functions.+  .+  The edge type can be freely chosen.+  This allows great flexibility+  but it is a bit more cumbersome to do in Haskell 98.+  Examples of edge types:+  .+  * @DirEdge@: Edges in a directed graph+  .+  * @UndirEdge@: Edges in an undirected graph+  .+  * @EitherEdge@: For graphs containing both directed and undirected edges+  .+  * You may define an edge type with an additional identifier+    in order to support multiple edges between the same pair of nodes.+  .+  * Using type functions on the node type+    you may even define an edge type for nodes from a Cartesian product,+    where only \"horizontal\" and \"vertical\" edges are allowed.+  .+  For examples see the @linear-circuit@ package and its tests.+  The @ResistorCube@ test demonstrates non-integer node types+  and the @Tree@ test demonstrates multigraphs.+  .+  The package is plain Haskell 98.+  .+  Related packages:+  .+  * @fgl@:+      standard package for graph processing with many graph algorithms+      but cumbersome data structure with Int numbered nodes+Homepage:            http://hub.darcs.net/thielema/comfort-graph+License:             BSD3+License-File:        LICENSE+Author:              Henning Thielemann+Maintainer:          haskell@henning-thielemann.de+Category:            Data+Build-Type:          Simple+Cabal-Version:       >=1.10++Source-Repository this+  Tag:         0.0+  Type:        darcs+  Location:    http://hub.darcs.net/thielema/comfort-graph++Source-Repository head+  Type:        darcs+  Location:    http://hub.darcs.net/thielema/comfort-graph++Library+  Exposed-Modules:+    Data.Graph.Comfort+  Other-Modules:+    Data.Graph.Comfort.Map+    Data.Graph.Comfort.TypeConstructor+    -- ToDo: should be replaced by future version of total-map+    Data.Graph.Comfort.TotalMap+  Build-Depends:+    QuickCheck >=2.5 && <3,+    containers >=0.4 && <0.6,+    transformers >=0.4 && <0.5,+    utility-ht >=0.0.10 && <0.1,+    base >=4.5 && <5+  Hs-Source-Dirs:      src+  Default-Language:    Haskell2010+  GHC-Options:         -Wall
+ src/Data/Graph/Comfort.hs view
@@ -0,0 +1,647 @@+module Data.Graph.Comfort (+   -- * types+   Graph,+   LabeledNode,+   LabeledEdge,+   Edge(from, to),+   DirEdge(DirEdge),+   UndirEdge(UndirEdge), undirEdge,+   EitherEdge(EDirEdge,EUndirEdge),++   -- * construction+   empty, fromList, fromMap,++   -- * extract large portions of the graph+   graphMap,+   nodeLabels, nodeSet, nodes, nodeEdges,+   edgeLabels, edgeSet, edges,++   -- * queries+   isEmpty,+   lookupNode, lookupEdge,+   adjacentEdges,+   isLoop,+   pathExists,+   isConsistent,++   -- * manipulate labels+   mapNode, mapNodeWithKey,+   mapEdge, mapEdgeWithKey,+   mapNodeWithInOut, InOut,+   filterEdgeWithKey,+   traverseNode, traverseEdge, traverse,++   -- * combine graphs+   checkedZipWith,+   union,++   -- * manipulate indices+   Reverse,+   reverse,+   reverseEdge,+   mapKeys,+   mapMaybeEdgeKeys,+   mapEdgeKeys,++   -- * insertion and removal+   deleteNode, deleteNodeSet, deleteEdge,+   insertNode, insertEdge, insertEdgeSet,+   ) where++import qualified Data.Graph.Comfort.Map as MapU+import qualified Data.Graph.Comfort.TotalMap as TMap+import qualified Data.Graph.Comfort.TypeConstructor as TC++import Data.Functor.Classes (Eq1(eq1), Ord1(compare1), Show1(showsPrec1))++import qualified Data.Set as Set+import qualified Data.Map as Map+import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import Control.Monad (liftM2)+import Control.Applicative (Applicative, pure, liftA2, liftA3)+import Data.Foldable (Foldable, foldMap)+import Data.Set (Set)+import Data.Map (Map)+import Data.Monoid (Monoid, mempty, mappend)+import Data.Tuple.HT (mapFst, fst3, snd3, thd3, mapFst3, mapThd3)++import qualified Test.QuickCheck as QC++import Prelude hiding (reverse)+++{-+For all 'Graph's the 'isConsistent' predicate must be 'True'.+-}+newtype Graph edge node edgeLabel nodeLabel =+   Graph {+      graphMapWrap ::+         Map node (InOutMap (TC.Wrap edge) node edgeLabel nodeLabel)+   } deriving (Eq, Ord)++instance+   (Edge e, Ord n, Show1 e, Show n, Show el, Show nl) =>+      Show (Graph e n el nl) where+   showsPrec prec g =+      showParen (prec>10) $+         showString "Graph.fromList " .+         shows (Map.toList $ nodeLabels g) .+         showString " " .+         shows (Map.toList $ edgeLabelsWrap g)+++isConsistent :: (Ord n, Eq el) => Graph DirEdge n el nl -> Bool+isConsistent (Graph ns) =+   foldMap fst3 ns == foldMap thd3 ns+   &&+   Set.isSubsetOf+      (foldMap (foldMap (foldMap Set.singleton) . Map.keys . fst3) ns)+      (Map.keysSet ns)+   &&+   (Fold.and $ flip Map.mapWithKey ns $+      \n (ins,_nl,outs) ->+         Fold.all ((n==) . toWrap) (Map.keysSet ins) &&+         Fold.all ((n==) . fromWrap) (Map.keysSet outs))+++type LabeledNode n label = (n, label)+++class (Foldable edge, Ord1 edge) => Edge edge where+   from, to :: edge node -> node++instance Edge DirEdge where+   from (DirEdge x _) = x+   to (DirEdge _ x) = x++instance Edge UndirEdge where+   from (UndirEdge x _) = x+   to (UndirEdge _ x) = x++instance Edge EitherEdge where+   from ee =+      case ee of+         EDirEdge   e -> from e+         EUndirEdge e -> from e+   to ee =+      case ee of+         EDirEdge   e -> to e+         EUndirEdge e -> to e+++{-+class (Edge edge) => ConsEdge edge where+   {- |+   The construction of an edge may fail+   and it is not warranted+   that @x == from (edge x y)@ or @y == to (edge x y)@.+   -}+   edge :: Ord node => node -> node -> Maybe (edge node)++instance ConsEdge DirEdge where+   edge x y = Just $ DirEdge x y++instance ConsEdge UndirEdge where+   edge x y = Just $ undirEdge x y+-}++++type LabeledEdge edge node label = (edge node, label)+++data DirEdge node = DirEdge node node+   deriving (Eq, Ord, Show)++data UndirEdge node = UndirEdge node node+   deriving (Eq, Ord, Show)++undirEdge :: (Ord node) => node -> node -> UndirEdge node+undirEdge x y =+   if x<y+     then UndirEdge x y+     else UndirEdge y x++data+   EitherEdge node =+        EDirEdge (DirEdge node)+      | EUndirEdge (UndirEdge node)+   deriving (Eq, Ord, Show)+++instance Eq1 DirEdge where eq1 = (==)+instance Ord1 DirEdge where compare1 = compare+instance Show1 DirEdge where showsPrec1 = showsPrec++instance Eq1 UndirEdge where eq1 = (==)+instance Ord1 UndirEdge where compare1 = compare+instance Show1 UndirEdge where showsPrec1 = showsPrec++instance Eq1 EitherEdge where eq1 = (==)+instance Ord1 EitherEdge where compare1 = compare+instance Show1 EitherEdge where showsPrec1 = showsPrec+++instance Functor DirEdge where+   fmap f (DirEdge x y) = DirEdge (f x) (f y)++instance Foldable DirEdge where+   foldMap f (DirEdge x y) = mappend (f x) (f y)++instance Foldable UndirEdge where+   foldMap f (UndirEdge x y) = mappend (f x) (f y)++instance Foldable EitherEdge where+   foldMap f ee =+      case ee of+         EDirEdge   e -> foldMap f e+         EUndirEdge e -> foldMap f e++instance (QC.Arbitrary n) => QC.Arbitrary (DirEdge n) where+   arbitrary = liftM2 DirEdge QC.arbitrary QC.arbitrary+   shrink (DirEdge x y) = map (uncurry DirEdge) $ QC.shrink (x,y)++instance (QC.Arbitrary n, Ord n) => QC.Arbitrary (UndirEdge n) where+   arbitrary = liftM2 undirEdge QC.arbitrary QC.arbitrary+   shrink (UndirEdge x y) =+      Set.toList $ Set.fromList $ map (uncurry undirEdge) $ QC.shrink (x,y)+++graphMap ::+   Graph edge node edgeLabel nodeLabel ->+   Map node (InOutMap edge node edgeLabel nodeLabel)+graphMap = fmap unwrapInOut . graphMapWrap++nodes ::+   (Edge edge, Ord node) =>+   Graph edge node edgeLabel nodeLabel ->+   [node]+nodes = Map.keys . graphMapWrap++nodeEdges ::+   (Edge edge, Ord node) =>+   Graph edge node edgeLabel nodeLabel ->+   Map node (Set (edge node), nodeLabel, Set (edge node))+nodeEdges =+   fmap+      (\(ins,n,outs) ->+         (unwrapSet $ Map.keysSet ins, n, unwrapSet $ Map.keysSet outs)) .+   graphMapWrap+++edgeLabels ::+   (Edge edge, Ord node) =>+   Graph edge node edgeLabel nodeLabel ->+   Map (edge node) edgeLabel+edgeLabels = unwrapMap . edgeLabelsWrap++edgeLabelsWrap ::+   (Edge edge, Ord node) =>+   Graph edge node edgeLabel nodeLabel ->+   Map (TC.Wrap edge node) edgeLabel+edgeLabelsWrap = foldMap fst3 . graphMapWrap++edgeSet ::+   (Edge edge, Ord node) =>+   Graph edge node edgeLabel nodeLabel -> Set (edge node)+edgeSet = unwrapSet . foldMap (Map.keysSet . fst3) . graphMapWrap++edges ::+   (Edge edge, Ord node) =>+   Graph edge node edgeLabel nodeLabel -> [edge node]+edges = Map.keys . edgeLabels+++reverse ::+   (Reverse e, Ord n) =>+   Graph e n el nl -> Graph e n el nl+reverse =+   withWrappedGraph $+   fmap+      (\(ins, nl, outs) ->+         (Map.mapKeys reverseEdgeWrap outs,+          nl,+          Map.mapKeys reverseEdgeWrap ins))++reverseEdgeWrap :: Reverse edge => TC.Wrap edge node -> TC.Wrap edge node+reverseEdgeWrap = TC.Wrap . reverseEdge . TC.unwrap+++class Edge edge => Reverse edge where+   reverseEdge :: edge node -> edge node++instance Reverse DirEdge where+   reverseEdge (DirEdge x y) = DirEdge y x+++{- |+The index map must be an injection,+that is, nodes must not collaps.+Also the node and edge index maps must be consistent, i.e.++> from (edgeMap e) == nodeMap (from e)+> to   (edgeMap e) == nodeMap (to   e)++Strictly spoken, we would need the node map only for isolated nodes,+but we use it for all nodes for simplicity.+-}+mapKeys ::+   (Edge edge1, Ord node0, Ord node1) =>+   (node0 -> node1) ->+   (edge0 node0 -> edge1 node1) ->+   Graph edge0 node0 edgeLabel nodeLabel ->+   Graph edge1 node1 edgeLabel nodeLabel+mapKeys f g =+   withWrappedGraph $+   fmap+      (\(ins,nl,outs) ->+         (Map.mapKeys (TC.Wrap . g . TC.unwrap) ins,+          nl,+          Map.mapKeys (TC.Wrap . g . TC.unwrap) outs)) .+   Map.mapKeysWith (error "Graph.mapKeys: node map is not injective") f++empty :: Graph edge node edgeLabel nodeLabel+empty = Graph Map.empty++{- |+The node sets must be disjoint.+-}+union ::+   (Edge edge, Ord node) =>+   Graph edge node edgeLabel nodeLabel ->+   Graph edge node edgeLabel nodeLabel ->+   Graph edge node edgeLabel nodeLabel+union (Graph ns0) (Graph ns1) =+   Graph+      (Map.unionWith (error "Graph.union: node sets overlap") ns0 ns1)++instance+   (Edge edge, Ord node) =>+      Monoid (Graph edge node edgeLabel nodeLabel) where+   mempty = empty+   mappend = union+++{- |+Node and edge sets must be equal.+-}+checkedZipWith ::+   (Edge edge, Ord node) =>+   MapU.Caller ->+   (nodeLabel0 -> nodeLabel1 -> nodeLabel2) ->+   (edgeLabel0 -> edgeLabel1 -> edgeLabel2) ->+   Graph edge node edgeLabel0 nodeLabel0 ->+   Graph edge node edgeLabel1 nodeLabel1 ->+   Graph edge node edgeLabel2 nodeLabel2+checkedZipWith caller f g (Graph ns0) (Graph ns1) =+   Graph $+   MapU.checkedZipWith (caller ++ " node")+      (\(ins0, n0, outs0) (ins1, n1, outs1) ->+         (MapU.checkedZipWith (caller ++ " ins") g ins0 ins1,+          f n0 n1,+          MapU.checkedZipWith (caller ++ " outs") g outs0 outs1))+      ns0 ns1+++nodeLabels :: (Edge e, Ord n) => Graph e n el nl -> Map n nl+nodeLabels = fmap snd3 . graphMapWrap++lookupEdge :: (Edge e, Ord n) => e n -> Graph e n el nl -> Maybe el+lookupEdge e (Graph g) =+   Map.lookup (TC.Wrap e) . thd3 =<< Map.lookup (from e) g++{- |+Alternative implementation for test:+-}+_lookupEdge :: (Edge e, Ord n) => e n -> Graph e n el nl -> Maybe el+_lookupEdge e (Graph g) =+   Map.lookup (TC.Wrap e) . fst3 =<< Map.lookup (to e) g+++isEmpty :: Graph e n el nl -> Bool+isEmpty = Map.null . graphMapWrap++lookupNode :: (Ord n) => n -> Graph e n el nl -> Maybe nl+lookupNode n (Graph g) = fmap snd3 $ Map.lookup n g++_pre, suc ::+   (Edge e, Ord n) =>+   Graph e n el nl -> n -> [n]+_pre g n =+   Set.toList . Set.map fromWrap . Map.keysSet . fst3 .+   Map.findWithDefault (error "pre: unknown node") n . graphMapWrap $ g+suc g n =+   Set.toList . Set.map toWrap . Map.keysSet . thd3 .+   Map.findWithDefault (error "suc: unknown node") n . graphMapWrap $ g++adjacentEdges ::+   (Edge e, Ord n) =>+   Graph e n el nl -> n -> Set (e n)+adjacentEdges g n =+   (\(ins,_nl,outs) ->+      unwrapSet $ Map.keysSet ins `Set.union` Map.keysSet outs) $+   Map.findWithDefault (error "adjacentEdges: unknown node") n $+   graphMapWrap g++{-+In constrast to Map.intersectWith ($), unaffected values are preserved.+-}+applyMap :: (Ord k) => Map k (a -> a) -> Map k a -> Map k a+applyMap f x =+   Map.union (Map.intersectionWith ($) f x) x++{- |+Node to be deleted must be contained in the graph.+-}+deleteNode ::+   (Edge e, Ord n) =>+   n -> Graph e n el nl -> Graph e n el nl+deleteNode n =+   withWrappedGraph $ \ns ->+   case Map.findWithDefault (error "deleteNode: unknown node") n ns of+      (ins, _nl, outs) ->+         applyMap (Map.mapKeys fromWrap $ Map.mapWithKey (\e _ -> mapThd3 $ Map.delete e) ins)  $+         applyMap (Map.mapKeys toWrap   $ Map.mapWithKey (\e _ -> mapFst3 $ Map.delete e) outs) $+         Map.delete n ns++{- |+Could be implemented more efficiently.+-}+deleteNodeSet ::+   (Edge e, Ord n) =>+   Set n -> Graph e n el nl -> Graph e n el nl+deleteNodeSet delNs g = Set.foldl (flip deleteNode) g delNs++deleteEdge ::+   (Edge e, Ord n) =>+   e n -> Graph e n el nl -> Graph e n el nl+deleteEdge e =+   withWrappedGraph $+      Map.adjust (mapThd3 $ Map.delete $ TC.Wrap e) (from e) .+      Map.adjust (mapFst3 $ Map.delete $ TC.Wrap e) (to e)++filterEdgeWithKey ::+   (Edge e, Ord n) =>+   (e n -> el -> Bool) ->+   Graph e n el nl -> Graph e n el nl+filterEdgeWithKey f =+   Graph .+   fmap+      (\(ins, nl, outs) ->+         (Map.filterWithKey (f . TC.unwrap) ins, nl,+          Map.filterWithKey (f . TC.unwrap) outs)) .+   graphMapWrap++{- |+You may only use this for filtering edges+and use more specialised types as a result.+You must not alter source and target nodes of edges.+-}+mapMaybeEdgeKeys ::+   (Edge e1, Ord n) =>+   (e0 n -> Maybe (e1 n)) ->+   Graph e0 n el nl -> Graph e1 n el nl+mapMaybeEdgeKeys f =+   withWrappedGraph $+   fmap+      (\(ins, nl, outs) ->+         (MapU.mapMaybeKeys (fmap TC.Wrap . f . TC.unwrap) ins,+          nl,+          MapU.mapMaybeKeys (fmap TC.Wrap . f . TC.unwrap) outs))++mapEdgeKeys ::+   (Edge e1, Ord n) =>+   (e0 n -> e1 n) ->+   Graph e0 n el nl -> Graph e1 n el nl+mapEdgeKeys f =+   withWrappedGraph $+   fmap+      (\(ins, nl, outs) ->+         (Map.mapKeys (TC.Wrap . f . TC.unwrap) ins,+          nl,+          Map.mapKeys (TC.Wrap . f . TC.unwrap) outs))++{- |+In the current implementation+existing nodes are replaced with new labels+and existing edges are maintained.+However, I think we should better have an extra function for this purpose+and you should not rely on this behavior.+-}+insertNode ::+   (Ord n) => n -> nl -> Graph e n el nl -> Graph e n el nl+insertNode n nl =+   Graph .+   Map.insertWith+      (\_ (ins, _, outs) -> (ins, nl, outs))+      n (Map.empty, nl, Map.empty) .+   graphMapWrap++insertEdge ::+   (Edge e, Ord n) =>+   e n -> el -> Graph e n el nl -> Graph e n el nl+insertEdge e el = insertEdgeSet $ Map.singleton e el++{- |+In the current implementation+existing edges are replaced with new labels.+However, I think we should better have an extra function for this purpose+and you should not rely on this behavior.+-}+insertEdgeSet ::+   (Edge e, Ord n) =>+   Map (e n) el -> Graph e n el nl -> Graph e n el nl+insertEdgeSet es =+   let ess = Map.mapWithKey Map.singleton $ wrapMap es+   in  withWrappedGraph $+       applyMap (fmap (\new -> mapFst3 (Map.union new)) $ Map.mapKeysWith Map.union toWrap   ess) .+       applyMap (fmap (\new -> mapThd3 (Map.union new)) $ Map.mapKeysWith Map.union fromWrap ess)++fromList ::+   (Edge e, Ord n) =>+   [LabeledNode n nl] -> [LabeledEdge e n el] -> Graph e n el nl+fromList ns es =+   fromMapWrap (Map.fromList ns) $ Map.fromList $ map (mapFst TC.Wrap) es++fromMap ::+   (Edge e, Ord n) =>+   Map n nl -> Map (e n) el -> Graph e n el nl+fromMap ns = fromMapWrap ns . wrapMap++fromMapWrap ::+   (Edge e, Ord n) =>+   Map n nl -> Map (TC.Wrap e n) el -> Graph e n el nl+fromMapWrap ns es =+   let ess = Map.mapWithKey Map.singleton es+   in  Graph $+       TMap.intersectionPartialWith (\ins (outs, nl) -> (ins,nl,outs))+          (TMap.cons Map.empty $ Map.mapKeysWith Map.union toWrap   ess) $+       TMap.intersectionPartialWith (,)+          (TMap.cons Map.empty $ Map.mapKeysWith Map.union fromWrap ess) ns+++mapNode :: (nl0 -> nl1) -> Graph e n el nl0 -> Graph e n el nl1+mapNode f =+   Graph . fmap (\(ins,n,outs) -> (ins, f n, outs)) . graphMapWrap++mapNodeWithKey :: (n -> nl0 -> nl1) -> Graph e n el nl0 -> Graph e n el nl1+mapNodeWithKey f =+   Graph .+   Map.mapWithKey (\n (ins,nl,outs) -> (ins, f n nl, outs)) .+   graphMapWrap++mapEdge :: (el0 -> el1) -> Graph e n el0 nl -> Graph e n el1 nl+mapEdge f =+   Graph . fmap (\(ins,n,outs) -> (fmap f ins, n, fmap f outs)) . graphMapWrap++mapEdgeWithKey :: (e n -> el0 -> el1) -> Graph e n el0 nl -> Graph e n el1 nl+mapEdgeWithKey f =+   Graph .+   fmap (\(ins,n,outs) -> (Map.mapWithKey (f . TC.unwrap) ins, n, Map.mapWithKey (f . TC.unwrap) outs)) .+   graphMapWrap++nodeSet :: Graph e n el nl -> Set n+nodeSet = Map.keysSet . graphMapWrap+++type+   InOut e n el nl =+      ([LabeledEdge e n el], LabeledNode n nl, [LabeledEdge e n el])++mapNodeWithInOut ::+   (Edge e, Ord n) =>+   (InOut e n el nl0 -> nl1) -> Graph e n el nl0 -> Graph e n el nl1+mapNodeWithInOut f =+   Graph .+   Map.mapWithKey+      (\n (ins,nl,outs) ->+         (ins,+          f (Map.toList $ unwrapMap ins, (n,nl), Map.toList $ unwrapMap outs),+          outs)) .+   graphMapWrap+++{- |+Same restrictions as in 'traverse'.+-}+traverseNode ::+   (Applicative f, Edge e, Ord n) =>+   (nl0 -> f nl1) -> Graph e n el nl0 -> f (Graph e n el nl1)+traverseNode f = traverse f pure++{- |+Same restrictions as in 'traverse'.+-}+traverseEdge ::+   (Applicative f, Edge e, Ord n) =>+   (el0 -> f el1) -> Graph e n el0 nl -> f (Graph e n el1 nl)+traverseEdge f = traverse pure f++{- |+Don't rely on a particular order of traversal!+-}+traverse, _traverseNaive ::+   (Applicative f, Edge e, Ord n) =>+   (nl0 -> f nl1) ->+   (el0 -> f el1) ->+   Graph e n el0 nl0 -> f (Graph e n el1 nl1)+traverse fn fe gr =+   liftA2 fromMap+      (Trav.traverse fn $ nodeLabels gr)+      (Trav.traverse fe $ edgeLabels gr)++{-+Due to the current implementation all edges are accessed twice.+That is, the actions should be commutative and non-destructive.+-}+_traverseNaive fn fe =+   fmap Graph .+   Trav.traverse+      (\(ins,n,outs) ->+         liftA3 (,,) (Trav.traverse fe ins) (fn n) (Trav.traverse fe outs)) .+   graphMapWrap+++isLoop :: (Edge edge, Eq node) => edge node -> Bool+isLoop e = from e == to e++pathExists ::+   (Edge edge, Ord node) =>+   node -> node -> Graph edge node edgeLabel nodeLabel -> Bool+pathExists src dst =+   let go gr a =+          not (isEmpty gr) &&+          (a==dst || (any (go (deleteNode a gr)) $ suc gr a))+   in  flip go src+++-- * Wrap utilities++unwrapMap :: Map (TC.Wrap e n) a -> Map (e n) a+unwrapMap = Map.mapKeysMonotonic TC.unwrap++wrapMap :: Map (e n) a -> Map (TC.Wrap e n) a+wrapMap = Map.mapKeysMonotonic TC.Wrap++unwrapSet :: Set (TC.Wrap f a) -> Set (f a)+unwrapSet = Set.mapMonotonic TC.unwrap+++type InOutMap e n el nl = (Map (e n) el, nl, Map (e n) el)++unwrapInOut :: InOutMap (TC.Wrap e) n el nl -> InOutMap e n el nl+unwrapInOut = mapFst3 unwrapMap . mapThd3 unwrapMap++withWrappedGraph ::+   (Map n0 (InOutMap (TC.Wrap e0) n0 el0 nl0) ->+    Map n1 (InOutMap (TC.Wrap e1) n1 el1 nl1)) ->+   Graph e0 n0 el0 nl0 -> Graph e1 n1 el1 nl1+withWrappedGraph f =+   Graph . f . graphMapWrap++fromWrap :: (Edge edge) => TC.Wrap edge node -> node+fromWrap = from . TC.unwrap++toWrap :: (Edge edge) => TC.Wrap edge node -> node+toWrap   = to   . TC.unwrap
+ src/Data/Graph/Comfort/Map.hs view
@@ -0,0 +1,108 @@+module Data.Graph.Comfort.Map where++import qualified Data.Set as Set+import qualified Data.Map as Map+import Data.Set (Set)+import Data.Map (Map)+import Data.Tuple.HT (swap)+import Data.Maybe (mapMaybe)++import qualified Prelude as P+import Prelude hiding (curry, uncurry, flip)+++-- | New improved ugly version with caller function name+type Caller = String+++checkedLookup ::+  (Ord k, Show k) => Caller -> Map k v -> k -> v+checkedLookup c m k =+  case Map.lookup k m of+    Nothing ->+      error $ "checkedLookup error in " ++ c ++ "\n"+              ++ "key: " ++ show k  ++ "\n"+              ++ "keys in map:\n" ++ unlines (map show (Map.keys m)) ++ "\n"+    Just x -> x++{- |+The set of keys must be equal and this is checked dynamically.+-}+checkedZipWith ::+  (Ord k) =>+  Caller ->+  (a -> b -> c) ->+  Map k a -> Map k b -> Map k c+checkedZipWith caller f ma mb =+  if Map.keysSet ma == Map.keysSet mb+    then Map.intersectionWith f ma mb+    else error $+            "checkedZipWith called by function " ++ caller +++            ": key sets differ"+++reverse :: (Ord b) => Map a b -> Map b a+reverse = Map.fromList . map swap . Map.toList++-- Map.fromSet is available from containers-0.5+fromSet ::+   (Ord key) => (key -> a) -> Set key -> Map key a+fromSet f = Map.fromAscList . map (\k -> (k, f k)) . Set.toAscList++differenceSet ::+   (Ord key) => Map key a -> Set key -> Map key a+differenceSet m s = Map.difference m (fromSet (const ()) s)++intersectionSet ::+   (Ord key) => Map key a -> Set key -> Map key a+intersectionSet m s = Map.intersection m (fromSet (const ()) s)++++curry ::+   (Ord k0, Ord k1) =>+   Caller ->+   (k -> (k0, k1)) ->+   Map k a -> Map k0 (Map k1 a)+curry caller f =+   Map.unionsWith (Map.unionWith (error $ caller ++ ".curry: duplicate key")) .+   Map.elems .+   Map.mapWithKey+      (\k a ->+         case f k of+            (k0, k1) -> Map.singleton k0 $ Map.singleton k1 a)++uncurry ::+   (Ord k) =>+   Caller ->+   (k0 -> k1 -> k) ->+   Map k0 (Map k1 v) -> Map k v+uncurry caller f =+   Map.unionsWith (error $ caller ++ ".uncurry: duplicate key") .+   Map.elems .+   Map.mapWithKey (Map.mapKeys . f)++flip ::+   (Ord k0, Ord k1) =>+   Map k0 (Map k1 a) -> Map k1 (Map k0 a)+flip =+   Map.unionsWith (Map.unionWith (error $ "Map.flip: duplicate key")) .+   concat .+   Map.elems .+   Map.mapWithKey+      (\k0 ->+         Map.elems .+         Map.mapWithKey+            (\k1 a -> Map.singleton k1 $ Map.singleton k0 a))+++mapMaybeKeys ::+   (Ord k1) =>+   (k0 -> Maybe k1) ->+   Map k0 a -> Map k1 a+mapMaybeKeys f =+   Map.fromList . mapMaybe (\(k,a) -> fmap (P.flip (,) a) $ f k) . Map.toList+++compose :: (Ord a, Ord b) => Map b c -> Map a b -> Map a c+compose bc ab = Map.mapMaybe (P.flip Map.lookup bc) ab
+ src/Data/Graph/Comfort/TotalMap.hs view
@@ -0,0 +1,34 @@+-- inspired by total-map+module Data.Graph.Comfort.TotalMap where++import Control.Applicative (Applicative, pure, (<*>))++import qualified Data.Map as Map+import Data.Map (Map)+import Data.Monoid ((<>))+++data TotalMap k a = TotalMap {deflt :: a, core :: Map k a}++cons :: a -> Map k a -> TotalMap k a+cons = TotalMap+++instance Functor (TotalMap k) where+   fmap f (TotalMap d m) = TotalMap (f d) (fmap f m)++instance (Ord k) => Applicative (TotalMap k) where+   pure a = TotalMap a Map.empty+   TotalMap fd fm <*> TotalMap ad am =+      TotalMap (fd ad) $+         fmap ($ad) (Map.difference fm am) <>+         fmap (fd$) (Map.difference am fm) <>+         Map.intersectionWith ($) fm am++intersectionPartialWith ::+   (Ord k) =>+   (a -> b -> c) -> TotalMap k a -> Map k b -> Map k c+intersectionPartialWith f (TotalMap ad am) bm =+   Map.intersectionWith f am bm+   `Map.union`+   fmap (f ad) bm
+ src/Data/Graph/Comfort/TypeConstructor.hs view
@@ -0,0 +1,30 @@+-- similar to prelude-extras+module Data.Graph.Comfort.TypeConstructor (+   Wrap(Wrap, unwrap),+   ) where++import Data.Functor.Classes (Eq1(eq1), Ord1(compare1), Show1(showsPrec1))++import Data.Traversable (Traversable, traverse)+import Data.Foldable (Foldable, foldMap)+++newtype Wrap f a = Wrap {unwrap :: f a}++instance (Eq1 f, Eq a) => Eq (Wrap f a) where+   Wrap x == Wrap y  =  eq1 x y++instance (Ord1 f, Ord a) => Ord (Wrap f a) where+   compare (Wrap x) (Wrap y)  =  compare1 x y++instance (Show1 f, Show a) => Show (Wrap f a) where+   showsPrec p (Wrap x)  =  showsPrec1 p x++instance Functor f => Functor (Wrap f) where+   fmap f (Wrap a) = Wrap (fmap f a)++instance Foldable f => Foldable (Wrap f) where+   foldMap f (Wrap a) = foldMap f a++instance Traversable f => Traversable (Wrap f) where+   traverse f (Wrap a) = fmap Wrap $ traverse f a