Я пишу программу, которая генерирует ортогональное представление плоского графа.Для этой работы я использую 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 "
Эта программа должна вывести «ОК», но результат «ОШИБКА»
Здесь более подробно.Функция prepareData получает граф с помощью ребер.Блок данных DataScheme также хранит их в списке cycInfoBS.Для этих ребер необходим алгоритм функции dualGraph.
Функция prepareG строит новый граф из одного удаления этих ребер.И значение встроенной переменнойBSG должно быть везде одинаковым.
Но при работе 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 второго состояния не имеет исходящих ребер.
Есть место, где обнаруживается ошибка функции lSortSuc в DualGraph.
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