diff --git a/src/Compare/Types/Lenses.hs b/src/Compare/Types/Lenses.hs index 267ea3fc476587dbc46fb15b9e678bd310140ea8..1aaab6177bbfe62c7ab6253c844623442b2fd0e4 100644 --- a/src/Compare/Types/Lenses.hs +++ b/src/Compare/Types/Lenses.hs @@ -1,6 +1,16 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE Rank2Types #-} -module Compare.Types.Lenses where +module Compare.Types.Lenses + ( outLEdges + , inLEdges + , edgeFrom + , edgeTo + , edgeLabel + , inn + , edges + , nodes + , node + ) where import qualified Data.Graph.Inductive as G import Lens.Micro @@ -39,24 +49,31 @@ edgeLabel = _3 inn :: G.Node -> Traversal' (Graph n e) (G.LEdge e) inn node = inLEdges node . traverse -edges :: Traversal' (Graph n e) e -edges action g = - let - oldEdges = g^._graph.to G.labEdges - action' (a,b,l) = (a,b,) <$> action l - newEdges = traverse action' oldEdges - in - (\x -> replaceEdges oldEdges x g) <$> newEdges +ctxEdges :: Traversal (G.Context n e1) (G.Context n e2) e1 e2 +ctxEdges action (inn, n, a, out) = (,n,a,) <$> lift inn <*> lift out + where + lift = (each . _1) action + +edges :: Traversal (Graph n e1) (Graph n e2) e1 e2 +edges = _graph . gContexts . ctxEdges + +nodes :: Traversal (Graph n1 e) (Graph n2 e) n1 n2 +nodes = _graph . gContexts . _3 + +gContexts :: G.DynGraph gr => Traversal (gr n1 e1) (gr n2 e2) + (G.Context n1 e1) (G.Context n2 e2) +gContexts action = G.ufold (\ctx g -> (G.&) <$> action ctx <*> g) (pure G.empty) + +ctxNode :: G.Node -> Traversal' (G.Context n e) n +ctxNode node act ctx + | ctx^._2 == node = _3 act ctx + | otherwise = pure ctx + +gNode :: G.DynGraph gr => G.Node -> Traversal' (gr n e) n +gNode node = gContexts . ctxNode node --- | See http://stackoverflow.com/questions/22169735/how-to-modify-node-label-in-fgl-package node :: G.Node -> Traversal' (Graph n e) n -node n = _graph . change - where - change action g = case G.match n (g) of - (Just (p, _, l, s), cg) -> - let newC = (p, n, , s) <$> action l - in (G.& cg) <$> newC - (Nothing, _) -> pure g +node n = _graph . gNode n replaceEdges :: [G.LEdge e] -> [G.LEdge e] -> Graph n e -> Graph n e replaceEdges e1 e2 g = g & _graph %~ G.delEdges (map G.toEdge e1)