-- (c) 2010 by Daneel S. Yaitskov
-- | Graph embedding algorithm is based on one of a graph planarity testing which 
--   described in the book \"Graph Drawing. Algorithms for the Visualization of Graphs\".
--   Its authors are Giuseppe Di Battista, Peter Eades, Roberto Tamassia and Ioannis G. Tollis.

module Data.Graph.Embedding (embedGraph,embedDiGraph) where
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.List (partition, sortBy, union, foldl', (\\), sort, find, nub)
import Data.Maybe (fromJust,isJust)
import Data.Graph.SimpleUtil (takeAfter, takeBefore, map2, apa)
import Control.Monad.State (get, put, execState,State)

import Data.Graph.InductivePlus
import Data.Graph.Analysis.Algorithms 

data EdgeLabel = StubLabel |
                 FreeEdge EdgeLabel |
                 FixedEdge EdgeLabel |
                 PieceOrder (Maybe PieceId) Int 
                            EdgeLabel deriving (Show, Eq)


isFreeELabel (FixedEdge _) = False
isFreeELabel _ = True
lastNumLabel (FixedEdge rest) = lastNumLabel rest
lastNumLabel (FreeEdge rest ) = lastNumLabel rest
lastNumLabel StubLabel = Nothing
lastNumLabel (PieceOrder _ n _) = Just n

continueLabel mayPid pos lbl@(FixedEdge rest) =
 error $ "continueLabel: try to continue fixed edge label\npos = " ++  show pos
         ++ "\nlbl = " ++ show lbl
continueLabel mayPid pos lbl@(FreeEdge rest) = FreeEdge $ PieceOrder mayPid pos rest

continueLabel mayPid pos lbl = FreeEdge $ PieceOrder mayPid pos lbl

fixELabel mayPid pos lbl =
  case continueLabel mayPid pos lbl of
   FreeEdge lbl -> FixedEdge lbl
   StubLabel -> FixedEdge StubLabel
   _ -> error "fixELabel: COOL!"
   
edgeLabelToList StubLabel = []

edgeLabelToList lbl@(FreeEdge _) =
  error $ "edgeLabelToList: convertation is impossible cause the edge label is free: "
          ++ show lbl
edgeLabelToList (FixedEdge rest) = reverse $ edgeLabelToList rest
edgeLabelToList (PieceOrder _ pos rest) = pos : edgeLabelToList rest 

instance Ord EdgeLabel where
 compare l1 l2 =
  let (ll1,ll2) = map2 edgeLabelToList (l1,l2) in
      compare ll1 ll2

type MyInGr = Gr () EdgeLabel

data OldC = OldC { oldCAsSet :: Set.Set Node,
                   oldCAsList :: [ Node ]
                 } deriving (Show, Eq)
data C = C { cAsList :: [ Node ],
             cAsSet  :: Set.Set Node,
             oldCC :: Maybe OldC
           } deriving (Show,Eq)

hasOldC c = isJust $ oldCC c           

newC c = C { cAsList = c,
             cAsSet = Set.fromList c,
             oldCC  = Nothing
           }

data Side = Inside | Outside deriving (Show,Eq)
notSide Inside = Outside
notSide Outside = Inside

type LegOfPiece =  Set.Set Node {- ws \not \in C -}

data Piece = Piece { pieceAsSubgraph  :: MyInGr,
                     nodesAlsoInC  :: Set.Set Node,
                     sideOfpiece :: Side,
                     legsOfpiece :: Map.Map Node {- v \in C -} LegOfPiece } deriving (Show,Eq)

instance Ord Piece where
 p1 > p2 = (sort . edges $ pieceAsSubgraph p1) > (sort . edges $ pieceAsSubgraph p2) 
 p1 < p2 = (sort . edges $ pieceAsSubgraph p1) < (sort . edges $ pieceAsSubgraph p2)  
 p1 >= p2 = p1 > p2 || p1 == p2
 p1 <= p2 = p1 < p2 || p1 == p2

type Pieces = [ Piece ]
type PieceId = Int
type MapPieces = Map.Map PieceId Piece

type EdgeMapPiece = Map.Map (Node{- v \in C -},Node {- w \not \in C -}) PieceId
type VertexMapPiece = Map.Map Node (Set.Set PieceId)
emptyPiece = Piece { pieceAsSubgraph = buildGr [],
                     nodesAlsoInC = Set.empty,
                     sideOfpiece = Inside,
                     legsOfpiece = Map.empty }
{-|
  The 'embedGraph' function embeds a planar biconnected undirected graph into a plane.  
  Edge's label of an embedded graph is a position of the edge in its source node.

  In undirected graph each edge is presented a pair of directed edges. Therefore
  it's enough each edge keeps only its position in the source node.

-}
embedGraph :: Gr a b -> Gr a  Int
embedGraph g =
 let ug = nmap (\_ -> () ) $ emap (\_ -> StubLabel) g
     firstC = snd . head . filter (\x -> fst x > 2 ) . map (\xc -> (length xc, xc) ) $ cyclesIn' ug
     c = newC firstC
  in extractGraph g $ execState (embedWithC c Nothing Nothing Nothing) ug
{-|
 The 'embedDiGraph' function embeds a planar directed graph into a plane. The source graph 
 must be biconnected if throw off edges' directions and also any two nodes v and w can have 
 either edge (v,w) or (w,v) but not both.

 Edge's label of an embedded graph consists of a pair integers. First element is a position 
 of the edge in its source node and second one is a position of the edge in its destination node.
-}
embedDiGraph :: Gr a b -> Gr a  (Int,Int)
embedDiGraph g =
 let ug = nmap (\_ -> () ) $ emap (\_ -> StubLabel) g
     ulg =  undir ug
     firstC = snd . head . filter (\x -> fst x > 2 ) . map (\xc -> (length xc, xc) ) $ cyclesIn' ulg
     c = newC firstC
  in orientGraph g $ execState (embedWithC c Nothing Nothing Nothing) ulg
  
embedWithC :: C -> Maybe VertexMapPiece -> Maybe EdgeMapPiece -> Maybe MapPieces -> State MyInGr ()
embedWithC c oldVmp oldEmp oldMp =
 do g <- get 
    let mp = fst $ findPiecesWithC c g 
        emp =  makeEMP mp 
        vmp =  makeVMP mp
        groupedMP = groupPieces c mp g (fromJust oldMp) 
                                       (fromJust oldVmp)
                                       (fromJust oldEmp)
        (g', mp') = foldr (\vinc (g,mp) -> orderEdgesOfNode vinc
                                                            c
                                                            g
                                                            mp
                                                            vmp emp
                                                            oldEmp oldMp)
                          (g,groupedMP)
                          $ cAsList c

        (pathPieces,otherPieces) = Map.partition isPath mp'
        g'' = Map.foldWithKey orderPathPiece g' pathPieces
        cg0 = delNodes (nodes g'' \\ cAsList c) g''

        cg  = Map.fold (\p cg ->
                           case Set.toList $ nodesAlsoInC p of
                             [a,b] -> delEdges [ (a,b), (b,a) ] cg
                             _ -> cg 
                       )
                       cg0 pathPieces

        lstOtherPieces = map snd $ Map.toList otherPieces
     in put g'' >>
        mapM_ (\p_i -> get >>= \gx -> let p = mergeTwoGraphs cg $ pieceAsSubgraph p_i
                                          c' = genNextC c p_i
                                       in do put p
                                             embedWithC c' (Just vmp) (Just emp) (Just mp' ) 
                                             p' <- get
                                             put $ patchEdgesGraph gx p' p_i )
              lstOtherPieces

isPath p = let subg = pieceAsSubgraph p
               outN = nodesAlsoInC p
               pre v = outdeg subg v == 1
               [ firstOut, secondOut ] = Set.toList outN
               numEqDeg2 = foldr (\v n -> if outdeg subg v == 2
                                               then n + 1
                                               else n)
                                   0
                                   $ nodes subg
            in Set.size outN == 2 &&
               pre firstOut &&
               pre secondOut &&
               numEqDeg2 == length (nodes subg) - 2 


findPiecesWithC :: C -> MyInGr -> ( MapPieces, MyInGr )
findPiecesWithC c g =
 let findPiece' v s@(mapPieces, g, freePID)  =
       let subgOfv = buildGr [ ([], v, (), []) ]
           newp = emptyPiece { pieceAsSubgraph = subgOfv }
           (newPiece, g') = execState (findPiece v c) ( newp, g )
        in if v `gelem` g 
              then (Map.insert freePID newPiece mapPieces, g', freePID + 1)
              else s 
     allNeighbours = foldr (\vinc an  ->  an `union`  neighboursOfCV vinc )
                           []
                           $ cAsList c
     neighboursOfCV vinc =  suc g vinc  \\ cAsList c
  in findPathPiecesWithC c $ foldr findPiece' (Map.empty, g, 0) allNeighbours 


findPathPiecesWithC :: C -> (MapPieces, MyInGr, PieceId)  -> (MapPieces, MyInGr)
findPathPiecesWithC c (mp, g, freePID) =
 let findEdgePiece vinc (mp, g, freePID) =
      let wa = fromJust $ takeAfter vinc $ cAsList c
          wb = fromJust $ takeBefore vinc $ cAsList c
          edgePieces = suc g vinc \\ [wa, wb]
          g' = foldr (\w g -> delUEdge (vinc,w) g) g edgePieces
          buildPiece w (mp,freePID) =
           let freePID' = freePID + 1
               legs = map Set.fromList [ [ w ], [ vinc ] ]
               subG = insEdges [ (w,vinc, getELabel (w,vinc) g),
                                 (vinc,w, getELabel (vinc,w) g) ] .
                      insNodes [ (w,()), (vinc, ()) ] $
                      buildGr []
               newPiece =
                 Piece { pieceAsSubgraph = subG,
                         nodesAlsoInC = Set.fromList [ w, vinc],
                         sideOfpiece  = Inside,
                         legsOfpiece  = Map.fromList $ zip [vinc, w] legs
                       }
            in (Map.insert freePID newPiece mp, freePID')      
          (mp',freePID') = foldr buildPiece
                                 (mp,freePID) edgePieces
       in (mp', g', freePID')
     (mp', g', _) = foldr findEdgePiece 
                          (mp, g, freePID)
                          $ cAsList c
  in (mp', g')

findPiece :: Node -> C -> State (Piece, MyInGr) ()
findPiece v c  = 
 do (p,g) <- get
    let nei = suc g v
        (inC, g') = if v `Set.member` cAsSet c
                       then (True, g)
                       else (False, delNode v g)
        p' = insertIntoPiece v c inC p nei g
     in if v `gelem` g 
              then do put ( p',g') 
                      if inC  
                         then return ()
                         else mapM_ (\v -> findPiece v c ) nei
              else return ()

insertIntoPiece :: Node -> C -> Bool -> Piece -> [ Node ] -> MyInGr -> Piece
insertIntoPiece v c inC p nei g =
 let p' = 
      if inC
         then p { nodesAlsoInC = Set.insert v $ nodesAlsoInC p }
         else let fNei wNei legs = 
                   if wNei `Set.member` cAsSet c
                      then case Map.lookup wNei legs of
                             Nothing ->
                              Map.insert wNei
                                         (Set.singleton  v)
                                         legs
                             Just leg ->
                              Map.insert wNei
                                         (Set.insert v leg)
                                         legs
                      else legs
               in p { legsOfpiece = foldr fNei
                                          (legsOfpiece p)
                                          nei  }
     newNei = filter (\n -> not (n `gelem` pieceAsSubgraph p')) nei                                  
     nei'  = zip newNei $ cycle [ () ]
     ls    = map (\(w,l) -> (v,w,l) ) $ lsuc g v
     lp    = map (\(w,l) -> (w, v, l) ) $ lpre g v
     subg' = insEdges ls . insEdges lp . insNodes nei' $ pieceAsSubgraph p'
  in if inC
        then p' 
        else p' { pieceAsSubgraph = subg' }
        
type PieceAndS = (Bool, PieceId, Piece, [ Set.Set Node ])
groupPieces :: C -> MapPieces -> MyInGr -> MapPieces -> VertexMapPiece -> EdgeMapPiece -> MapPieces
groupPieces c mp g oldMp oldVmp oldEmp =
 let (freePieces, fixedPieces) = Map.partition (isFreePiece c) mp     
     (fixedInside, fixedOutside, mp') = Map.foldWithKey (detectSideOfFixedPiece oldMp oldEmp oldVmp g c)
                                                        (Map.empty, Map.empty, mp)
                                                        fixedPieces
     (fixI, fixO ) = map2 (map snd . Map.toList . Map.mapWithKey (\k p -> (True, k, p, getS p c)))
                          (fixedInside, fixedOutside)
     freP = Map.mapWithKey (\k p -> (False, k, p, getS p c)) freePieces
     (_,_,res) = Map.foldWithKey (arrangePiece fixI fixO ) ([], [], mp') freP
  in res
 where
  arrangePiece :: [PieceAndS] -> [PieceAndS] -> PieceId -> PieceAndS ->
                  ([PieceAndS], [PieceAndS], MapPieces) ->
                  ([PieceAndS], [PieceAndS], MapPieces)
  arrangePiece fixedInside fixedOutside
               pid ps@(isFree,_,p,s)
               (inside, outside, mp) =
   let allOutside = fixedOutside ++ outside
       allInside = fixedInside ++ inside
    in case interlaced' ps fixedInside of
        ([],_) ->
         case interlaced' ps inside of
            ([],_) -> usualResult Inside mp
            (psInterIn,notInterIn) ->
             case interlaced' ps fixedOutside of
              ([],_) ->
                case interlaced' ps outside of
                 ([], _) -> usualResult Outside mp
                 (psInterOut,notInterOut) ->
                   if any (\psiin -> any (interlaced psiin) allOutside) psInterIn
                      then if any (\psio -> any (interlaced psio) allInside) psInterOut
                              then errGraphIsntPlanar "psInterOut interlaced with inside and vice versa"
                              else fixToInSide mp psInterOut notInterOut
                      else fixToOutSide mp psInterIn notInterIn
              (conFixOut,_) ->
               if any (\psiin -> any (interlaced psiin) allOutside ) psInterIn
                  then errGraphIsntPlanar "psInterIn interlaced with allOutside and the piece interlaced with conFixOut"
                  else fixToOutSide mp psInterIn notInterIn
        (conFixIn,_) ->
          case interlaced' ps fixedOutside of
           ([],_) ->
             case interlaced' ps outside of
              ([], _) -> usualResult Outside mp
              (psInterOut,notInterOut) ->
                if any (\psio -> any (interlaced psio) allInside) psInterOut
                   then errGraphIsntPlanar "psInterOut interlace with allInside and the piece interlace with conFixIn"
                   else fixToInSide mp psInterOut notInterOut
           (conFixOut,_) -> errGraphIsntPlanar "both side consist confliting fixed pieces"
   where
    errGraphIsntPlanar msg =
     error ( "arrangePiece: The graph isn't a planar. " ++
             "I can't arrange a piece:\n" ++
             "Conflict pid " ++ show pid ++ "\npiece: " ++
             show p ++ "\nMessage: " ++ msg
           )
    setSide s mp = Map.insert pid p { sideOfpiece = s } mp
    usualResult side mp =
      case side of
        Inside ->  ( (isFree, pid, p, s) : inside,
                     outside,
                     setSide side mp
                   )
        Outside -> ( inside,
                     (isFree, pid, p, s) : outside,
                     setSide side mp
                   )
    fixToInSide mp psInterOut notInterOut = 
      (psInterOut ++ inside,
       (isFree, pid, p, s) : notInterOut,
       setSide Outside $ foldr (\(isFree, pid, p, s) mp ->
                                  Map.adjust (\p -> p { sideOfpiece = Inside } )
                                             pid
                                             mp)
                                mp
                                psInterOut)
    fixToOutSide mp psInterIn notInterIn =
     ( (isFree, pid, p, s) : notInterIn,
       psInterIn ++ outside,
       setSide Inside $ foldr (\(isFree, pid, p, s) mp ->
                                 Map.adjust (\p -> p { sideOfpiece = Outside } )
                                            pid
                                            mp)
                              mp
                              psInterIn)
  interlaced' :: PieceAndS -> [ PieceAndS ] -> ([ PieceAndS ],[ PieceAndS ]) 
  interlaced' ps xside = partition (interlaced ps) xside

isFreePiece c p =
 let outv = nodesAlsoInC p
     oldc = fromJust $ oldCC c
     cs = cAsSet c
     cl = cAsList c
     ocl = oldCAsList oldc
     ocs = oldCAsSet oldc
     gp = pieceAsSubgraph p
     shared = Set.toList $ ocs `Set.intersection` cs              
     a = fromJust $ find (\v -> apa (/=) (takeAfter v) ocl cl) shared
     b = fromJust $ find (\v -> apa (/=) (takeBefore v) ocl cl) shared     
     pre v =
       let lbls = map snd $ lsuc gp v
           testTP aorb = v == aorb && all isFreeELabel lbls
        in (v `Set.notMember` ocs)
           || testTP a
           || testTP b
  in if hasOldC c
        then all pre $ Set.toList outv
        else True 
        
detectSideOfFixedPiece :: MapPieces -> EdgeMapPiece -> VertexMapPiece ->
                          MyInGr -> C -> PieceId -> Piece ->
                          (MapPieces, MapPieces, MapPieces) ->
                          (MapPieces, MapPieces, MapPieces)
detectSideOfFixedPiece mp emp vmp 
                       g c kpid p (fixi, fixo, newMp) =
  let anodes = nodes $ pieceAsSubgraph p
      oc = fromJust $ oldCC c
      cs = cAsSet c
      cl = cAsList c
      ocl = oldCAsList oc
      ocs = oldCAsSet oc
      nodesInC = nodesAlsoInC p

      theSide = if all (`Set.member` ocs )  anodes 
                   then  
                    let [ outv1, outv2 ] = case  Set.toList $ nodesAlsoInC p of 
                                             [a,b] -> [a,b]
                                             _ -> error ("piece from oldc hasn't gon 2 outer vertexes\n"  ++ show p ++
                                                         "\n C = " ++ show c ++ "\n G = " ++  show g ++
                                                         "\n old mp = " ++ show mp ++ "\n"
                                                        )
                        [ piecesWithV1, piecesWithV2 ] = map (\v -> fromJust $ Map.lookup v vmp)
                                                             [ outv1, outv2 ]
                        maybePieces = piecesWithV1 `Set.union` piecesWithV2
                        nodesOfWantedPiece = Set.toList $ cAsSet c `Set.difference` ocs
                        thePid = head . Set.toList
                                        $ Set.filter (\pid ->
                                                        let p = fromJust $ Map.lookup pid mp
                                                            gofp = pieceAsSubgraph p
                                                         in all (`gelem` gofp) nodesOfWantedPiece
                                                     )
                                                     maybePieces
                        theP = fromJust $ Map.lookup thePid mp
                     in notSide $ sideOfpiece theP 
                   else let outv = head . Set.toList $ nodesAlsoInC p `Set.intersection` ocs
                            neiOutV = head . Set.toList . fromJust . Map.lookup outv $ legsOfpiece p
                            thePid = fromJust $ Map.lookup (outv, neiOutV) emp -- emp is old emp
                            piece = fromJust $ Map.lookup thePid mp -- mp is old mp
                         in sideOfpiece piece
      setS p = p { sideOfpiece = theSide }
      p' = setS p
   in case theSide of
           Inside -> (Map.insert kpid p' fixi, fixo, Map.adjust  setS kpid newMp)
           Outside -> (fixi, Map.insert kpid p' fixo, Map.adjust  setS kpid newMp)

interlaced :: PieceAndS -> PieceAndS -> Bool
interlaced (_,_,p1,s1) (_,_,p2,s2) =
 let a1 = nodesAlsoInC p1
  in all (\subs2 -> a1 `Set.intersection` subs2  /= a1 ) s2

getS :: Piece -> C -> [ Set.Set Node ]
getS p c = foldl' f [] c' 
  where  
    vinc = head . Set.toList $ nodesAlsoInC p
    (a,b) = span (vinc /= ) $ cAsList c 
    c' = b ++ a ++ [ head b ]
    f :: [ Set.Set Node ] -> Node -> [ Set.Set Node ]
    f l vinc = if vinc `Set.member` nodesAlsoInC p
                  then if null l
                          then [ Set.singleton vinc ]
                          else if vinc == head c'
                                  then (Set.insert vinc $ head l ) : tail l
                                  else Set.singleton vinc  : (Set.insert vinc $ head l ) : tail l
                  else if null l
                          then [ Set.singleton vinc ] 
                          else ( Set.insert vinc $ head l ) : tail l

patchEdgesGraph beingImprovedG (itsSubG :: MyInGr ) p_i =
 let allEdgesPI = concat $ map (\n -> map (\(w,l) -> (n,w,l) ) $ lsuc itsSubG n)  
                               (nodes $ pieceAsSubgraph p_i)
     fEdge  (v,w,l) g = setELabel' (v,w) l g
  in foldr fEdge beingImprovedG allEdgesPI

orientGraph :: Gr a b -> MyInGr -> Gr a (Int,Int)
orientGraph srcG  embeddedG =
 let srcG' = emap (\_ -> (0,0)) srcG
     conEdgeLabels v sg =
      let outgoing = map (\(w,l) -> (v,w,l) ) $ lsuc embeddedG v
          sortedOut= sortBy (\(_,_,l1) (_,_,l2) ->
                             if isFreeELabel l1 || isFreeELabel l2
                                then error $ "outgoing contains free edgelabel !outgoing = \n " ++ show outgoing
                                else compare l1 l2)
                            outgoing
          sout     = map (\(n, (v,w,_)) -> (n,v,w) ) $ zip [0..] sortedOut
       in foldr (\(n,v,w) sg -> case find ((w == ) . fst) $ lsuc sg v of
                                 Nothing -> case find ((v == ) . fst) $ lsuc sg w of
                                        Nothing -> error $ "orientGraph: can't find edge "
                                                            ++ show (v,w) ++ " or "
                                                            ++ show (w,v)
                                        Just (_,(right,_)) -> setELabel' (w,v) (right,n) sg
                                 Just (_,(_,back)) -> setELabel' (v,w) (n,back) sg
                )                                  
                sg
                sout
   in foldr conEdgeLabels srcG' $ nodes embeddedG

-- analog of orientGraph but for undirected graph
-- edge label of final graph is an position edge in set outgoing edges of the node
extractGraph :: Gr a b -> MyInGr -> Gr a Int
extractGraph srcG  embeddedG =
 let srcG' = emap (\_ -> 0) srcG
     conEdgeLabels v sg =
      let outgoing = map (\(w,l) -> (v,w,l) ) $ lsuc embeddedG v
          sortedOut= sortBy (\(_,_,l1) (_,_,l2) ->
                             if isFreeELabel l1 || isFreeELabel l2
                                then error $ "outgoing contains free edgelabel !outgoing = \n " ++ show outgoing
                                else compare l1 l2)
                            outgoing
          -- here is outging edges are ordered and are numbered
          sout     = map (\(n, (v,w,_)) -> (n,v,w) ) $ zip [0..] sortedOut
       in foldr (\(n,v,w) sg -> setELabel' (v,w) n sg )                                  
                sg
                sout
   in foldr conEdgeLabels srcG' $ nodes embeddedG

genNextC :: C -> Piece -> C
genNextC oldc p_i =
 let a = nodesAlsoInC p_i
     firstInA = head $ Set.toList a 
     (_, afterF)   = span (firstInA /= ) . cycle $ cAsList oldc
     (_, rest) = break ( `Set.member` a) $ tail afterF
     secondInA = head rest
     newPart = head . findPaths  firstInA secondInA $ pieceAsSubgraph p_i
     (leavingPart, _) = break ( == firstInA ) $ tail rest
     nc = ( firstInA : newPart ) ++ ( secondInA : leavingPart )
  in (newC nc) { oldCC = Just OldC { oldCAsSet = cAsSet oldc,
                                     oldCAsList = cAsList oldc
                                   }
               } 

orderPathPiece pid p g =
 let s = nodesAlsoInC p     
     procOneV v g =
      if v `Set.notMember` s 
         then let nei = zip [0..] $ suc g v in
                  foldr (\(n,w) g -> setELabel' (v,w)
                                                (FixedEdge . PieceOrder (Just pid) n $ StubLabel)
                                                g)
                        g nei
         else g     
  in foldr procOneV g . nodes $ pieceAsSubgraph p

orderEdgesOfNode :: Node -> C -> MyInGr ->
                    MapPieces -> VertexMapPiece ->
                    EdgeMapPiece -> Maybe EdgeMapPiece ->
                    Maybe MapPieces -> (MyInGr, MapPieces)
orderEdgesOfNode v c g mp vmp emp oldEmp oldMp =
 let cl = cAsList c
     allPiecesOfv = map (\pid -> (pid, fromJust $ Map.lookup pid mp) )
                              . Set.toList $ case Map.lookup v vmp of
                                                  Nothing -> Set.empty
                                                  Just x -> x
     apv = filter (\(_,p) -> any isFreeELabel
                                 . map snd
                                 $ lsuc (pieceAsSubgraph p) v
                  )
                  allPiecesOfv 
     (insidePieces,outsidePieces) =
       partition ((== Inside) . sideOfpiece . snd )
                 apv
     orderPieces pieces cmp =
        map (\((pid,p),_) -> (p, Just pid ))
            . sortBy cmp
              $ map (\p -> (p, distanceToNearestW v c $ snd p ))
                    pieces
     cmpOut a@((pida,pa),wa) b@((pidb, pb),wb) =
       case compare wb wa of
        EQ ->  let [ la, lb ] = map legsOfpiece [pa,pb]                   
                   [(w, sa), (_,sb) ] =  map (\legs -> if Map.size legs == 2
                                                          then head . Map.toList $ Map.delete v legs
                                                          else error $ "legs must be 2\nlegs = " ++ show legs)
                                             [la,lb]
                   checkEquality labels = if length ( nub labels ) == 1
                                             then labels
                                             else error $ "Labels aren't equal: " ++ show labels
                   [firstLbl , secondLbl ] = map (\s -> head
                                                          . checkEquality
                                                          . map (\wNei -> lastNumLabel $ getELabel (w, wNei ) g )
                                                          $  Set.toList s)
                                                  [sa,sb]
                in if apa (/=) Map.keys la lb
                      then error $ "embedGraphWithC: unknown state:\na = " ++ show a ++ "\nb = " ++  show b
                      else case compare secondLbl firstLbl  of
                                             LT -> GT 
                                             GT -> LT
                                             EQ -> EQ 
        other -> other
     outsidePieces' = orderPieces  outsidePieces cmpOut 
     insidePieces' = orderPieces   insidePieces  (flip cmpOut) 
     wBeforeV =  fromJust $ takeBefore v cl
     wAfterV = fromJust $ takeAfter v cl
     pieceBeforeV = emptyPiece { legsOfpiece = Map.singleton v $ Set.fromList [ wBeforeV ] }
     pieceAfterV =  emptyPiece { legsOfpiece = Map.singleton v $ Set.fromList [ wAfterV ] }
     lblBefore = getELabel (v, wBeforeV) g
     lblAfter =  getELabel (v,wAfterV) g
     lstt = let rest = concat [  outsidePieces',
                                 if isFreeELabel lblAfter
                                    then [ (pieceAfterV, Nothing) ]
                                    else [],
                                 insidePieces'
                              ]
             in if isFreeELabel lblBefore
                   then let omp = fromJust oldMp
                            oemp = fromJust oldEmp
                            previousPid = Map.lookup (v, wBeforeV) oemp
                            previousP = fromJust $ Map.lookup (fromJust previousPid)
                                                              omp
                            legOfv    = fromJust . Map.lookup v $ legsOfpiece previousP
                            (insidePieces'', togetherBefore) = span (\(p, _) -> all ( `Set.notMember` legOfv )
                                                                                    . nodes $ pieceAsSubgraph p)
                                                                    insidePieces'
                         in if isJust oldMp
                               && isJust previousPid
                               && v `Set.member` (oldCAsSet . fromJust $ oldCC c)
                               then concat [ togetherBefore,
                                             [ (pieceBeforeV, Nothing) ],
                                             outsidePieces',
                                             if isFreeELabel lblAfter
                                                then [ (pieceAfterV, Nothing) ]
                                                else [],
                                             insidePieces''
                                           ]
                                           
                               else (pieceBeforeV, Nothing) : rest
                   else rest
     apieces = zip [0..] lstt 
     markAllEdgesOfPiece (n,(p, mayPid)) (g,mp) =
      let neiNodesInP =  fromJust . Map.lookup v $ legsOfpiece p
          modGofP f mp pid  =
            Map.adjust (\p -> p { pieceAsSubgraph = f $ pieceAsSubgraph p })
                       pid
                       mp
       in if Set.size neiNodesInP  == 1
             then let w = head $ Set.toList neiNodesInP
                      vwlbl = getELabel (v,w) g
                      vwlbl' = fixELabel mayPid n vwlbl
                      modg g = setELabel' (v, w ) vwlbl' g
                   in (modg g,
                       maybe mp (modGofP modg mp) mayPid )
             else let markEdgeOfPiece w g =
                        let vwlbl = getELabel (v,w) g
                            vwlbl' = continueLabel mayPid n vwlbl
                         in setELabel' (v,w) vwlbl' g
                      modg g = Set.fold markEdgeOfPiece g  neiNodesInP
                   in (modg g,
                       maybe mp (modGofP modg mp) mayPid )
  in foldr markAllEdgesOfPiece (g,mp) apieces
     
distanceToNearestW v c p = 
    let (beforeV,vAndAfter)  =  span (v /= ) $ cAsList c
        c' = vAndAfter ++ beforeV
        outer = nodesAlsoInC p
     in map fst . filter ((`Set.member` outer) . snd) $ zip [ 0..] c'

makeEMP :: MapPieces -> EdgeMapPiece
makeEMP mp =
 let fPiece pid p emp = 
       let legs = legsOfpiece p
           fLeg v leg emp = Set.fold (\w emp -> Map.insert (v,w) pid emp)
                                     emp
                                     leg
        in Map.foldWithKey fLeg
                           emp
                           legs
  in Map.foldWithKey fPiece
                     Map.empty
                     mp

makeVMP :: MapPieces -> VertexMapPiece
makeVMP mp =
 let fPiece pid p vmp =
       let fVertex v vmp =
            let a = case Map.lookup v vmp of
                         Nothing ->  Set.singleton pid
                         Just s  ->  Set.insert pid s       
             in Map.insert v a vmp
        in Set.fold fVertex vmp $ nodesAlsoInC p
  in Map.foldWithKey fPiece
                     Map.empty
                     mp