我编写了一个程序来生成平面图的正交表示。对于这项工作,我使用 GHC 6.10.1。我的代码基于 FGL 库。它用于保持图形结构。
最近我发现了一个我无法解释的错误。如果删除我的程序的上下文作业,那么:
main = let g = insEdge (0,1,()) $ buildGr [ ([], 0, (), []), ([], 1, (), []) ] g' = delEdge (0,1) g 在 if 1 `elem` suc g 0 然后把StrLn“确定” 否则 putStrLn “错误”
该程序必须打印“OK”但结果是“ERROR”
这里更详细。函数 prepareData 得到一个带有帮助边的图。Data BlockScheme 也将他们的数据保存在cyclesInfoBS 列表中。这些边需要函数 dualGraph 的算法。
函数 prepareG 从删除这些边的图形中构建新图形。并且 EmbeddedBSG 变量的值必须在任何地方都相同。
但是 dualGraph 工作时会发生错误。内部跟踪表示该图没有帮助边(2,1),但在调用 dualGraph 之前,它的图参数有帮助边。dualGraph 的模块既没有 delEdge 也没有 delEdge 也没有 delNodes 也没有 delNode 并且没有调用要执行此操作的函数。dualGraph 的模块只读取图形变量。
如果注释代码删除帮助边缘,那么它们会留下来。
dualGraph之前的图状态:
__+嵌入式BSG = 0:NodeLabel {typeLabel = Terminator, sizeLabel = (30.0,10.0), textLabel = (), foregroundLabel = 0x000000, backgroundLabel = 0xFFFFFF}->[((1,3),3)] 1:NodeLabel {typeLabel = Terminator, sizeLabel = (30.0,10.0), textLabel = (), foregroundLabel = 0x000000, backgroundLabel = 0xFFFFFF}->[] 2:NodeLabel {typeLabel = HelpNode, sizeLabel = (0.0,0.0), textLabel = (), foregroundLabel = 0x000000, backgroundLabel = 0xFFFFFF}->[((2,0),1)] 3:NodeLabel {typeLabel = IfWhBlock, sizeLabel = (30.0,20.0), textLabel = (), foregroundLabel = 0x000000, backgroundLabel = 0xFFFFFF}->[(((1,0),2),((2,2),1 ),((0,1),4)] 4:NodeLabel {typeLabel = OpBlock, sizeLabel = (30.0,20.0), textLabel = (), foregroundLabel = 0x000000, backgroundLabel = 0xFFFFFF}->[((0,1),2)]
将图的状态转换为 DualGraph 模块:
0:(0.0,NodeLabel {typeLabel = Terminator, sizeLabel = (30.0,10.0), textLabel = (), foregroundLabel = 0x000000, backgroundLabel = 0xFFFFFF})->[((1,3),3)] 1:(30.0,NodeLabel {typeLabel = Terminator, sizeLabel = (30.0,10.0), textLabel = (), foregroundLabel = 0x000000, backgroundLabel = 0xFFFFFF})->[] 2:(45.0,NodeLabel {typeLabel = HelpNode, sizeLabel = (0.0,0.0), textLabel = (), foregroundLabel = 0x000000, backgroundLabel = 0xFFFFFF})->[] 3:(15.0,NodeLabel {typeLabel = IfWhBlock, sizeLabel = (30.0,20.0), textLabel = (), foregroundLabel = 0x000000, backgroundLabel = 0xFFFFFF})->[((2,2),1),((1, 0),2),((0,1),4)] 4:(35.0,NodeLabel {typeLabel = OpBlock, sizeLabel = (30.0,20.0), textLabel = (), foregroundLabel = 0x000000, backgroundLabel = 0xFFFFFF})->[((0,1),2)] allEdges: = [(OutEdge,(2,(0,1))),(InEdge,(3,(0,1)))]
第二状态的节点 2 没有任何传出边。
DualGraph中有一个检测错误的地方是函数lSortSuc。
lSortSuc vertexId graph =.... 它要求 vertexId 的顶点至少有 1 个入边和 1 个出边,或者它是 sink 节点。在这种情况下,sink 节点为 1。
然后它可以假设 lSortSuc 在没有节点 2 的帮助边的图的某个地方被调用。但事实并非如此。
有人有什么想法吗?我能做些什么?
类型 BlockSchemeGraph = Gr NodeLabel () 数据周期信息 = 循环信息 { reversedEdge :: 边缘, 帮助边缘 :: 边缘 } 推导 (Show, Eq) 数据 BlockScheme = BlockScheme { graphBS :: BlockSchemeGraph, 循环信息BS :: [循环信息], generalSchemeOptionsBS :: (), backBonesBS :: [[节点]] } 推导 (Show, Eq) 准备数据 bs = 让 bsg = graphBS bs [ sink, source ] = map head $ pam bsg [ getSinks, getSources ] [帮助节点] = newNodes 1 bsg helpEdges = [ (source,helpNode), (helpNode, sink) ] bsg' = insEdges [ (a,b, ()) | (a,b) (l, 0.0) ) -- 这里的帮助边被删除 $ foldr (\cinf g -> delEdge (helpEdge cinf) g) (trace ("\n\nembG = " ++ show embG) embG) 周期信息 f (v, 高度) g = 让 fsuc (w, (order, weight)) g = setELabel' (v,w) (顺序, 重量 + 高度/2) g fpre (w, (order, weight)) g = setELabel' (w,v) (顺序, 重量 + 高度/2) g g' = 折叠 fsuc g $ lsuc gv 在文件夹 fpre g' $ lpre g' v 在 emap (\(order, weight) -> (order, {-round-} weight)) . 文件夹 f embG' . 地图 (\n -> (n, snd . sizeLabel $ getVLabel n embG)) $ 节点 embG -------------------------------------------------- --------------------- {-# LANGUAGE ScopedTypeVariables #-} 模块 GraphVisualiser #如果定义(MYDEBUG) #别的 (可视化方案,块方案图像) #万一 在哪里 导入 SimpleUtil (map2,swap,pam, vopt, compareDouble) 导入 Data.Maybe (fromJust,isJust) 导入 Data.List (foldl',find, nubBy, deleteFirstsBy, maximumBy) 导入合格的 Data.Map 作为 Map 导入方案编译器 导入 InductivePlus 导入 GraphEmbedder 导入 DualGraph 导入拓扑编号 导入 Text.Printf (printf) 导入 Debug.Trace 类型 NodePosition =(双,双) 键入 EdgePosition = [ 节点位置 ] 类型 BSIG = Gr (NodePosition, NodeLabel) EdgePosition newtype BlockSchemeImage = BlkScmImg BSIG 推导方程 getWeight = fst visualiseScheme :: BlockScheme -> BlockSchemeImage 可视化方案 bs = let (numEmbBsg, numDualBsg, emf, nmf, source, sink) = prepareData bs xCoords = map (calcXForBackBone (numEmbBsg, numDualBsg, emf, nmf)) $ backBonesBS bs calcedNodes = calcNodePositions numEmbBsg numDualBsg nmf emf source sink xCoords calcedEdges = calcEdgePositions numEmbBsg numDualBsg nmf emf source sink calcedNodes xCoords scaledG = scaleGraph calcedEdges -- g' = reverseFeedBacks scaledG $cyclesInfoBS bs 在 BlkScmImg g' -- -- calcedEdges calcXForBackBone (numEmbBsg, numDualBsg, emf, nmf) idsOfNodes = -- 让 (_, (xleft, xright) ) = maximumBy (\ (v1, (xleft1, xright1) ) (v2, (xleft2, xright2) ) -> 比较 (xright1 - xleft1) (xright2 - xleft2) ) $ map (\ v -> (v, fidsToWeights numDualBsg $ Map.lookup v nmf )) idsOfNodes 在 ( (xright + xleft) / 2.0 , idsOfNodes ) -- g :: Gr (NodePosition, NodeLabel) [ NodePositions ] reverseFeedBacks g 周期信息 = foldr fEdge g 周期信息 其中 fEdge cinfo g = 让 elbl = getELabel 例如 e = reversedEdge cinfo (v,w) = e g' = delEdge 例如 在 insEdge (w,v, 反向 elbl) g' calcEdgePositions numEmbBsg numDualBsg nmf emf 源接收器 calcedNodes backBones = 让 fEdge e@(v,w) g = 让 xOfe = case find (\ (x, lst) -> if v `elem` lst && w `elem` lst 那么真 否则为假 ) 骨干 什么都没有 -> halfSumEdge numDualBsg emf e 只是 (x,_) -> x [startY, endY] = 映射 (\n -> getWeight $ getVLabel n numEmbBsg) [ v, w ] 坐标 = [ (xOfe, startY), (xOfe, endY) ] g' = setELabel' (v,w) 坐标 g 在跟踪 ("\n\ncoords = " ++ 显示坐标 ++ "\ncalc 边缘 " ++ 显示 (v,w) ++ "\nemf = " ++ 显示 emf ++ "\nnmf = " ++ 显示 nmf ++ "\nnumDualBsg = " ++ 显示 numDualBsg ++ "\nnumEmbBsg = " ++ 显示 numEmbBsg) G' outEdgesOfSource = map fst $ lSortSuc numEmbBsg 源 inEdgesOfSink = map fst $ lSortPre numEmbBsg sink fixFouthEdgeLbl v lst yModifier g = 第一个案例 [_]->g [ _, _ ] -> (trace "\nFixFouth\n" g) [ _, _, _ ] -> g [ _, _, _, w ] -> 让 [ (x1,y1), p2 ] = getELabel (v,w) g (xv, yv) = fst $ getVLabel vg 在 setELabel' (v,w) [ (xv, yModifier y1 ), (x1, yModifier y1 ), p2 ] G _ -> 错误 $ "visualiseScheme.fixFouthEdgeLbl: lst 有超过 4 条边!!!\n" ++ 显示 lst calcedUsualEdges = foldr fEdge 计算节点 $ 边缘计算节点 calcedAll = fixFouthEdgeLbl sink inEdgesOfSink (+1) $ fixFouthEdgeLbl source outEdgesOfSource (\a -> a - 1) calcedUsualEdges 在跟踪 ("\ncalcedAll = " ++ 显示 calcedAll) calcedAll 比例图 g = 让 系数 = 3.0 保证金LT = 10 modifyCoord = (marginLT + ) 。(*factor) -- marginLeft и marginTop modifyCoords a = map2 modifyCoord 。vopt (-) a $ minCoordinates g 在 emap 中(地图修改坐标) $ nmap (\(coords, lbl) -> (modifyCoords coords, lbl) ) G 准备数据 bs = 让 bsg = graphBS bs [ sink, source ] = map head $ pam bsg [ getSinks, getSources ] [帮助节点] = newNodes 1 bsg helpEdges = [ (source,helpNode), (helpNode, sink) ] bsg' = insEdges [ (a,b, ()) | (a,b) (l, 0.0) ) $ foldr (\cinf g -> {- g) --- -} delEdge (helpEdge cinf) g) (trace ("\n\nembG = " ++ show embG) embG) 周期信息 f (v, 高度) g = 让 fsuc (w, (order, weight)) g = setELabel' (v,w) (顺序, 重量 + 高度/2) g fpre (w, (order, weight)) g = setELabel' (w,v) (顺序, 重量 + 高度/2) g g' = 折叠 fsuc g $ lsuc gv 在文件夹 fpre g' $ lpre g' v 在 emap (\(order, weight) -> (order, {-round-} weight)) . 文件夹 f embG' . 地图 (\n -> (n, snd . sizeLabel $ getVLabel n embG)) $ 节点 embG prepareDualG dg = 让 dg' = emap (\lbl -> (lbl, 0.0)) dg 宽度元素 v sucOrPre = 让宽度 = fst 。sizeLabel $getVLabel vg 宽度 / (fromIntegral .length $ sucOrPre gv) -- 节点是人脸 fNodes v (dg :: Gr Face (Edge, Double) )= 让 fEdge (w, (orig@(origV, origW), weight)) dg = 让 wV = widthElement origV lsuc wW = widthElement origW lpre 在 setELabel' (v,w) (orig, weight + wV + wW) dg 传出 :: [ (Node, (Edge, Double)) ] 传出 = lsuc dg v 在文件夹 fEdge dg 传出 在 emap (\(e, weight) -> (e, {-round-} weight)) . foldr fNodes dg' $ 节点 dg calcNodePositions numEmbBsg numDualBsg nmf emf source sink backBones {- :: [ (Double, [ Node ] ) -} = 让 fNode v (g :: Gr (NodePosition, NodeLabel) [ NodePosition ] ) = 如果 v == 源 -- s 然后 calcSorT v id g lSortSuc numEmbBsg numDualBsg emf backBones 否则如果 v == sink -- t 然后 calcSorT v 交换 g lSortPre numEmbBsg numDualBsg emf backBones 否则让 vlbl = getVLabel v numEmbBsg xCoord = case find (\ (x, lst) -> 如果 v `elem` lst 那么真 否则为假 ) 骨干 什么都没有 -> halfSumNode numDualBsg nmf v 只是 (x,_) -> x 在 setVLabel' v ((xCoord, getWeight vlbl ), snd vlbl) g g' :: Gr (NodePosition, NodeLabel) [ NodePosition ] g' = emap (\_ -> [] ) $ nmap (\(weight, lbl) -> ((0.0,0.0), lbl)) numEmbBsg 结果 :: Gr (NodePosition, NodeLabel) [ NodePosition ] 结果 = 折叠 fNode G' $ 节点 numEmbBsg 结果 calcSorT v 选择器 (g :: Gr (NodePosition, NodeLabel) [ NodePosition ] ) edgeSelector numEmbBsg numDualBsg emf backBones = 让 calcSTDegree4 w = let (weight , vlbl) = getVLabel v numEmbBsg 在 setVLabel' v ((halfSumEdge numDualBsg emf $ selector (v,w) , 重量 ), vlbl) G in case map fst $ edgeSelector numEmbBsg v of []->错误$“calcSorT:节点”++显示v ++ " 没有任何 suc 边!\nGraph:\n" ++ show g ++ "\nnumEmbBsg = \n" ++ 显示 numEmbBsg [ w ] -> let (weight, vlbl) = getVLabel v numEmbBsg xCoord = case find (\ (x, lst) -> 如果 v `elem` lst 那么真 否则为假 ) 骨干 无 -> halfSumEdge numDualBsg emf $ 选择器 (v,w) -----halfSumNode numDualBsg nmf v 只是 (x,_) -> x 在 setVLabel' v ((xCoord , weight), vlbl) G [ w1, _ ] -> let (weight , vlbl) = getVLabel v numEmbBsg 在 setVLabel' v (( snd .fidsToWeights numDualBsg $ Map.lookup(选择器(v,w1))电动势, 重量), vlbl ) G [ _, w, _ ] -> calcSTDegree4 w [ _, w, _, _ ] -> calcSTDegree4 w moreEdges -> error $ "calcSorT: node " ++ show v ++ " has got too may edges!:\n" ++ 显示更多边 ++ "\nGraph:" ++ 显示 g ++ "\nnumEmbBsg = " ++ 显示 numEmbBsg --- fidsToWeights :: 也许 EdgeFaces -> NodePosition fidsToWeights numDualBsg = map2 (\fid -> getWeight $ getVLabel fid numDualBsg) 。来自Just halfSum numDualBsg fids = ( uncurry (+) (fidsToWeights numDualBsg fids) / 2.0 ) :: Double halfSumNode numDualBsg nmf v = (halfSum numDualBsg) $ Map.lookup v nmf halfSumEdge numDualBsg emf e = (halfSum numDualBsg) $ Map.lookup e emf -------------------------------------------------- --------------------- 模块 DualGraph #如果定义(MYDEBUG) #别的 (dualGraph, Face(..), leftFace, rightFace, FaceId, EdgeFaces, EdgeMapFaces,NodeMapFaces, DualGraph, lSortSuc, lSortPre) #万一 在哪里 导入合格的 Data.Set 作为 Set 导入合格的 Data.Map 作为 Map 导入 Data.Maybe (fromJust,isJust) 导入 SimpleUtil (apa,swap,map2) 导入 Data.List (foldl', sortBy, 查找) 导入 InductivePlus 导入 GraphEmbedder 导入 Debug.Trace 类型 FaceId = Int 类型 EdgeFaces = (FaceId, FaceId) type EdgeMapFaces = Map.Map Edge EdgeFaces type NodeMapFaces = Map.Map 节点 EdgeFaces leftFace :: EdgeFaces -> FaceId 左脸 = fst rightFace :: EdgeFaces -> FaceId rightFace = snd 数据 Face = Face { sourceNode, sinkNode :: Node, leftContour, rightContour :: Set.Set Edge --- [节点], } | 外表面{ leftContour, rightContour :: Set.Set Edge --- [节点], } 推导 (Show, Eq) nodePathToEdgePath :: Ord a => [ a ] -> Set.Set (a,a) nodePathToEdgePath (h:rest) = Set.fromList 。snd $ foldl' (\ (current,result) next -> (下一个,(当前,下一个):结果)) (H, []) 休息 newFace src leftC rightC = 面{ sourceNode = src, sinkNode = 最后左边C, leftContour = nodePathToEdgePath $ src : leftC, rightContour = nodePathToEdgePath $src : rightC -- , } newOuterFace embG edgeSelector slotModifier = case filter (\v -> null $ lpre embG v) $ nodes embG of [] -> 错误 $ "newOuterFace: 该图没有任何源顶点\n" ++ 显示 embG [ v ] -> slotModifier emptyOuterFace . nodePathToEdgePath $ findContour v 源顶点-> error $ "newOuterFace: 图形有多个源顶点:" ++ 显示源顶点 ++ "\nThe Graph:\n" ++ 显示 embG 在哪里 emptyOuterFace = OuterFace { leftContour = Set.empty, rightContour = Set.empty } 找到轮廓 v = case lSortSuc embG v 的 [] -> [ v ] someEdges -> v : (findContour . fst $ edgeSelector someEdges ) setRightContour face con = face { rightContour = con } setLeftContour face con = face { leftContour = con } 输入 DualGraph = Gr 面边 dualGraph :: BlockSchemeEmbeddedGraph -> (DualGraph, EdgeMapFaces, NodeMapFaces) checkm msg g = if 1 `notElem` suc g 2 然后错误 $ "\ncheckm:" ++ msg ++ "\nthe G = " ++ show g 否则跟踪 ( "\n\nsuc g 2 = " ++ 显示 (suc g 2) ) g dualGraph embGr = 让 embG = checkm "dualGraph:" embGr 通常的脸 = snd 。foldr (findFaces embG) (2, buildGr []) --- Map.empty) $ 节点 embG sFace = newOuterFace embG 头部 setRightContour tFace = newOuterFace embG last setLeftContour allFaces = insNodes [ (0,sFace), (1,tFace) ] allNodes = map (\n -> (n, getVLabel n allFaces)) $ 节点 allFaces linkedFaces = 折叠链接 全脸 [ (f1, f2) | f1@(fid1,_) fid1 ] emf = foldr (\(fid,f) m -> let comb fun conSel m = Set.fold (\em -> Map.insertWith fun e (fid,fid) 米) 米 $ conSelf 在梳子 (\ (_,r) (l,_) -> (l,r) ) 左轮廓 $梳子 (\ (l,_) (_,r) -> (l,r) ) 右轮廓 米 ) 地图.empty 所有节点 fNMF nm = let (lFace,rFace) = case lSortSuc embG n of [] -> 让 ls = lSortPre embG n lFace = leftFace . 来自Just $ Map.lookup (fst $head ls, n) -- 最后 ls, n) 电动势 rFace = rightFace . 来自Just $ Map.lookup (fst $ last ls, n) -- 头部 ls, n) 电动势 在 (lFace, rFace) ls -> 让 lFace = leftFace . 来自Just $ Map.lookup (n, fst $ head ls) 电动势 rFace = rightFace . 来自Just $ Map.lookup (n, fst $ last ls) 电动势 在 (lFace, rFace) 在 Map.insert n (lFace, rFace) m nmf = foldr fNMF Map.empty $ 节点 embG 在跟踪 ("\nDualGrapn: (linkedFaces, emf, nmf) \n" ++ show (linkedFaces, emf, nmf) ) (linkedFaces, emf, nmf) findFaces embG v st = case map fst $lSortSuc(checkm "findFaces:" embG) v of [] -> st -- вершина не может образовать грань [_]->圣 (firstOut:outgoing) -> snd $ foldl' (findFace embG v) (firstOut,st) 传出 数据 EdgeType = InEdge | OutEdge 推导 (Show,Eq) lSortEdges gren v = 让 g = trace ("\nlSortEdges: g = " ++ show gren) (checkm ("lSortEdges: v = " ++ show v )gren) getEdgeNumber (OutEdge, (_, (n,_))) = n getEdgeNumber (InEdge, (_, (_,n))) = n oute = lsuc gv ine = lpre gv allEdges = sortBy(apa 比较 getEdgeNumber) $ concat [ map (\lbl -> (OutEdge, lbl) ) 输出, 地图 (\lbl -> (InEdge, lbl) ) ine ] cAllEdges = 循环 allEdges zeroEdge = head (trace ("allEdges: = " ++ show allEdges) allEdges) spanE e = span ((e ==) . fst) outEdges = case fst zeroEdge of OutEdge -> fst 。跨度 OutEdge . snd 跨度InEdge . snd $ spanE OutEdge 呼叫边缘 _ -> fst 。跨度 OutEdge 。snd $ spanE InEdge 调用 inEdges = case fst zeroEdge of InEdge -> fst 。跨度InEdge . snd 跨度 OutEdge . snd $ spanE InEdge 调用 _ -> fst 。跨度 InEdge 。snd $ spanE OutEdge 呼叫边缘 在 if 空行 || 零外 然后让 [ sv ] = getSources g findContour prew w = 如果 w /= v 然后 findContour (Just w) 。fst 。head $ (trace ("\n\nlSortSuc gw = " ++ show w ++ " lsortSuc = " ++ 显示 (lSortSuc gw)) ( lSortSuc gw )) 否则预 wOfFirstEdge = fromJust $ findContour Nothing sv sine = sortBy (apa notCompare (snd . snd)) ine (beforeW, withW) = span ((wOfFirstEdge /=) . fst) 正弦 in ( sortBy (apa compare (fst . snd)) oute, withW ++ sortBy (apa compare (snd . snd)) beforeW ) 否则map2(地图snd) (outEdges, inEdges) 其中 notCompare ab = 大小写比较 ab 情商 -> 情商 LT->GT GT->LT lSortPre gv = 让 res = snd $ lSortEdges gv in trace ("\n\nlSortPre(" ++ show v ++ ") = " ++ show res) res lSortSuc gv = 让 res = fst $ lSortEdges gv in trace ("\n\nlSortSuc(" ++ show v ++ ", g= " ++ show g ++ ") = " ++ show res) res findFace embG v (wi, st@ (freeFID, mf)) wj = 让 findContour vw pStop selectEdge = 让 preEdges = lSortPre (checkm ("findFace: v = " ++ show v ++ " wi = " ++显示wi ++“v =”++显示v ++ " w = " ++ 显示 w ++ " wj = " ++ 显示 wj) embG) w sucEdges = lSortSuc embG w nextW = selectEdge sucEdges res = if null sucEdges || (not (null preEdges) && pStop v preEdges) -- w 是 t 节点 然后 [ w ] else w : findContour w nextW pStop selectEdge 在跟踪中 ("findContour: v = " ++ show v ++ " w = " ++ show w ++ " suc = " ++ show sucEdges ++ " pre = " ++ show preEdges ) 资源 leftCon = findContour v wi (\v -> (v /= ) . fst . head ) -- 最后 ) (fst . 最后) rightCon = findContour v wj (\v -> (v /=) . fst . last ) -- 头) (fst. 头) tr = trace ("\nfindFace v = " ++ show v ++ " wi = " ++ show wi ++ " wj = " ++ show wj ++ " freeFID = " ++ show freeFID ) leftCon res = (wj, (freeFID + 1, insNode (freeFID, newFace v tr rightCon) mf ) ) 在跟踪 ("\nfindFace:" ++ 显示 res ) res 链接 ((fid1, f1), (fid2, f2)) g = 让 getC f = (leftContour f, rightContour f) [ (lc1, rc1), (lc2, rc2) ] = 地图 getC [f1,f2] foldIntersection res 选择器 = 让 (ff1, ff2) = 选择器 (fid1, fid2) foldr (\e@(v,w) g -> insEdge (ff1,ff2,e) g ) G 资源 如果 Set.toList $ lc1 `Set.intersection` rc2 的 []-> case Set.toList $ rc1 `Set.intersection` lc2 of []->g -- 我 f2 в f1 res -> foldIntersection res id res -> foldIntersection res 交换