I write a program which generate orthogonal representation of a planar graph. For this job I use GHC 6.10.1. My code bases on FGL library. It uses to keep a graph structure.
Recently I have found an error which I can't explain. If drop the context job of my program then:
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 "
This program must print "OK" but the result is "ERROR"
Here is more detailed. Function prepareData is got a graph with help edges. Data BlockScheme also keeps theirs in the list cyclesInfoBS. Theses edges are required an algorithm of the function dualGraph.
Function prepareG builds new graph from one deleting these edges. And a value of the embeddedBSG variable must be same everywhere.
But an error occurs when dualGraph works. Tracing inside says that the graph hasn't got help edge (2,1) but before call of dualGraph its graph argument has got help edges. dualGraph's module hasn't got neither delEdge nor delEdge nor delNodes nor delNode and doesn't call a function which were to do this. dualGraph's module only reads the graph variable.
If comment code deleting help edges then they stay.
the state of the graph before 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)]
the state of the graph into DualGraph module:
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)))]
Node 2 of second state hasn't got any outgoing edges.
There is a place where the error is detected function lSortSuc in DualGraph.
lSortSuc vertexId graph =.... It requires vertex with vertexId has got at least 1 incoming edge and 1 outgoing one or it is sink node. The sink node is 1 in this case.
Then It can suppose lSortSuc is called somewhere yet for graph without help edges for node 2. But it isn't true.
Does anybody have any ideas? What can I do?
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
