modify edge label in Haskell package fgl

I've wrote the following code to increment the label of a given edge of a graph with FGL package, if the edge does not exist, it is created before being incremented :

import Data.Graph.Inductive    

incrementEdge :: Edge -> Gr a Int -> Gr a Int
incrementEdge edge g 开发者_C百科= gmap (increment edge) g 

increment :: Edge -> Context a Int -> Context a Int
increment (a,b) all@(p,n,x,v) = if a /= n then all else (p,n,x,v'')
  where
    v' = let (r,_) = elemNode b v in if r then v else ((0,b):v)
    v'' = map (\(x,y) -> if y == b then (x+1,y) else (x,y)) v'

a :: Gr String Int
a = ([],1,"a",[]) & empty
b = ([],2,"b",[]) & a

while testing I got the following result :

*Main> incrementEdge (1,1) b

1:"a"->[(1,1)]
2:"b"->[]
*Main> incrementEdge (1,2) b

1:"a"->[(1,2)]
2:"b"->[]
*Main> incrementEdge (2,2) b

1:"a"->[]
2:"b"->[(1,2)]

But ...

*Main> incrementEdge (2,1) b
*** Exception: Edge Exception, Node: 1

what is the problem here ?

EDITION

elemNode ys [] = (False,0)
elemNode ys ((m,xs):xss) = if ys == xs then (True,m) else elemNode ys xss

I want to write a function which will add an edge to a graph from two nodes labels, the function checks that the two nodes exist, if not it create them : - if nodes already exists the label of the edge between them is increment, - if there is no edge between those node it is create before being incremented

Thanks for your reply

I don't think you're supposed to add edges with gmap: it folds over all the contexts in the graph in an arbitrary order and builds up the new graph by &ing the new contexts together. If a new context has a link to or from a node that hasn't been &ed yet, you get the Edge Exception.

Here's a simple example:

*Main> ([], 1, "a", [(0, 2)]) & empty :: Gr String Int
*** Exception: Edge Exception, Node: 2

I've only used FGL for a couple of little projects and am certainly no expert, but it probably makes more sense just to add new edges (with label 1) using insEdge and then do all the counting when needed:

import Data.Graph.Inductive
import qualified Data.IntMap as I

incrementEdge :: Edge -> Gr a Int -> Gr a Int
incrementEdge (a, b) = insEdge (a, b, 1)

count :: Gr a Int -> Gr a Int
count = gmap $ \(p, n, x, v) -> (countAdj p, n, x, countAdj v)
  where
    swap (a, b) = (b, a)
    countAdj = map swap . I.toList . I.fromListWith (+) . map swap

This seems to work as desired:

*Main> count $ incrementEdge (2, 1) b
1:"a"->[]
2:"b"->[(1,1)]

*Main> count $ incrementEdge (2, 1) $ incrementEdge (2, 1) b
1:"a"->[]
2:"b"->[(2,1)]

1) A quick grep for Edge Exception in the fgl package:

cabal unpack fgl
cd fgl*
grep "Edge Exception" * -R

yields the file Data/Graph/Inductive/Tree.hs. Looking there we have the call updAdj that will throw this exception any time elemFM g v is false.

2) Could you provide runnable code? What you posted is missing elemNode (when using fgl 5.4.2.3)

3) Could you provide what version of fgl you're using? If it's old an upgrade might fix the issue.

Mapping over the graph doesn't seem like quite the right kind of traversal. The following works with the extracted context of the edge's source node.

edgeLookup :: Node -> [(a,Node)] -> Maybe ((a,Node), [(a,Node)])
edgeLookup n = aux . break ((== n) . snd)
    where aux (h, []) = Nothing
          aux (h, t:ts) = Just (t, h ++ ts)

incrementEdge :: Edge -> Gr a Int -> Maybe (Gr a Int)
incrementEdge (from,to) g = aux $ match from g
    where aux (Nothing, _) = Nothing
          aux (Just (i,n,l,o), g') = Just $ (i,n,l,checkEdge o) & g'
          checkEdge outEdges = 
              maybe ((1,to):outEdges) incEdge $ edgeLookup to outEdges
          incEdge ((cnt,n), rst) = (cnt+1,n):rst

I would probably also use a helper to go from (Maybe a, b) -> Maybe (a,b) then fmap aux over the helper composed with match. That would help to distill things down a bit better.

EDIT

To support node addition based on labels, one needs to track the bijection between labels and Node identifiers (Ints). This can be done by using a Map that is updated in parallel to the graph.

import Data.Graph.Inductive
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (fromJust)

-- A graph with uniquely labeled nodes.
type LGraph a b = (Map a Int, Gr a b)

-- Ensure that a node with the given label is present in the given
-- 'LGraph'. Return the Node identifier for the node, and a graph that
-- includes the node.
addNode :: Ord a => a -> LGraph a b -> (Int, LGraph a b)
addNode label (m,g) = aux $ M.lookup label m
    where aux (Just nid) = (nid, (m,g))
          aux Nothing    = (nid', (m', g'))
          [nid'] = newNodes 1 g 
          m' = M.insert label nid' m
          g' = insNode (nid', label) g

-- Adding a context to a graph requires updating the label map.
(&^) :: Ord a => Context a b -> LGraph a b -> LGraph a b
c@(_, n, label, _) &^ (m,g) = (m', g')
    where m' = M.insert label n m
          g' = c & g

-- Look for a particular 'Node' in an edge list.
edgeLookup :: Node -> [(a,Node)] -> Maybe ((a,Node), [(a,Node)])
edgeLookup n = aux . break ((== n) . snd)
    where aux (h, []) = Nothing
          aux (h, t:ts) = Just (t, h ++ ts)

-- Increment the edge between two nodes; create a new edge if needed.
incrementEdge :: Edge -> Gr a Int -> Maybe (Gr a Int)
incrementEdge (from,to) g = fmap aux $ liftMaybe (match from g)
    where aux ((i,n,l,o), g') = (i,n,l,checkEdge o) & g'
          checkEdge outEdges = 
              maybe ((1,to):outEdges) incEdge $ edgeLookup to outEdges
          incEdge ((cnt,n), rst) = (cnt+1,n):rst

liftMaybe :: (Maybe a, b) -> Maybe (a, b)
liftMaybe (Nothing, _) = Nothing
liftMaybe (Just x, y) = Just (x, y)

-- Increment an edge in an 'LGraph'. If the nodes are not part of the 
-- graph, add them.
incrementLEdge :: Ord a => (a, a) -> LGraph a Int -> LGraph a Int
incrementLEdge (from,to) g = (m', fromJust $ incrementEdge' (from',to') g')
    where (from', gTmp)  = addNode from g
          (to', (m',g')) = addNode to gTmp

-- Example
a' :: LGraph String Int
a' = ([],1,"a",[]) &^ (M.empty, empty)
b' = ([],2,"b",[]) &^ a'
test6 = incrementLEdge ("c","b") $ incrementLEdge ("b","a") b'

{-
*Main> test6
(fromList [("a",1),("b",2),("c",3)],
1:"a"->[]
2:"b"->[(1,1)]
3:"c"->[(1,2)])
-}