修改邊標籤哈斯克爾包FGL

Question

我已經寫了下面的代碼，以增加與FGL包圖的給定邊的標籤，如果邊緣不存在，它被遞增之前創建的：

import Data.Graph.Inductive  

incrementEdge :: Edge -> Gr a Int -> Gr a Int 
incrementEdge edge g = 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 

測試時，我得到了以下結果：

*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)] 

但是......

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

什麼這裏是問題嗎？

版

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

我想編寫一個函數，將一個邊緣從兩個節點標籤添加到圖表，函數檢查兩個節點存在，如果不是創建它們： - 如果節點已經存在，它們之間的邊緣的標籤是增量， - 如果它正在增加

感謝您的回覆之前創建這些節點之間沒有邊

Answer 1

我不認爲你應該添加邊緣gmap：它以任意順序疊加在圖形中的所有上下文中，並且通過將新的上下文結合在一起構建新圖形。如果新的上下文有一個鏈接指向還是來自尚未被編輯的節點的鏈接，則會得到Edge Exception。

這裏有一個簡單的例子：

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

我只用FGL了幾個小項目，和我肯定沒有專家，但它可能更有意義只是爲了增加新的邊緣（帶標籤1）使用insEdge，然後在需要的時候做的所有計數：

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 

這似乎爲所需的工作：

*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)] 

Answer 2

1）在fgl包快速grep爲Edge Exception：

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

產生文件Data/Graph/Inductive/Tree.hs。看看那裏，我們有電話updAdj，這將拋出此例外elemFM g v是錯誤的任何時間。

2）你能提供可運行代碼嗎？您發佈的內容缺失elemNode（使用fgl 5.4.2.3時）

3）您能否提供您正在使用的fgl版本？如果過時了，升級可能會解決問題。

Answer 3

對圖的映射似乎不是很正確的一種遍歷。以下內容適用於邊緣源節點的提取上下文。

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 

我可能還使用一個輔助的(Maybe a, b) -> Maybe (a,b)然後fmap aux走過去與match組成的幫手。這將有助於提煉出更好的東西。

EDIT

要基於標籤的支持節點此外，一個需要跟蹤標籤和節點標識符（整數）之間的雙射。這可以通過使用與圖形並行更新的Map來完成。

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)]) 
-}