我编写了一个程序,生成平面图的正交表示。对于这项工作,我使用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”,但结果是“错误”
这里更详细。
函数Preparedata得到一个带有帮助边缘的图。数据块方案还将它们保存在列表循环中。这些边缘需要一个函数双算法。
函数PrepareG从删除这些边的一条创建新的图表。
并且embeddedbsg变量的值在任何地方都必须相同。
但当双道图工作时,会出现一个错误。在图中跟踪表明图没有帮助边缘(2,1),但是在调用双algraph之前,它的图参数有帮助边缘。Dualgraph的模块既没有删除也没有删除,也没有delnode s和delnode,也没有调用要执行此操作的函数。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)]
进入双图表模块的图表状态:
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没有任何传出边缘。
在双algraph中有一个错误检测函数lsortsuc的位置。
lsortsuc VertexID图形=…
它要求顶点具有顶点,顶点至少有一个传入边缘和一个传出边缘,或者它是接收节点。在这种情况下,接收器节点是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
