我编写了一个程序，用于生成平面图的正交表示。对于这项工作，我使用GHC 6.10.1。我的代码基于FGL库。它用于保持图形结构。
最近我发现了一个我无法解释的错误。如果删除我的程序的上下文作业，那么：
main = let g = insEdge (0,1,()) $ buildGr [ ([], 0, (), []), ([], 1, (), []) ]
g' = delEdge (0,1) g
in if 1 `elem` suc g 0
then putStrLn "OK"
else putStrLn "ERROR "
此程序必须打印“OK”，但结果为“ERROR”
这里更详细。 函数prepareData有一个带帮助边的图形。 Data BlockScheme还将它们保存在列表cyclesInfoBS中。这些边需要函数dualGraph的算法。
函数prepareG从删除这些边的一个构建新图。 并且embeddedBSG变量的值必须在任何地方都相同。
但是当dualGraph工作时会发生错误。跟踪里面说图形没有得到帮助边缘（2,1）但是在调用dualGraph之前它的图形参数有帮助边缘。 dualGraph的模块既没有delEdge也没有delEdge，也没有delNodes和delNode，也没有调用执行此操作的函数。 dualGraph的模块只读取图形变量。
如果评论代码删除了帮助边缘，那么它们就会停留。
dualGraph之前的图形状态：
__+embeddedBSG =
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个传出边缘，或者它是汇聚节点。在这种情况下，汇聚节点为1。
然后可以假设lSortSuc在某个地方被称为图形而没有节点2的帮助边缘。但事实并非如此。
有人有什么想法吗？我该怎么办？
type BlockSchemeGraph = Gr NodeLabel ()
data CycleInfo =
CycleInfo {
reversedEdge :: Edge ,
helpEdge :: Edge
} deriving (Show, Eq)
data BlockScheme = BlockScheme { graphBS :: BlockSchemeGraph,
cyclesInfoBS :: [ CycleInfo ],
generalSchemeOptionsBS :: (),
backBonesBS :: [ [ Node ] ]
} deriving (Show, Eq)
prepareData bs =
let bsg = graphBS bs
[ sink, source ] = map head $ pam bsg [ getSinks, getSources ]
[ helpNode ] = newNodes 1 bsg
helpEdges = [ (source,helpNode), (helpNode, sink) ]
bsg' = insEdges [ (a,b, ()) | (a,b) (l, 0.0) )
-- here help edges are deleted
$ foldr (\cinf g -> delEdge (helpEdge cinf) g)
(trace ("\n\nembG = " ++ show embG) embG)
cyclesInfo
f (v, height) g =
let fsuc (w, (order, weight)) g =
setELabel' (v,w) (order, weight + height/2) g
fpre (w, (order, weight)) g =
setELabel' (w,v) (order, weight + height/2) g
g' = foldr fsuc g $ lsuc g v
in foldr fpre g' $ lpre g' v
in emap (\(order, weight) -> (order, {-round-} weight))
. foldr f embG'
. map (\n -> (n, snd . sizeLabel $ getVLabel n embG))
$ nodes embG
-----------------------------------------------------------------------
{-# LANGUAGE ScopedTypeVariables #-}
module GraphVisualiser
#if defined(MYDEBUG)
#else
(visualiseScheme, BlockSchemeImage )
#endif
where
import SimpleUtil (map2,swap,pam, vopt, compareDouble)
import Data.Maybe (fromJust,isJust)
import Data.List (foldl',find, nubBy, deleteFirstsBy, maximumBy)
import qualified Data.Map as Map
import SchemeCompiler
import InductivePlus
import GraphEmbedder
import DualGraph
import TopologicalNumbering
import Text.Printf (printf)
import Debug.Trace
type NodePosition = (Double,Double)
type EdgePosition = [ NodePosition ]
type BSIG = Gr (NodePosition, NodeLabel) EdgePosition
newtype BlockSchemeImage = BlkScmImg BSIG deriving Eq
getWeight = fst
visualiseScheme :: BlockScheme -> BlockSchemeImage
visualiseScheme 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
in BlkScmImg g' -- -- calcedEdges
calcXForBackBone (numEmbBsg, numDualBsg, emf, nmf) idsOfNodes =
--
let (_, (xleft, xright) ) =
maximumBy (\ (v1, (xleft1, xright1) ) (v2, (xleft2, xright2) ) ->
compare (xright1 - xleft1) (xright2 - xleft2) )
$ map (\ v -> (v, fidsToWeights numDualBsg $ Map.lookup v nmf ))
idsOfNodes
in ( (xright + xleft) / 2.0 , idsOfNodes )
-- g :: Gr (NodePosition, NodeLabel) [ NodePositions ]
reverseFeedBacks g cyclesInfo = foldr fEdge g cyclesInfo
where fEdge cinfo g =
let elbl = getELabel e g
e = reversedEdge cinfo
(v,w) = e
g' = delEdge e g
in insEdge (w,v, reverse elbl) g'
calcEdgePositions numEmbBsg numDualBsg nmf emf source sink calcedNodes backBones =
let fEdge e@(v,w) g =
let xOfe = case find (\ (x, lst) ->
if v `elem` lst && w `elem` lst
then True
else False
) backBones of
Nothing -> halfSumEdge numDualBsg emf e
Just (x,_) -> x
[startY, endY] = map (\n -> getWeight $ getVLabel n numEmbBsg) [ v, w ]
coords = [ (xOfe, startY), (xOfe, endY) ]
g' = setELabel' (v,w) coords g
in trace ( "\n\ncoords = " ++ show coords ++ "\ncalc edge " ++ show (v,w) ++ "\nemf = "
++ show emf ++ "\nnmf = " ++ show nmf
++ "\nnumDualBsg = " ++ show numDualBsg
++ "\nnumEmbBsg = " ++ show numEmbBsg)
g'
outEdgesOfSource = map fst $ lSortSuc numEmbBsg source
inEdgesOfSink = map fst $ lSortPre numEmbBsg sink
fixFouthEdgeLbl v lst yModifier g =
case lst of
[ _ ] -> g
[ _, _ ] -> (trace "\nFixFouth\n" g)
[ _, _, _ ] -> g
[ _, _, _, w ] ->
let [ (x1,y1), p2 ] = getELabel (v,w) g
(xv, yv) = fst $ getVLabel v g
in setELabel' (v,w)
[ (xv, yModifier y1 ), (x1, yModifier y1 ), p2 ]
g
_ -> error $ "visualiseScheme.fixFouthEdgeLbl: lst has more than 4 edges!!!\n"
++ show lst
calcedUsualEdges = foldr fEdge
calcedNodes
$ edges calcedNodes
calcedAll = fixFouthEdgeLbl sink inEdgesOfSink (+1)
$ fixFouthEdgeLbl source outEdgesOfSource (\a -> a - 1) calcedUsualEdges
in trace ("\ncalcedAll = " ++ show calcedAll) calcedAll
scaleGraph g =
let
factor = 3.0
marginLT = 10
modifyCoord = (marginLT + ) . (*factor) -- marginLeft и marginTop
modifyCoords a = map2 modifyCoord . vopt (-) a $ minCoordinates g
in emap (map modifyCoords)
$ nmap (\(coords, lbl) -> (modifyCoords coords, lbl) )
g
prepareData bs =
let bsg = graphBS bs
[ sink, source ] = map head $ pam bsg [ getSinks, getSources ]
[ helpNode ] = 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)
cyclesInfo
f (v, height) g =
let fsuc (w, (order, weight)) g =
setELabel' (v,w) (order, weight + height/2) g
fpre (w, (order, weight)) g =
setELabel' (w,v) (order, weight + height/2) g
g' = foldr fsuc g $ lsuc g v
in foldr fpre g' $ lpre g' v
in emap (\(order, weight) -> (order, {-round-} weight))
. foldr f embG'
. map (\n -> (n, snd . sizeLabel $ getVLabel n embG))
$ nodes embG
prepareDualG dg g =
let dg' = emap (\lbl -> (lbl, 0.0)) dg
widthElement v sucOrPre =
let width = fst . sizeLabel $ getVLabel v g
in width / (fromIntegral . length $ sucOrPre g v)
-- node is face
fNodes v (dg :: Gr Face (Edge, Double) )=
let fEdge (w, (orig@(origV, origW), weight)) dg =
let wV = widthElement origV lsuc
wW = widthElement origW lpre
in setELabel' (v,w) (orig, weight + wV + wW) dg
outgoing :: [ (Node, (Edge, Double)) ]
outgoing = lsuc dg v
in foldr fEdge dg outgoing
in emap (\(e, weight) -> (e, {-round-} weight))
. foldr fNodes dg'
$ nodes dg
calcNodePositions numEmbBsg numDualBsg nmf emf source sink backBones {- :: [ (Double, [ Node ] ) -} =
let fNode v (g :: Gr (NodePosition, NodeLabel) [ NodePosition ] ) =
if v == source -- s
then calcSorT v id g lSortSuc numEmbBsg numDualBsg emf backBones
else if v == sink -- t
then calcSorT v swap g lSortPre numEmbBsg numDualBsg emf backBones
else let vlbl = getVLabel v numEmbBsg
xCoord = case find (\ (x, lst) ->
if v `elem` lst
then True
else False
) backBones of
Nothing -> halfSumNode numDualBsg nmf v
Just (x,_) -> x
in setVLabel' v ((xCoord, getWeight vlbl ), snd vlbl) g
g' :: Gr (NodePosition, NodeLabel) [ NodePosition ]
g' = emap (\_ -> [] ) $ nmap (\(weight, lbl) -> ((0.0,0.0), lbl))
numEmbBsg
result :: Gr (NodePosition, NodeLabel) [ NodePosition ]
result = foldr fNode
g'
$ nodes numEmbBsg
in result
calcSorT v selector (g :: Gr (NodePosition, NodeLabel) [ NodePosition ] ) edgeSelector numEmbBsg numDualBsg emf backBones =
let calcSTDegree4 w =
let (weight , vlbl) = getVLabel v numEmbBsg
in setVLabel' v ((halfSumEdge numDualBsg emf $ selector (v,w) ,
weight ),
vlbl )
g
in case map fst $ edgeSelector numEmbBsg v of
[ ] -> error $ "calcSorT: node " ++ show v
++ " hasn't got any suc edges!\nGraph:\n" ++ show g
++ "\nnumEmbBsg = \n" ++ show numEmbBsg
[ w ] -> let (weight, vlbl) = getVLabel v numEmbBsg
xCoord = case find (\ (x, lst) ->
if v `elem` lst
then True
else False
) backBones of
Nothing -> halfSumEdge numDualBsg emf $ selector (v,w)
-----halfSumNode numDualBsg nmf v
Just (x,_) -> x
in setVLabel' v ((xCoord , weight), vlbl)
g
[ w1, _ ] -> let (weight , vlbl) = getVLabel v numEmbBsg
in setVLabel' v (( snd . fidsToWeights numDualBsg
$ Map.lookup (selector (v, w1)) emf,
weight),
vlbl
)
g
[ _, w, _ ] -> calcSTDegree4 w
[ _, w, _, _ ] -> calcSTDegree4 w
moreEdges -> error $ "calcSorT: node " ++ show v ++ "has got too may edges!:\n"
++ show moreEdges ++ "\nGraph:" ++ show g
++ "\nnumEmbBsg = " ++ show numEmbBsg
--- fidsToWeights :: Maybe EdgeFaces -> NodePosition
fidsToWeights numDualBsg = map2 (\fid -> getWeight $ getVLabel fid numDualBsg) . fromJust
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
-----------------------------------------------------------------------
module DualGraph
#if defined(MYDEBUG)
#else
(dualGraph, Face(..), leftFace, rightFace, FaceId, EdgeFaces, EdgeMapFaces,NodeMapFaces, DualGraph, lSortSuc, lSortPre)
#endif
where
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Maybe (fromJust,isJust)
import SimpleUtil (apa,swap,map2)
import Data.List (foldl', sortBy, find)
import InductivePlus
import GraphEmbedder
import Debug.Trace
type FaceId = Int
type EdgeFaces = (FaceId, FaceId)
type EdgeMapFaces = Map.Map Edge EdgeFaces
type NodeMapFaces = Map.Map Node EdgeFaces
leftFace :: EdgeFaces -> FaceId
leftFace = fst
rightFace :: EdgeFaces -> FaceId
rightFace = snd
data Face = Face { sourceNode, sinkNode :: Node,
leftContour, rightContour :: Set.Set Edge --- [ Node ],
} |
OuterFace {
leftContour, rightContour :: Set.Set Edge --- [ Node ],
} deriving (Show, Eq)
nodePathToEdgePath :: Ord a => [ a ] -> Set.Set (a,a)
nodePathToEdgePath (h:rest) = Set.fromList . snd
$ foldl' (\ (current,result) next ->
(next, (current, next) : result))
(h, [])
rest
newFace src leftC rightC =
Face { sourceNode = src,
sinkNode = last leftC,
leftContour = nodePathToEdgePath $ src : leftC,
rightContour = nodePathToEdgePath $ src : rightC -- ,
}
newOuterFace embG edgeSelector slotModifier =
case filter (\v -> null $ lpre embG v) $ nodes embG of
[] -> error $ "newOuterFace: the graph hasn't got any source vertex\n"
++ show embG
[ v ] -> slotModifier emptyOuterFace
. nodePathToEdgePath
$ findContour v
sourceVertexes ->
error $ "newOuterFace: the graph has got more than one source vertex:"
++ show sourceVertexes
++ "\nThe Graph:\n" ++ show embG
where
emptyOuterFace = OuterFace { leftContour = Set.empty,
rightContour = Set.empty
}
findContour v =
case lSortSuc embG v of
[] -> [ v ]
someEdges -> v : (findContour . fst $ edgeSelector someEdges )
setRightContour face con = face { rightContour = con }
setLeftContour face con = face { leftContour = con }
type DualGraph = Gr Face Edge
dualGraph :: BlockSchemeEmbeddedGraph -> (DualGraph, EdgeMapFaces, NodeMapFaces)
checkm msg g = if 1 `notElem` suc g 2
then error $ "\ncheckm: " ++ msg ++ "\nthe G = " ++ show g
else trace ( "\n\nsuc g 2 = " ++ show (suc g 2) ) g
dualGraph embGr =
let embG = checkm "dualGraph: " embGr
usualFaces = snd . foldr (findFaces embG)
(2, buildGr [] ) --- Map.empty)
$ nodes embG
sFace = newOuterFace embG head setRightContour
tFace = newOuterFace embG last setLeftContour
allFaces = insNodes [ (0,sFace), (1,tFace) ] usualFaces
allNodes = map (\n -> (n, getVLabel n allFaces))
$ nodes allFaces
linkedFaces = foldr linkage
allFaces
[ (f1, f2) | f1@(fid1,_) fid1
]
emf = foldr (\(fid,f) m -> let comb fun conSel m = Set.fold (\e m -> Map.insertWith fun
e
(fid,fid)
m)
m
$ conSel f
in comb (\ (_,r) (l,_) -> (l,r) )
leftContour
$ comb (\ (l,_) (_,r) -> (l,r) )
rightContour
m
)
Map.empty
allNodes
fNMF n m = let (lFace,rFace) = case lSortSuc embG n of
[] -> let ls = lSortPre embG n
lFace = leftFace
. fromJust
$ Map.lookup (fst $ head ls, n) -- last ls, n)
emf
rFace = rightFace
. fromJust
$ Map.lookup (fst $ last ls, n) -- head ls, n)
emf
in (lFace, rFace)
ls -> let lFace = leftFace
. fromJust
$ Map.lookup (n, fst $ head ls)
emf
rFace = rightFace
. fromJust
$ Map.lookup (n, fst $ last ls)
emf
in (lFace, rFace)
in Map.insert n (lFace, rFace) m
nmf = foldr fNMF Map.empty $ nodes embG
in trace ("\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 -- вершина не может образовать грань
[_] -> st
(firstOut:outgoing) -> snd $ foldl' (findFace embG v)
(firstOut,st)
outgoing
data EdgeType = InEdge | OutEdge deriving (Show,Eq)
lSortEdges gren v =
let g = trace ("\nlSortEdges: g = " ++ show gren) (checkm ("lSortEdges: v = " ++ show v )gren)
getEdgeNumber (OutEdge, (_, (n,_))) = n
getEdgeNumber (InEdge, (_, (_,n))) = n
oute = lsuc g v
ine = lpre g v
allEdges = sortBy (apa compare getEdgeNumber)
$ concat [ map (\lbl -> (OutEdge, lbl) ) oute,
map (\lbl -> (InEdge, lbl) ) ine ]
cAllEdges = cycle allEdges
zeroEdge = head (trace ("allEdges: = " ++ show allEdges) allEdges)
spanE e = span ((e ==) . fst)
outEdges = case fst zeroEdge of
OutEdge -> fst . spanE OutEdge
. snd . spanE InEdge
. snd $ spanE OutEdge cAllEdges
_ -> fst . spanE OutEdge . snd $ spanE InEdge cAllEdges
inEdges = case fst zeroEdge of
InEdge -> fst . spanE InEdge
. snd . spanE OutEdge
. snd $ spanE InEdge cAllEdges
_ -> fst . spanE InEdge . snd $ spanE OutEdge cAllEdges
in if null ine || null oute
then let [ sv ] = getSources g
findContour prew w =
if w /= v
then findContour (Just w) . fst . head $ (trace ("\n\nlSortSuc g w = " ++ show w
++ " lsortSuc = " ++ show (lSortSuc g w))
( lSortSuc g w ))
else prew
wOfFirstEdge = fromJust $ findContour Nothing sv
sine = sortBy (apa notCompare (snd . snd)) ine
(beforeW, withW) = span ((wOfFirstEdge /=) . fst) sine
in ( sortBy (apa compare (fst . snd)) oute,
withW ++ sortBy (apa compare (snd . snd)) beforeW
)
else map2 (map snd)
(outEdges, inEdges)
where notCompare a b = case compare a b of
EQ -> EQ
LT -> GT
GT -> LT
lSortPre g v = let res = snd $ lSortEdges g v in
trace ("\n\nlSortPre(" ++ show v ++ ") = " ++ show res) res
lSortSuc g v = let res = fst $ lSortEdges g v in
trace ("\n\nlSortSuc(" ++ show v ++ ", g= " ++ show g ++ ") = " ++ show res) res
findFace embG v (wi, st@ (freeFID, mf)) wj =
let findContour v w pStop selectEdge =
let preEdges = lSortPre (checkm ("findFace: v = " ++ show v ++ " wi = "
++ show wi ++ " v = " ++ show v
++ " w = " ++ show w ++ " wj = "
++ show wj) embG) w
sucEdges = lSortSuc embG w
nextW = selectEdge sucEdges
res = if null sucEdges || (not (null preEdges) && pStop v preEdges) -- w is t-node
then [ w ]
else w : findContour w nextW pStop selectEdge
in trace ("findContour: v = " ++ show v ++ " w = " ++ show w ++ " suc = " ++ show sucEdges ++ " pre = " ++ show preEdges )
res
leftCon = findContour v wi
(\v -> (v /= ) . fst . head ) -- last )
(fst . last)
rightCon = findContour v wj
(\v -> (v /=) . fst . last ) -- head )
(fst . head )
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
)
)
in trace ("\nfindFace: " ++ show res ) res
linkage ((fid1, f1), (fid2, f2)) g =
let getC f = (leftContour f, rightContour f)
[ (lc1, rc1), (lc2, rc2) ] = map getC [f1,f2]
foldIntersection res selector =
let (ff1, ff2) = selector (fid1, fid2) in
foldr (\e@(v,w) g -> insEdge (ff1,ff2,e) g )
g
res
in case Set.toList $ lc1 `Set.intersection` rc2 of
[] ->
case Set.toList $ rc1 `Set.intersection` lc2 of
[] -> g
-- из f2 в f1
res -> foldIntersection res id
res -> foldIntersection res swap
答案 0 :(得分：1)
在你的例子中：
main = let g = insEdge (0,1,()) $ buildGr [ ([], 0, (), []), ([], 1, (), []) ]
g' = delEdge (0,1) g
in if 1 `elem` suc g 0
then putStrLn "OK"
else putStrLn "ERROR "
从不使用变量g'。表达式suc g 0应该是suc g' 0吗？在我看来，这应该打印OK ...