帮助理解惰性代码中的奇怪行为

Question

我编写了一个生成平面图正交表示的程序。对于这项工作，我使用 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 也将其保留在循环InfoBS 列表中。这些边需要函数 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 图 =.... 它要求具有 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 

Answer 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...