layered-graph-drawing 0.1.0.0 → 0.2.0.0

raw patch · 5 files changed

+2172/−1679 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• app/Main.hs +1/−0
• layered-graph-drawing.cabal +7/−3
• src/Graph/CommonGraph.hs +125/−73
• src/Graph/GraphDrawing.hs +1645/−1463
• src/Graph/SubGraphWindows.hs +394/−140

@@ -205,6 +205,7 @@   deriving (Eq, Ord, Show, Generic)  instance NodeClass UINodeLabel where+  isCase gr n = False   isDummy gr n = False -- maybe False isDummyLabel (Graph.lookupNode n gr)   isConnNode gr n = maybe False isConnLabel (Graph.lookupNode n gr)   isFunction gr n = maybe False isFuncLabel (Graph.lookupNode n gr)

@@ -1,14 +1,14 @@ name:                layered-graph-drawing-version:             0.1.0.0+version:             0.2.0.0 synopsis:            Layered Graph Drawing after Sugiyama description:         Calculates the positions of graph nodes in a table with layered graph drawing-homepage:            https://github.com/BeFunctional/layered-graph-drawing+homepage:            https://github.com/tkvogt/layered-graph-drawing license:             BSD3 license-file:        LICENSE author:              Tillmann Vogt maintainer:          tillk.vogt@gmail.com copyright:           2023 Tillmann Vogt-category:            graphics, graph+category:            Graphics, Graphs build-type:          Simple -- extra-source-files: cabal-version:       >=1.10@@ -43,4 +43,8 @@                      , text    default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/tkvogt/layered-graph-drawing 

@@ -25,52 +25,62 @@     adjacentNodesByAttr,   ) +-- | Word32 is used for the node because graph drawing is most likely used in a browser with javascript and the ints there have 32 bits, and this is more than enough type UINode = Word32 --- A Graph consists of nodes and edges, graph drawing arranges it from left to right,--- start to end.+-- | A shorthand for multiple edges type CGraph n e = Graph n [e] -type CGraphL n e = (Graph n [e], Map UINode (Int, Int))+-- | Layouted Graph, assign a (x,y) position to every node+--   also returning the blocks in yCoordinateassignment, the final layouting has to be done in javascript+type CGraphL n e = (Graph n [e], Map UINode (X, Y), YBlockLines) -type Channel = Int -- The nth type of a type node--- This is path of function and type nodes with spaces that can be filled with options+type X = Int+type Y = Int+type YBlock      =  (Y, [(UINode, X)])+type YBlocks     =  (Y, [[(UINode, X)]])+type YBlockLines = [(Y, [[(UINode, X)]])] +-- | Nodes could be grouped into lists. But as a lof of algorithms walk through the graph, +--   it is more convenient to see for example if a node is connected vertically than to see if it is part of a list of vertically grouped nodes.+--   This is of course a matter of taste and there probably good arguments to put nodes in lists data EdgeType   = NormalEdge-  | VerticalEdge -- When having options, they appear continuously in one column-  -- We mark this in the graph with vertical edges from the first-  -- option to the second and so on-  | VirtualHorEdge -- virtual edges are not displayed but used for layouting and-  -- naviagtion with the keyboard-  | SeparatingEdge -- to connect graph components that are separate+  | VerticalEdge -- ^When having options, they appear continuously in one column. We mark this in the graph with vertical edges from the first option to the second and so on+  | VirtualHorEdge -- ^Virtual edges are not displayed but used to put several graphs in a row for layouting and navigation with the keyboard+  | SeparatingEdge -- ^To connect graph components that are separate   deriving (Show, Generic, Eq, Ord)  type GraphMoveX = Int  type Column = (GraphMoveX, [UINode]) ---instance NodeClass n => Eq n where---  node1 == node2 = uinode node1 == uinode node2-+-- | A type class for the node type, so that an individual node type can be used+--   Some functions had to be introduced that are special for the original purpose. The main reason for not using grapviz was that it became clear that a binding to graphviz does not allow to adjust algorithms easily class NodeClass n where   isDummy :: EdgeClass e => CGraph n e -> UINode -> Bool+  isCase :: EdgeClass e => CGraph n e -> UINode -> Bool   isConnNode :: EdgeClass e => CGraph n e -> UINode -> Bool-  isFunction :: EdgeClass e => CGraph n e -> UINode -> Bool-  isMainArg :: CGraph n e -> UINode -> Bool+  isFunction :: EdgeClass e => CGraph n e -> UINode -> Bool -- ^ This special for displaying function networks+  isMainArg :: EdgeClass e => CGraph n e -> UINode -> Bool -- ^ This special for displaying function networks   isSubLabel :: n -> Bool-  isArgLabel :: n -> Bool+  isArgLabel :: n -> Bool -- ^ This special for displaying function networks   subLabels :: n -> Int   connectionNode :: n   dummyNode :: Int -> n -- Depth -> n   nestingFeatures :: n -> Maybe LayerFeatures   updateLayer :: Maybe LayerFeatures -> n -> n-  verticalNumber :: n -> Maybe Word32 -- we want to keep the order of vertically connected Nodes,+  verticalNumber :: n -> Maybe Int -- we want to keep the order of vertically connected Nodes,  type ChannelNrIn = Maybe Channel  type ChannelNrOut = Channel +-- | A channel (or port) is used if a node has several subfields that are connected separately+--   For example the nth type of a type node+type Channel = Int++-- | Edges can are also be implemented individually class EdgeClass e where   dummyEdge :: ChannelNrIn -> ChannelNrOut -> e   standard :: EdgeType -> e@@ -79,32 +89,12 @@   channelNrOut :: e -> ChannelNrOut  --------------------------------------------------------------------------------------------------------myFromJust :: Int -> Maybe a -> a-myFromJust i term-  | isJust term -- Debug.Trace.trace ("myFromJustTrue "++ show i)-    =-    fromJust term-  | otherwise =-    Debug.Trace.trace-      ("myFromJust " ++ show i)-      fromJust-      term--myhead :: Int -> [a] -> a-myhead i a-  | null a = error ("head: empty list " ++ show i)-  | otherwise = head a--vhead :: (VU.Unbox a) => Int -> VU.Vector a -> a-vhead i a-  | VU.null a = error ("VU.head: empty list " ++ show i)-  | otherwise = VU.head a--rmdups :: (Ord a) => [a] -> [a]-rmdups = map (myhead 500) . group . sort--------------------------------------------------------------------------------------------------------+-- * Grouping edges into classes with non overlapping bits, +--+-- $bits+--+-- For example vertBit = 00000001 = 1, virtBit = 00000010 = 2, sepBit = 00000100 =4, ...+--   Up to 8 bits. This was used to have a superfast lookup with an intmap. Maybe a normal Map with a key (UINode,Word32) would have been easier, with Word32 being the edge type. But this is faster.  vertBit :: Word8 vertBit = 0x1@@ -130,29 +120,49 @@         (0, [standard NormalEdge])       ] -  -- show_e (Just [UIEdge standard Nothing 0 e]) = show e-  -- show_e _ = "no Edge"+--  show_e (Just [UIEdgeLabel standard Nothing 0 e]) = show e+  show_e _ = "no Edge"   bases _ = [Edge8 0, Edge8 vertBit, Edge8 virtBit] -childrenSeparating :: EdgeClass e => CGraph n e -> Word32 -> VU.Vector Word32-childrenSeparating gr n = adjacentNodesByAttr gr True n (Edge8 sepBit)+------------------------------------------------------------------------------------------------------+-- * Querying nodes that are connected by a certain type of edge+--    +-- | All children that are connected but without the vertically connected nodes childrenNoVertical :: EdgeClass e => Graph n [e] -> Word32 -> VU.Vector Word32 childrenNoVertical gr n =   adjacentNodesByAttr gr True n (Edge8 virtBit)     VU.++ adjacentNodesByAttr gr True n (Edge8 0) +-- | All parents that are connected but without the vertically connected nodes+parentsNoVertical :: EdgeClass e => Graph n [e] -> Word32 -> VU.Vector Word32+parentsNoVertical gr n =+  adjacentNodesByAttr gr False n (Edge8 virtBit)+    VU.++ adjacentNodesByAttr gr False n (Edge8 0)++-- | All parents that are connected but without the virtual connected nodes+parentsNoVirtual :: EdgeClass e => CGraph n e -> Word32 -> VU.Vector Word32+parentsNoVirtual gr n =+  (adjacentNodesByAttr gr False n (Edge8 vertBit))+    VU.++ (adjacentNodesByAttr gr False n (Edge8 0))++-- | All parents that are connected but without the virtual or vertically connected nodes+parentsNoVerticalOrVirtual :: EdgeClass e => CGraph n e -> Word32 -> VU.Vector Word32+parentsNoVerticalOrVirtual gr n = adjacentNodesByAttr gr False n (Edge8 0)++-- | Children that are connected vertically childrenVertical :: EdgeClass e => Graph n [e] -> Word32 -> VU.Vector Word32 childrenVertical gr n = adjacentNodesByAttr gr True n (Edge8 vertBit) +-- | Parents that are connected vertically parentsVertical :: EdgeClass e => Graph n [e] -> Word32 -> VU.Vector Word32 parentsVertical gr n = adjacentNodesByAttr gr False n (Edge8 vertBit) -parentsNoVertical :: EdgeClass e => Graph n [e] -> Word32 -> VU.Vector Word32-parentsNoVertical gr n =-  adjacentNodesByAttr gr False n (Edge8 virtBit)-    VU.++ adjacentNodesByAttr gr False n (Edge8 0)+-- | Children that are connected with a separating edge+childrenSeparating :: EdgeClass e => CGraph n e -> Word32 -> VU.Vector Word32+childrenSeparating gr n = adjacentNodesByAttr gr True n (Edge8 sepBit) +-- | Find all vertically connected nodes, by exploring incoming and outgoing vertical edges  verticallyConnectedNodes :: EdgeClass e => CGraph n e -> UINode -> [UINode] verticallyConnectedNodes g n =   VU.toList $@@ -171,11 +181,20 @@           VU.++ VU.concatMap (goDown . childrenVertical g) nodes  ------------------------------------------------------------------------------------------------------+-- * Borders of cells+--   Cells have a nesting and border type, when a box has to be drawn around a graph +type Nesting = Int -- the nesting of the window:+-- 0 -> dummy node+-- 1 -> not part of a window+-- 2 -> first window layer++type BoxId = Word32 -- ^ I use the node of the function that is exploded as the box id+ data LayerFeatures = LayerFeatures-  { layer :: Int, -- Expanding a fuction generates a new layer-  -- (maybe make every new layer a little bit darker)-    border :: Maybe Border -- To set the right css values (border, boxshadow)+  { layer :: Nesting, -- ^Graphs that are inside graphs get a higher nesting value (I use this to make every new layer a little bit darker). This is used to calculate the subgraph windows+    boxId :: Maybe BoxId, -- ^ There can be several subgraphs in a graph, that are surrounded by a box. This value has to be unique for every box+    border :: Maybe Border -- ^Set the css values (border, boxshadow)   }   deriving (Show, Generic) @@ -183,32 +202,32 @@  instance ToJSON LayerFeatures -lb :: Int -> Maybe LayerFeatures-lb n = Just (LayerFeatures n (Just LeftBorder))+lb :: Nesting -> Maybe BoxId -> Maybe LayerFeatures+lb n b = Just (LayerFeatures n b (Just LeftBorder)) -rb :: Int -> Maybe LayerFeatures-rb n = Just (LayerFeatures n (Just RightBorder))+rb :: Nesting -> Maybe BoxId -> Maybe LayerFeatures+rb n b = Just (LayerFeatures n b (Just RightBorder)) -tb :: Int -> Maybe LayerFeatures-tb n = Just (LayerFeatures n (Just TopBorder))+tb :: Nesting -> Maybe BoxId -> Maybe LayerFeatures+tb n b = Just (LayerFeatures n b (Just TopBorder)) -bb :: Int -> Maybe LayerFeatures-bb n = Just (LayerFeatures n (Just BottomBorder))+bb :: Nesting -> Maybe BoxId -> Maybe LayerFeatures+bb n b = Just (LayerFeatures n b (Just BottomBorder)) -ltb :: Int -> Maybe LayerFeatures-ltb n = Just (LayerFeatures n (Just LeftTopBorder))+ltb :: Nesting -> Maybe BoxId -> Maybe LayerFeatures+ltb n b = Just (LayerFeatures n b (Just LeftTopBorder)) -rtb :: Int -> Maybe LayerFeatures-rtb n = Just (LayerFeatures n (Just RightTopBorder))+rtb :: Nesting -> Maybe BoxId -> Maybe LayerFeatures+rtb n b = Just (LayerFeatures n b (Just RightTopBorder)) -lbb :: Int -> Maybe LayerFeatures-lbb n = Just (LayerFeatures n (Just LeftBottomBorder))+lbb :: Nesting -> Maybe BoxId -> Maybe LayerFeatures+lbb n b = Just (LayerFeatures n b (Just LeftBottomBorder)) -rbb :: Int -> Maybe LayerFeatures-rbb n = Just (LayerFeatures n (Just RightBottomBorder))+rbb :: Nesting -> Maybe BoxId -> Maybe LayerFeatures+rbb n b = Just (LayerFeatures n b (Just RightBottomBorder)) -mid :: Int -> Maybe LayerFeatures-mid n = Just (LayerFeatures n Nothing)+mid :: Nesting -> Maybe BoxId -> Maybe LayerFeatures+mid n b = Just (LayerFeatures n b Nothing)  data Border   = LeftBorder@@ -224,3 +243,36 @@ instance FromJSON Border  instance ToJSON Border++------------------------------------------------------------------------------------------------------+-- * Helper functions+--++myFromJust :: Int -> Maybe a -> a+myFromJust i term+  | isJust term -- Debug.Trace.trace ("myFromJustTrue "++ show i)+    =+    fromJust term+  | otherwise =+    Debug.Trace.trace+      ("myFromJust " ++ show i)+      fromJust+      term++myHead :: Int -> [a] -> a+myHead i a+  | null a = error ("head: empty list " ++ show i)+  | otherwise = head a++myLast :: Int -> [a] -> a+myLast i a+  | null a = error ("last: empty list " ++ show i)+  | otherwise = last a++vHead :: (VU.Unbox a) => Int -> VU.Vector a -> a+vHead i a+  | VU.null a = error ("VU.head: empty list " ++ show i)+  | otherwise = VU.head a++rmdups :: (Ord a) => [a] -> [a]+rmdups = map (myHead 500) . group . sort

@@ -13,1466 +13,1648 @@  import qualified Data.IntMap as I import qualified Data.IntMap.Strict as IM-import Data.List (elemIndex, find, group, groupBy, intercalate, sort, sortBy, sortOn, (\\))-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Tuple (swap)-import qualified Data.Vector.Algorithms.Intro as I-import Data.Vector.Unboxed (Vector)-import qualified Data.Vector.Unboxed as VU-import Data.Word (Word32)-import Debug.Trace (trace)-import Graph.CommonGraph-  ( CGraph,-    CGraphL,-    Channel,-    Column,-    EdgeClass (channelNrIn, channelNrOut, dummyEdge, standard),-    EdgeType (NormalEdge),-    GraphMoveX,-    LayerFeatures (LayerFeatures),-    NodeClass (connectionNode, dummyNode, isConnNode, isDummy, isMainArg, isSubLabel, subLabels),-    UINode,-    childrenNoVertical,-    childrenSeparating,-    childrenVertical,-    isFunction,-    myFromJust,-    myhead,-    parentsNoVertical,-    parentsVertical,-    rmdups,-    verticallyConnectedNodes,-    vhead,-  )-import qualified Graph.CommonGraph as Common-import Graph.IntMap (Graph (..), nodes)-import qualified Graph.IntMap as Graph---- Also returns a map with Columns to allow navigation with arrows-layeredGraphAndCols ::-  (NodeClass n, Show n, EdgeClass e, Show e) =>-  Bool ->-  CGraph n e ->-  (CGraphL n e, (Map.Map GraphMoveX [UINode], Map.Map Int [Column]))-layeredGraphAndCols cross graph = (g, getColumns g)-  where-    g = layeredGraph cross graph---- Debug with https://dreampuf.github.io/GraphvizOnline using neato or fdp engine---- ^ Layout a directed acyclic graph in several steps (Sugiyama)--- 1. Assign the nodes to several layers (longest path)--- 2. Dummy vertices for lines that are longer than a layer--- 3. Reduce crossings, place the longest path on top--- 4. Assign y-coordinates to the nodes so that long lines that pass several layers are---    as straight as possible--layeredGraph ::-  (VU.Unbox UINode, NodeClass n, Show n, EdgeClass e, Show e) =>-  Bool ->-  CGraph n e ->-  CGraphL n e-layeredGraph cross graph =-  -- Debug.Trace.trace ("layered "++ show graph ++"\n") -- ++ showEdges graph ++ show (Graph.edgeLabels graph)) $ -- ++"\nnewGraph\n" ++ show newGraph ++"\n") $-  newGraph-  where-    sortLayers (gr, ls) = (gr, map sort ls) -- makes the dummy vertices appear lower-    newGraph =-      ( -- subgraphWindows .-        yCoordinateAssignement-          -- .-          -- primitiveYCoordinateAssignement-          . crossingReduction 1 cross-          . sortLayers-          . addConnectionVertices-          . longestPathAlgo-          . addMissingInputNodes -- does not change the graph, only computes layers-      )-        graph--fr :: (Int, n) -> (UINode, n)-fr (n, nl) = (fromIntegral n, nl)--graphvizNodes :: (CGraph n e, Map.Map Int [Column]) -> String-graphvizNodes (gr, m) = concatMap ((++ "\n") . sh) (I.toList (Graph.nodeLabels gr))-  where-    sh (n, _nl) = show n ++ " [ pos = \"" ++ show (myFromJust 499 $ Map.lookup n m) ++ "!\"]"--primitiveYCoordinateAssignement :: (CGraph n e, [[UINode]]) -> CGraphL n e-primitiveYCoordinateAssignement (graph, layers) =-  --    Debug.Trace.trace ("primitiveY1 "++ show (graph,layers,ns)) $-  (graph, Map.fromList ns)-  where-    ns :: [(UINode, (Int, Int))]-    ns = concat $ zipWith (\layer i -> map (incX i) layer) (map oneLayer layers) ([0 ..] :: [Int])-    oneLayer l = zip (iterate incY (0, 0)) l-    incX i ((x, y), n) = (n, (x - i, y))-    incY (x, y) = (x, y + 1)-{--primitiveYCoordinateAssignement2 :: (CGraph, [[UINode]]) -> CGraph-primitiveYCoordinateAssignement2 (g, (la:layers)) =-    Debug.Trace.trace ("primitiveY2 "++ show (g, newGraph, ns, la, layers)) $---                       ++ show (reverse $ oneLayer newLa layers)) $-    newGraph-  where-    newGraph = g { nodeLabels = I.fromList $ map fr2 $ map (positionNode g) (concat ns) }-    ns = zipWith (\layer i -> map (incX i) layer) (oneLayer newLa layers) ([0..] :: [Int])-    newLa = zip (iterate incY (0,0)) la-    oneLayer :: [((Int,Int), UINode)] -> [[UINode]] -> [[((Int,Int), UINode)]]-    oneLayer l0 [] = [l0]-    oneLayer l0 (l1:rest) = l0 : (oneLayer newL1 rest)-      where-        newL1 = childYOrInc 0 (-1) l1--        childYOrInc _ _ [] = []-        childYOrInc y lastY (e:es)-          | isJust cy && (fromJust cy) /= lastY =---          Debug.Trace.trace ("cy " ++ show (fromJust cy) ++" "++ show e ++ " " ++ show lu) $-                        ((0,fromJust cy),e) : childYOrInc ((fromJust cy)+1) (fromJust cy) es-          | otherwise =---         Debug.Trace.trace ("other y "++ show y ++" cy "++ show cy ++" "++ show e) $-                        ((0,y),e) : childYOrInc (y+1) (fromMaybe y cy) es-          where cy | VU.null (child e) = Nothing-                   | otherwise = fmap snd lu-                lu = lookup (vhead 500 (child e)) (map (\(a,b) -> (b,a)) l0)-    child el = childrenNoVertical g el-    incX i ((x,y),n) = (x-i,y,n)-    incY (x,y)     = (x,y+1)--}-{--positionNode :: CGraph -> (Int, Int, UINode) -> (UINode, UINodeLabel)-positionNode graph (x,y,n) =-  (n, UINodeLabel { option = maybe NoOption option lu,-                    formerNonOption = maybe False formerNonOption lu,-                    uinode = maybe (DN (DummyNode 1)) uinode lu,-                    nestingFeatures = maybe Nothing nestingFeatures lu,-                    verticalNumber = maybe Nothing verticalNumber lu-                  })-    where lu = Graph.lookupNode n graph--}---- ^ See "Fast and Simple Horizontal Coordinate Assignment" (Brandes, Köpf)--yCoordinateAssignement :: (NodeClass n, EdgeClass e) => (CGraph n e, [[UINode]]) -> CGraphL n e-yCoordinateAssignement (graph, layers) =-  -- Debug.Trace.trace ("\nyCoordAssign "++ show (layers,graph,pos)) $-  (graph, pos)-  where-    -- newGraph = graph { nodeLabels = I.fromList placedNodes } -- for debugging (Map.fromList edgesToKeep)-    pos :: Map UINode (Int, Int)-    pos = horizontalBalancing lu ld ru rd-    lu = biasedAlignment graph yPos medians (reverse nLayers) (True, True)-    ld = biasedAlignment graph yPos medians (reverse nLayers) (True, False)-    ru = biasedAlignment graph yPos medians (reverse nLayers) (False, True)-    rd = biasedAlignment graph yPos medians (reverse nLayers) (False, False)--    -- for debugging-    --      edgesToKeep :: [(Graph.DirEdge UINode, [UIEdge])]-    --      edgesToKeep = map (\(x,y) -> (Graph.DirEdge x y, fromJust (Graph.lookupEdge (Graph.DirEdge x y) graph))) $-    --                      concat $ map (sweep medians Map.empty 0 (True,True)) (tuples (reverse nLayers))--    yPos = Map.fromList (concat enumLayers)-    enumLayers = map (\l -> zip l [0 ..]) layers-    nLayers = map (map connProp) layers-    connProp n = (n, isConnNode graph n)--    medians = (Map.fromList lowerMedians, Map.fromList upperMedians)-    upperMedians =-      -- Debug.Trace.trace ("upper"++ show (map upper ns, map (getMedian . upper) ns)) $-      mapMaybe (getMedian . upper) ns-    lowerMedians =-      -- Debug.Trace.trace ("lower"++ show (map lower ns)) $-      mapMaybe (getMedian . lower) ns-    ns = map fr $ I.toList (Graph.nodeLabels graph)-    upper (n, _) = (n, VU.toList (childrenNoVertical graph n))-    lower (n, _) = (n, VU.toList (parentsNoVertical graph n))--    getMedian (n, ns1)-      | l == 0 -- Debug.Trace.trace "get l0" $-        =-        Nothing-      | l == 1 = Just (n, Single rightMedian)-      | even l -- Debug.Trace.trace ("get lmod2"++ show (nodeLbls,ns1,(n, (leftMedian, rightMedian)))) $-        =-        Just (n, UpLowMedian leftMedian rightMedian) -- an even list has two medians-      | otherwise -- Debug.Trace.trace ("get other"++ show (nodeLbls,ns1,(n, (rightMedian, rightMedian)))) $-        =-        Just (n, Middle rightMedian) -- an odd list has only one median-      where-        leftMedian =-          -- Debug.Trace.trace ("median "++ show (n,ns1,nodeLbls,sorted,l)) $-          addConnProp (sorted !! ((l `div` 2) - 1))-        rightMedian = addConnProp (sorted !! (l `div` 2))-        l = length ns1-        sorted = sortBy py nodeLbls-        py (y0, _) (y1, _) = compare y0 y1-        nodeLbls = map (\node -> (fromMaybe 0 (Map.lookup node yPos), node)) ns1-        addConnProp (y, node) = (y, (node, isConnNode graph node))---- the paper suggest to use an average of four alignments (TODO)-horizontalBalancing :: Map UINode (X, Y) -> Map UINode (X, Y) -> Map UINode (X, Y) -> Map UINode (X, Y) -> Map UINode (X, Y)-horizontalBalancing lu _ld _ru _rd =-  -- Debug.Trace.trace ("horizontalBalancing "++ show (lu,ru)) --  ++"\n"++ show ld ++"\n"++ show average)-  -- lu -- ld ru rd-  lu---- average = zipWith f lu ru---        f :: (UINode,(X,Y)) -> (UINode,(X,Y)) -> (UINode,(X,Y))---        f (n0,(x0,y0)) (n1,(x1,y1)) | n0 /= n1 = error "horizontalBalancing n0 /= n1 "---                                    | otherwise = (n0, (x0, (y0+y1) `div` 2 ))--type X = Int--type Y = Int--type YN = (Y, (UINode, Bool))--data MYN-  = Single (Y, (UINode, Bool)) -- no medians because there is only one connection-  | Middle (Y, (UINode, Bool)) -- an odd number of connections has only one median-  | UpLowMedian (Y, (UINode, Bool)) (Y, (UINode, Bool))-  deriving (Eq, Ord, Show) -- an even number of connections has two medians--type Median = Map UINode MYN--biasedAlignment ::-  (NodeClass n, EdgeClass e) =>-  CGraph n e ->-  Map UINode Y ->-  (Median, Median) ->-  [[(UINode, Bool)]] ->-  (Bool, Bool) ->-  Map UINode (X, Y)-biasedAlignment graph _ medians layers dir =-  -- Debug.Trace.trace ("\nbalign"++ show (layers, balign)) $ --edgesToKeep, map sweep2 (tuples layers)) ++-  --                                                                "\nunpositioned " ++ show (map removePositioned (map (map fst) layers))) $-  balign-  where-    (left, _up) = dir-    positioned = Map.keys balign-    _removePositioned ns = ns \\ positioned-    -- see with https://dreampuf.github.io/GraphvizOnline/-    balign =-      -- Debug.Trace.trace ("\n\nedgesToKeep "++ show dir ++ "\ndigraph G {" ++-      --                   (concat $ map line edgesToKeep) ++"\n"++ placeNodes ++ "\n}") -- \n\nmedians "++ show medians) $-      align graph (map (map fst) layers) edgesToKeep dir-    edgesToKeep = rmdups $ concatMap (concatMap resolve . sweep2) (tuples layers)-    _line (from, to) = "\n" ++ show from ++ " -> " ++ show to-    _placeNodes = concat $ concatMap (map placeNode) (zipWith (zip . repeat) [1 ..] (map (zip [1 ..]) layers))-      where-        placeNode :: (X, (Y, (UINode, Bool))) -> String-        placeNode (x, (y, (n, _b))) = show n ++ " [pos=\"" ++ show x ++ "," ++ show (-y) ++ "!\"];\n"-    resolve :: [(MYN, MYN)] -> [(UINode, UINode)]-    resolve ts =-      -- Debug.Trace.trace ("\nresolve "++ show (ts, res))-      res-      where-        res = rmdups $ map toNode (resolveConflicts dir ts)--    _sweep :: ([(UINode, Bool)], [(UINode, Bool)]) -> [[(MYN, MYN)]]-    _sweep (layer0, layer1) =-      -- Debug.Trace.trace ("\nsweep "++ show (dir, layer0, layer1) ++"\n"++ show sfiel)-      -- Debug.Trace.trace ("(l0,l1)\n"++ show (layer0, layer1) ++"\n\n"++ show medians ++"\n\n"++ show sfiel) $-      sfiel-      where-        sfiel = sweepForIndependentEdgeLists graph medians allowedEdges dir (Map.empty, Map.empty) (0, 0) (layer0, layer1) Set.empty-        allowedEdges :: Set.Set (UINode, UINode)-        allowedEdges = Set.fromList (mapMaybe f layer0)-        --              f :: UINode -> (UINode, UINode)-        f (n, _b)-          | isJust lu = Just (n, dest)-          | otherwise = Nothing-          where-            dest = fst $ snd $ getYN (fst dir) (myFromJust 500 lu)-            lu = Map.lookup n (snd medians)--    -- sweeping through a layer to find all edges without separating them into independent lists-    -- maybe slower in some cases, faster in others-    sweep2 :: ([(UINode, Bool)], [(UINode, Bool)]) -> [[(MYN, MYN)]]-    sweep2 (layer0, _layer1) =-      -- Debug.Trace.trace ("sweep2 "++ show (layer0, layer1,es))-      es-      where-        es = [catMaybes (zipWith f [0 ..] layer0)]-        f y (n, b)-          | isJust lu && isValidEdge -- Debug.Trace.trace ("sweep2lu0 "++ show lu) $-            =-            Just (Single (y, (n, b)), myFromJust 501 lu)-          | otherwise -- Debug.Trace.trace ("sweep2lu1 "++ show (n,lu))-            =-            Nothing-          where-            lu = Map.lookup n (snd medians)-            luBack = Map.lookup (fst $ snd $ getYN left $ myFromJust 502 lu) (fst medians)-            isValidEdge =-              -- Debug.Trace.trace ("n,lu,luBack "++ show (n,lu,luBack)) $-              isJust luBack && n == fst (snd $ getYN left $ myFromJust 503 luBack)--toNode :: ((a1, (a2, b1)), (a3, (b2, b3))) -> (a2, b2)-toNode ((_, (n0, _)), (_, (n1, _))) = (n0, n1)--tuples :: [a] -> [(a, a)]-tuples (x : y : xs) = (x, y) : tuples (y : xs)-tuples _ = []--type Insp = (Map Int (MYN, MYN), Map Int (MYN, MYN))---- | Takes two layers and returns a list of lists of independent edges.---   A list A of edges is independent of a list B of edges if every edge of A does not intersect or connect any edge of B.---   This sweeping should save some time because graphs often have edges crossing near to each other.---   The number of intersections has been reduced in crossingreduction.---   Because of this we can assume that most edges are quite short and rectangular to layer0 and layer1.---   A sweep in the parallel direction of the two layers should reduce the number of edges that have to be examined.---   The overall algorithm (sweep + resolve) should have a runtime more like n*log(n) instead of n²,---   because we only have to search for conflicts inside of these independent lists.---   The Brandes-Köpf paper is not explaining very well how they find intersections between two layers.---   I doubt that the whole algorithm is O(n). It seems more like a quadratic runtime in the worst case.---   Even finding the number of intersections (without giving back the exact edges that intersect) is O(n log n),---   See:  Simple and Efficient Bilayer Cross Counting by Barth, Mutzel, Jünger---        or chapter 33 of Cormen: Introduction to algorithms---   If several edges emanate from a node the algorithm takes (one of the) the median. (e.g. three edges have one median, 4 edges have two)---   The sweep works by looking at the next node in the two layers, and comparing which node deletes more edges and---   introduces less new edges from the set of edges to look at. Every edge has a start node (first appearing at its---   y-position) and an end node. A start node means adding an edge when its source or target node appears in one of---   the two layers, and the edge disappears when both its nodes have been swept over.-sweepForIndependentEdgeLists ::-  (NodeClass n, EdgeClass e) =>-  CGraph n e ->-  (Median, Median) ->-  Set (UINode, UINode) ->-  (Bool, Bool) ->-  Insp ->-  (Y, Y) ->-  ([(UINode, Bool)], [(UINode, Bool)]) ->-  Set (MYN, MYN) ->-  [[(MYN, MYN)]]-sweepForIndependentEdgeLists graph medians allowedEdges dir inspectionEdges (y0, y1) (layer0, layer1) missingEdges-  | null layer0 && null layer1 = Debug.Trace.trace ("nullnull " ++ show (layer0, layer1)) []-  | y0 >= 10 || y1 >= 10 = Debug.Trace.trace ("1010 " ++ show (y0, y1, layer0, layer1)) []-  | -- node at postion y1 is connected vertically with node at position y1+1-    (length layer1 >= 2) && verticalNode && isFunction graph hl1 =-    -- Debug.Trace.trace "sweep vert node" $-    sweepForIndependentEdgeLists graph medians allowedEdges dir sweepedOver (y0, y1 + 1) (layer0, tl1) Set.empty-  | Map.null sweepedOverFrom && Map.null sweepedOverTo =-    -- Debug.Trace.trace ("res"++ show (y0,y1) ++"\nlayer0 "++ show layer0 ++"\nlayer1 "++ show layer1-    --                    ++"\nresEdges "++ show resEdges ++"\nnewInsFrom "++ show newInsFrom ++"\nnewInsTo "-    --                    ++ show newInsTo ++"\nsweepedOver "++ show sweepedOver ++"\n") $-    resEdges : (sweepForIndependentEdgeLists graph medians allowedEdges dir sweepedOver (y0 + 1, y1 + 1) (tl0, tl1) Set.empty)-  | Map.size sweepedOverFrom < Map.size sweepedOverTo =-    -- Debug.Trace.trace (show (Map.size sweepedOverFrom)++ "<"++ show (Map.size sweepedOverTo) ++"\n"++-    --       show (y0,y1) ++"\nnewInsFrom "++ show newInsFrom ++"\nnewInsTo "++ show newInsTo-    --     ++"\nsweepedOverFrom "++ show sweepedOverFrom ++"\nsweepedOverTo "++ show sweepedOverTo ++"\n") $-    sweepForIndependentEdgeLists-      graph-      medians-      allowedEdges-      dir-      sweepedOver-      (y0 + 1, y1)-      (tl0, layer1)-      (Set.union missingEdges newMissingEdges)-  | otherwise -- Debug.Trace.trace (show (Map.size sweepedOverFrom)++ ">="++ show (Map.size sweepedOverTo) ++"\n"++-  --       show (y0,y1) ++"\nnewInsFrom "++ show newInsFrom ++"\nnewInsTo "++ show newInsTo-  --       ++"\nsweepedOverFrom "++ show sweepedOverFrom ++"\nsweepedOverTo "++ show sweepedOverTo ++"\n") $-    =-    sweepForIndependentEdgeLists-      graph-      medians-      allowedEdges-      dir-      sweepedOver-      (y0, y1 + 1)-      (layer0, tl1)-      (Set.union missingEdges newMissingEdges)-  where-    (inspectEdgesFrom, inspectEdgesTo) = inspectionEdges-    (lowerMedians, upperMedians) = medians-    (left, _up) = dir-    (n0, b0) = myhead 60 layer0-    (n1, b1) = myhead 61 layer1-    tl0-      | null layer0 = []-      | otherwise = tail layer0-    tl1-      | null layer1 = []-      | otherwise = tail layer1-    hl1 = fst (myhead 62 layer1)-    verticalNode = VU.elem (fst (myhead 63 tl1)) (Graph.adjacentNodesByAttr graph True hl1 (Graph.Edge8 Common.vertBit))-    resEdges = myNub (Map.elems newInsFrom ++ Map.elems newInsTo ++ Set.toList missingEdges)--    edgeFrom :: Maybe MYN-    edgeFrom-      | null layer0 = Nothing-      | otherwise -- Debug.Trace.trace ("up2 "++ show (n0, Map.lookup n0 upperMedians)) $-        =-        Map.lookup n0 upperMedians-    edgeTo :: Maybe MYN-    edgeTo-      | null layer1 --  || (not (Set.member (n0,n1) allowedEdges))-        =-        Nothing-      | otherwise -- Debug.Trace.trace ("up4 "++ show (n1, Map.lookup n1 lowerMedians)) $-        =-        Map.lookup n1 lowerMedians--    newInsFrom :: Map Int (MYN, MYN)-    newInsFrom-      | isJust edgeFrom && yy1 >= y1 = Map.insert yy1 (Single (y0, (n0, b0)), myFromJust 504 edgeFrom) inspectEdgesFrom-      | otherwise = inspectEdgesFrom-      where-        yy1 = getY left (myFromJust 505 edgeFrom)--    newInsTo :: Map Int (MYN, MYN)-    newInsTo-      | isJust edgeTo && yy0 >= y0 = Map.insert yy0 (myFromJust 506 edgeTo, Single (y1, (n1, b1))) inspectEdgesTo-      | otherwise = inspectEdgesTo-      where-        yy0 = getY left (myFromJust 506 edgeTo)--    newMissingEdges :: Set.Set (MYN, MYN)-    newMissingEdges-      | isJust edgeFrom && isJust edgeTo =-        Set.fromList-          [ (Single (y0, (n0, b0)), myFromJust 507 edgeFrom),-            (myFromJust 508 edgeTo, Single (y1, (n1, b1)))-          ]-      | isJust edgeFrom = Set.singleton (Single (y0, (n0, b0)), myFromJust 509 edgeFrom)-      | isJust edgeTo = Set.singleton (myFromJust 510 edgeTo, Single (y1, (n1, b1)))-      | otherwise = Set.empty--    sweepedOverFrom = Map.delete y1 newInsFrom-    sweepedOverTo = Map.delete y0 newInsTo-    sweepedOver = (sweepedOverFrom, sweepedOverTo) :: Insp---- | Either e0 prevails against all e1s or all e1s prevail against e0-data EdgeTy a = E0Prevails a | E1Prevails a | NoIntersect (a, a) deriving (Eq, Show)--resolveConflicts :: (Bool, Bool) -> [(MYN, MYN)] -> [(YN, YN)]-resolveConflicts (_, _) [] = []-resolveConflicts (left, _) [e] = [toYN left e]-resolveConflicts (left, up) es =-  -- Debug.Trace.trace ("resolveConflicts"++ show (es, resolveConfs (left,up) es 0)) $-  map (toYN left) (resolveConfs (left, up) es 0)--toYN :: Bool -> (MYN, MYN) -> ((Y, (UINode, Bool)), (Y, (UINode, Bool)))-toYN left (n0, n1) = (getYN left n0, getYN left n1)---- | Compare all edges of a layer with each other. Worst case: O(n²).--- But n can shrink fast in every round and n is small, because of sweepForIndependentEdgeLists-resolveConfs :: (Bool, Bool) -> [(MYN, MYN)] -> Int -> [(MYN, MYN)]-resolveConfs (_, _) [] _ =-  -- Debug.Trace.trace "ch0 "-  []-resolveConfs (left, up) (e0 : edges) i-  | i > 20 -- Debug.Trace.trace ("ch1 "++ show (e0:edges))-    =-    e0 : edges -- avoid endless loop-  | checkE0 consistent -- Debug.Trace.trace ("checkE0 "++ show (map te (e0:edges)) ++"\n"++ show (map _toEdges2 conflictList) ++"\n") $-    =-    e0 : (resolveConfs (left, up) removeInferiorToE0 (i + 1))-  | checkNoIntersect consistent -- Debug.Trace.trace ("check noIntersect "++ show (map te (e0:edges)) ++"\n"++ show (conflictList, consistent, i) ++ "\n") $-    =-    if null conflictList-      then e0 : edges-      else e0 : (resolveConfs (left, up) edges (i + 1)) -- concat (map toEdges conflictList)-  | otherwise -- Debug.Trace.trace ("checkE1 "++ show (map te (e0:edges)) ++"\n"++ show (conflictList, consistent, i, firstE1, edgesE1First) ++ "\n") $-    =-    resolveConfs (left, up) edgesE1First (i + 1)-  where-    conflictList = map (conflict left e0) edges--    edgesE1First = e1 : (filter (\e -> e /= e0 && e /= e1) (concatMap toEdges conflictList))-    e1 = head (toEdges firstE1)-    firstE1 = myFromJust 511 (find e1Prevails conflictList)--    consistent = isConsistent conflictList-    checkE0 (E0Prevails True) = True-    checkE0 _ = False-    _checkE1 (E1Prevails True) = True-    _checkE1 _ = False-    checkNoIntersect (NoIntersect _) = True-    checkNoIntersect _ = False-    removeInferiorToE0 = rmdups $ concatMap toEdges (filter isNoIntersect conflictList)-    isNoIntersect (NoIntersect _) = True-    isNoIntersect _ = False-    e1Prevails (E1Prevails _) = True-    e1Prevails _ = False-    toEdges (E0Prevails e) = [e]-    toEdges (E1Prevails e) = [e]-    toEdges (NoIntersect (edge0, edge1)) = [edge0, edge1]--    _toEdges2 (E0Prevails (n0, n1)) = [te1 (n0, n1)]-    _toEdges2 (E1Prevails (n0, n1)) = [te1 (n0, n1)]-    _toEdges2 (NoIntersect ((n0, n1), (n2, n3))) = [te1 (n0, n1), te1 (n2, n3)]-    te1 (n0, n1) = (getN n0, getN n1)---- resolveConfs _ _ _ = Debug.Trace.trace "error resolveConfs " []---- | The resolveConflicts-algorithm has to be constructed in a consistent way---   It should be impossible that edge e has priority to edge x (keeping e),---   and another edge y has priority to edge e (deleting e). It would not be clear if e has to be deleted or not-isConsistent :: [EdgeTy (MYN, MYN)] -> EdgeTy Bool-isConsistent (NoIntersect _ : es) = isConsistent es-isConsistent [] = NoIntersect (True, True) -- will only be called if there is no E0Prevails or E1Prevails-isConsistent ((E0Prevails _) : es) = isAllE0OrNoIntersect es-  where-    isAllE0OrNoIntersect [] = E0Prevails True-    isAllE0OrNoIntersect ((E0Prevails _) : edges) = isAllE0OrNoIntersect edges-    isAllE0OrNoIntersect ((NoIntersect _) : edges) = isAllE0OrNoIntersect edges-    isAllE0OrNoIntersect (_ : _) = E0Prevails False -- not consistent-isConsistent ((E1Prevails _) : es) = isAllE1OrNoIntersect es-  where-    isAllE1OrNoIntersect [] = E1Prevails True-    isAllE1OrNoIntersect ((E1Prevails _) : edges) = isAllE1OrNoIntersect edges-    isAllE1OrNoIntersect ((NoIntersect _) : edges) = isAllE1OrNoIntersect edges-    isAllE1OrNoIntersect (_ : _) = E1Prevails False--conflict :: Bool -> (MYN, MYN) -> (MYN, MYN) -> EdgeTy (MYN, MYN)-conflict left (n0, n1) (n2, n3)-  | isIntersecting -- Debug.Trace.trace ("intersecting "++ show (n0,n1,n2,n3)) $-    =-    cases left (n0, n1) (n2, n3)-  | otherwise = NoIntersect ((n0, n1), (n2, n3))-  where-    isIntersecting -- two segments intersect-      =-      (getY left n0 <= getY left n2 && getY left n1 >= getY left n3)-        || (getY left n0 >= getY left n2 && getY left n1 <= getY left n3)---- | Given two edges that intersect or connect, which one will prevail?-cases :: Bool -> (MYN, MYN) -> (MYN, MYN) -> EdgeTy (MYN, MYN)-cases left (n0, n1) (n2, n3)-  -- type 2 (one segment consists of two connection nodes and is preferred then)-  | connNode n0 && connNode n1 -- Debug.Trace.trace ("type2 0 "++ show (n0,n1,n2,n3)) $-    =-    E0Prevails (n0, n1)-  | connNode n2 && connNode n3 -- Debug.Trace.trace ("type2 1 "++ show (n0,n1,n2,n3)) $-    =-    E1Prevails (n2, n3)-  | (connNode n0 || connNode n1)-      && (connNode n2 || connNode n3) -- one connection node (type 2)-    =-    if (isMedian n0 || isMedian n1) && isSingle n2 && isSingle n3-      then -- Debug.Trace.trace ("type2 2 "++ show (n0,n1,n2,n3)) $-        E0Prevails (n0, n1)-      else E0Prevails (n2, n3)-  -- type 1 (non-inner segment crosses an inner segment)-  | (connNode n0 || connNode n1)-      && not (connNode n2)-      && not (connNode n3) -- Debug.Trace.trace ("type1 0"++ show (n0,n1,n2,n3)) $-    =-    E0Prevails (n0, n1)-  | (connNode n2 || connNode n3)-      && not (connNode n0)-      && not (connNode n1) -- Debug.Trace.trace ("type1 1"++ show (n0,n1,n2,n3)) $-    =-    E1Prevails (n2, n3)-  -- type 0 (a pair of non-inner segments)-  | not (connNode n0) && not (connNode n1)-      && not (connNode n2)-      && not (connNode n3) -- Debug.Trace.trace ("type0 "++ show (preferE0,n0,n1,n2,n3)) $-    =-    if preferE0-      then E0Prevails (n0, n1)-      else E1Prevails (n2, n3)-  | otherwise = Debug.Trace.trace "cases err" $ E0Prevails (n0, n1) -- correct? just to fix a warning-  where-    connNode (Single (_, (_, b))) = b-    connNode (Middle (_, (_, b))) = b-    connNode (UpLowMedian (_, (_, b0)) (_, (_, b1)))-      | left = b0-      | otherwise = b1-    isMedian (Single _) = False-    isMedian (Middle _) = True-    isMedian (UpLowMedian _n0 _n1) = True-    isSingle (Single _) = True-    isSingle _ = False-    preferE0-      | (isMedian n0 || isMedian n1) && not (isMedian n2) && not (isMedian n3) -- Debug.Trace.trace "p0"-        =-        True-      | (isMedian n2 || isMedian n3) && not (isMedian n0) && not (isMedian n1) -- Debug.Trace.trace "p1"-        =-        False-      | abs (getY left n0 - getY left n1) < abs (getY left n2 - getY left n3) -- Debug.Trace.trace "p2"-        =-        True-      | otherwise -- Debug.Trace.trace "p3"-        =-        False--getYN :: Bool -> MYN -> (Y, (UINode, Bool))-getYN _ (Single (y, (n, b))) = (y, (n, b))-getYN _ (Middle (y, (n, b))) = (y, (n, b))-getYN left (UpLowMedian (y0, (n0, b0)) (y1, (n1, b1)))-  | left = (y0, (n0, b0))-  | otherwise = (y1, (n1, b1))--getY :: Bool -> MYN -> Y-getY _ (Single (y, _)) = y-getY _ (Middle (y, _)) = y-getY left (UpLowMedian (y0, (_n0, _b0)) (y1, (_n1, _b1)))-  | left = y0-  | otherwise = y1--getN :: MYN -> [UINode]-getN (Single (_y, (n, _b))) = [n]-getN (Middle (_y, (n, _b))) = [n]-getN (UpLowMedian (_y0, (n0, _b0)) (_y1, (n1, _b1))) = [n0, n1]--ranksame :: [[UINode]] -> String-ranksame ls = "{ rank=same; " ++ intercalate "," (map show ls) ++ " }\n"--col :: Int -> UINode -> String-col i n = show n ++ " " ++ c (i `mod` 5) ++ "\n"-  where-    c m-      | m == 0 = "[color = red" ++ width-      | m == 1 = "[color = green" ++ width-      | m == 2 = "[color = blue" ++ width-      | m == 3 = "[color = yellow" ++ width-      | m == 4 = "[color = turquoise" ++ width-    c _ = "[color = black" ++ width-    width = ",penwidth=" ++ show (1 + (i `div` 2)) ++ "]"-------------------------------------------------------------------------------------------------------------------------- Similar to Brandes-Köpf but without arrays and no placement of blocks--- The basic algorithm is longest path.--- debugging can be done with graphviz, also uncomment line 533 in longestPath | otherwise-align :: EdgeClass e => CGraph n e -> [[UINode]] -> [(UINode, UINode)] -> (Bool, Bool) -> Map UINode (Int, Int)-align graph layers edges (_alignLeft, _up) =-  {-Debug.Trace.trace ("\nalign\ndigraph{\n"++ (concat $ map ranksame layers)-                      ++ (concat (map ((++ "\n") . (intercalate " -> ") . (map show)) layers))-                      ++ (graphviz "[color=red,penwidth=2];" edges)-                      ++ (graphviz "" es) ++ "}\n"-                      ++ show (startNs, map last (zipWith f [0..] layers))-                      ++"\nblocks\n"++ show blocks ++ "\nnextInLayerMap" ++ show nextInLayerMap-                    )-}-  mb2-  where-    --  | up = lp-    --  | otherwise = lpBackwards-    -- mb = Debug.Trace.trace ("lp\n" ++ show lp ++ "\nmb\n" ++ show (moveBlocks (Map.fromList lp))) $-    --     moveBlocks (Map.fromList lp)-    mb2 =-      -- Debug.Trace.trace ("lp\n" ++ show lp ++ "\nmb\n" ++ show (moveBlocks (Map.fromList lp), moveBlocksAgain (Map.fromList lp)) ++ "\n") $-      moveBlocksAgain (Map.fromList lp)-    lp = longestPath (map blockChildren startNs) [] 0-    --        globalYMin = minimum (map (snd . snd) lp)-    --        lpBackwards = longestPath (map blockChildren startNsBackwards) [] 0-    layerConnections = Map.fromList $ concatMap tuples layers-    reverseLayerConnections = Map.fromList $ concatMap (tuples . reverse) layers-    edgeMap = Map.fromList edges-    reverseBlocks = Map.fromList (map swap edges)-    _es = Map.keys (Graph.edgeLabels graph) \\ edges--    startNs = mapMaybe (nodeWithoutParent . last) (zipWith f [0 ..] layers)-    --        startNsBackwards = catMaybes $ map (nodeWithoutParent . head) (zipWith f [0..] layers)-    f i ns = map (i,) ns--    nodeWithoutParent (x, n)-      | isNothing (Map.lookup n reverseBlocks)-          && noParentInLayer (x, n) -- no parent in block-        =-        --  Debug.Trace.trace ("nodeWoPar0 "++ show (n, Map.lookup n reverseBlocks, noParentInLayer (x,n))) $-        Just (x, n)-      | otherwise =-        --  Debug.Trace.trace ("nodeWoPar1 "++ show (n, Map.lookup n reverseBlocks, noParentInLayer (x,n))) $-        Nothing-      where-        noParentInLayer root =-          -- Debug.Trace.trace ("noParInLayer "++ show (root, blockChildren root,-          --                   map hasNoLayerParent (blockChildren root))) $-          all hasNoLayerParent (blockChildren root)--        hasNoLayerParent (_, _n) = isNothing (Map.lookup n layerConnections)--    blockChildren :: (X, UINode) -> [(X, UINode)]-    blockChildren (x, n)-      | isJust lu = (x, n) : blockChildren (x + 1, myFromJust 513 lu)-      | otherwise = [(x, n)]-      where-        lu = Map.lookup n edgeMap--    longestPath :: [[(X, UINode)]] -> [UINode] -> Int -> [(UINode, (Int, Int))]-    longestPath [] _ _ =-      -- Debug.Trace.trace "finish"-      []-    longestPath blockNodes used i-      | i > 100 -- Debug.Trace.trace ("reverseBlocks " ++ show (edges, reverseBlocks)) $-        =-        []-      | otherwise -- Debug.Trace.trace ((concat $ map (col i) blns) ++ "\n") $-      --      ++ "map layerChild " ++ show (map layerChild (concat blockNodes)) ++ "\n"-      --      ++ "nextLayerRoots " ++ show nextLayerRoots ++ "\n"-      --      ++ "map blockChildren nextLayerRoots " ++ show (map blockChildren nextLayerRoots) ++ "\n"-      --      ++ "blocksWithOnlyUsedParents " ++ show blocksWithOnlyUsedParents ++ "\n"-      --      ++ "newUsed " ++ show newUsed-      --                ) $-        =-        newLayer ++ longestPath blocksWithOnlyUsedParents newUsed (i + 1)-      where-        newLayer = concatMap (oneLayer i) blockNodes-        blocksWithOnlyUsedParents = rmdups $ filter noParentOrUsed (map blockChildren nextLayerRoots)-        --                                          | otherwise = rmdups $ filter noParentOrUsed (map blockChildren nextLayerRootsBackwards)-        nextLayerRoots = myNub2 (map findRoot nextPossibleLayerNodes)-        --                nextLayerRootsBackwards = myNub2 (map findRoot nextPossibleLayerNodesBackwards)-        nextPossibleLayerNodes = mapMaybe layerChild (concat blockNodes)-        --                nextPossibleLayerNodesBackwards = catMaybes (map layerParent (concat blockNodes))-        layerChild (x, n) = maybe Nothing (\node -> Just (x, node)) (Map.lookup n reverseLayerConnections)-        --                layerParent (x,n) = maybe Nothing (\node -> Just (x,node)) (Map.lookup n layerConnections)-        newUsed = used ++ blns-        blns = map snd (concat blockNodes)-        noParentOrUsed block =-          -- Debug.Trace.trace ("noParentOrUsed "++ show (block, map noParOrUsed block, newUsed)) $-          all noParOrUsed block-        noParOrUsed (_, n) =-          -- Debug.Trace.trace ("noParOrUsed "++ show (n,lu)) $-          isNothing lu || (isJust lu && elem (myFromJust 514 lu) newUsed)-          where-            lu = Map.lookup n layerConnections--    oneLayer :: Y -> [(X, UINode)] -> [(UINode, (Int, Int))]-    oneLayer y ns = map (\(x, n) -> (n, (x, -y))) ns--    findRoot :: (X, UINode) -> (X, UINode)-    findRoot (x, n)-      | isJust lu && x >= 0 -- Debug.Trace.trace ("findRoot " ++ show (x,n)) $-        =-        findRoot (x - 1, myFromJust 515 lu)-      | otherwise = (x, n)-      where-        lu = Map.lookup n reverseBlocks--    blocks = extr ++ (map (\x -> [x]) rest)-      where-        extr = extractBlocks edgeMap-        rest = (concat layers \\ allNodes) \\ concat extr-        allNodes = Map.keys edgeMap ++ Map.elems edgeMap--    extractBlocks :: Map UINode UINode -> [[UINode]]-    extractBlocks m-      | Map.null m = []-      | otherwise = oneBlock ++ extractBlocks newEdgeMap -- extract one block and remove keys from the edge map-      where-        newEdgeMap =-          -- Debug.Trace.trace ("oneBlock " ++ show oneBlock) $-          foldr Map.delete m (concat oneBlock)-        oneBlock =-          filter-            (not . null)-            ( merge1 (map (fst . snd) oneBlockWithVerts)-                ++ [map fst oneBlockWithVerts]-                ++ merge1 (map (snd . snd) oneBlockWithVerts)-            )-        merge1 [] = []-        merge1 xs = (map head fil) : (merge1 (map tail fil))-          where-            fil = filter (not . null) xs-        oneBlockWithVerts =-          -- Debug.Trace.trace ("oneBlock " ++ show (reverse (blockNodesDown (head ks)), tail (blockNodesUp (head ks)))) $-          reverse (blockNodesDown (head ks))-            ++ tail (blockNodesUp (head ks))--        ks = Map.keys m ++ Map.elems m--        blockNodesDown :: UINode -> [(UINode, ([UINode], [UINode]))]-        blockNodesDown n-          | isJust lu = (n, (vertup, vertdown)) : (blockNodesDown (myFromJust 513 lu))-          | otherwise = [(n, (vertup, vertdown))]-          where-            lu = Map.lookup n edgeMap-            vertup = VU.toList (parentsVertical graph n)-            vertdown = VU.toList (childrenVertical graph n)--        blockNodesUp :: UINode -> [(UINode, ([UINode], [UINode]))]-        blockNodesUp n-          | isJust lu = (n, (vertup, vertdown)) : (blockNodesUp (myFromJust 513 lu))-          | otherwise = [(n, (vertup, vertdown))]-          where-            lu = Map.lookup n reverseBlocks-            vertup = VU.toList (parentsVertical graph n)-            vertdown = VU.toList (childrenVertical graph n)--    moveBlocks m =-      -- Debug.Trace.trace ("blocks" ++ show blocks ++ "\nm\n" ++ show (foldr moveToShortestConnection m (reverse blocks)))-      foldr moveToShortestConnection m (reverse blocks)-    moveBlocksAgain m =-      -- Debug.Trace.trace ("blocks" ++ show blocks ++ "\nm\n" ++ show (foldr moveToShortestConnection m (reverse blocks)))-      foldr moveToShortestConnection (moveBlocks m) (reverse blocks)--    moveToShortestConnection block m-      | null bs = m-      | otherwise = -- Debug.Trace.trace ("\nblock " ++ show block ++-      --       "\nbounds " ++ show bounds ++-      --       "\nnewY " ++ show newY ++-      --       "\nadjustY block newY m\n" ++ show (adjustY block newY m))-        adjustY block newY m-      where-        -- newY = ( (fromJust (fst (head bounds))) + (fromJust (snd (head bounds))) ) `div` 2-        bs = mapMaybe fst bounds-        newY = maximum bs + 1 -- TODO look at block connections-        bounds = map blockBound block-        blockBound b =-          -- Debug.Trace.trace ("blockBound " ++ show (b,n,(yTop,yBottom),m))-          (yTop, yBottom)-          where-            -- yTop = fmap snd (maybe (Just (0,globalYMin)) (\node -> Map.lookup node m) n)-            yTop = fmap snd (maybe Nothing (`Map.lookup` m) n)-            yBottom = fmap snd (Map.lookup b m)-            n = Map.lookup b nextInLayerMap--    nextInLayerMap = foldr addLayerEdges Map.empty layers-      where-        addLayerEdges layer m = foldr addEdge m (tuples layer)-        addEdge (from, to) m = Map.insert to from m--    adjustY block newY m = foldr adj m block-      where-        adj b mp = Map.adjust (\(x, _y) -> (x, newY)) b mp--------------------------------------------------------------------------------------------------------------- The idea behind the following heuristic:--- Very frequent chaining of functions are obvious and need no attention, e.g. Data.Text.pack str--- unusual chainings need the highest attention--- a long path means it is the main path of activity, like a table of contents in a book that--- is a guide where to go. This long path should be a straight line at the top of the page.---- Sort nodes in the layers by:---   Finding the longest path with the most infrequent connections, make these nodes appear---   first (y=0) use dfs to find the second longest/infrequent path--- longestinfrequentPaths :: CGraph -> [[Node]] -> [Node]--type YNode = (YPos, Channel, UINode, IsDummy)--type YPos = Word32--type IsDummy = Bool--data Dir = LeftToRight | RightToLeft deriving (Show)--leftToRight :: Dir -> Bool-leftToRight LeftToRight = True-leftToRight RightToLeft = False--longestinfrequentPaths :: EdgeClass e => NodeClass n => CGraph n e -> [[UINode]] -> Vector Int-longestinfrequentPaths _ [] = VU.empty-longestinfrequentPaths _ [_] = VU.empty-longestinfrequentPaths g (l0 : l1 : layers)-  | null r = VU.empty-  | otherwise = VU.take (length layers + 2) $ myhead 64 r-  where-    r = map (liPaths g (l1 : layers) []) (startNodes g l0 l1)--startNodes :: EdgeClass e => CGraph n e -> [Word32] -> [Word32] -> [Word32]-startNodes g l0 l1 = mapMaybe (nodeWithChildInLayer l1) l0-  where-    nodeWithChildInLayer layer1 node-      | VU.null $-          VU.filter-            (`elem` layer1)-            (childrenNoVertical g node) =-        Nothing-      | otherwise = Just node--liPaths :: EdgeClass e => NodeClass n => CGraph n e -> [[UINode]] -> [UINode] -> UINode -> Vector Int-liPaths _ [] ns node = VU.fromList (map fromIntegral (node : ns))-liPaths g (l0 : layers) ns node = VU.concatMap (liPaths g layers (node : ns)) cs-  where-    cs =-      VU.filter-        --        (\x -> (maybe False (not . isDummyLabel) (Graph.lookupNode x g)) && elem x l0)-        (\x -> not (isDummy g x) && elem x l0)-        (childrenNoVertical g node)--myNub :: Ord a => [a] -> [a]-myNub = map (myhead 65) . group . sort--myNub2 :: [(Int, UINode)] -> [(Int, UINode)]-myNub2 = map (myhead 66) . groupBy nnn . sortBy nn-  where-    nn (_, n0) (_, n1) = compare n0 n1-    nnn (_, n0) (_, n1) = n0 == n1--type UnconnectedChildren = [UINode]---- | Every graph has a longest path, which is the center of attention for us--- Return layers of node ids--- This algorithm is a little bit more complicated because we can connect nodes "vertically",--- so that they are guaranteed to be all in one vertical layer--- All nodes before this vertical layer have to be placed in layers before we can proceed-longestPathAlgo :: (NodeClass n, EdgeClass e) => CGraph n e -> (CGraph n e, [[UINode]])-longestPathAlgo g =-  -- Debug.Trace.trace ("\nlongestPathAlgo\n" ++ show (g, newLayers, moveFinalNodesLeftToVert newLayers)) $-  --  Debug.Trace.trace ("\nlongestPathAlgo " ++ show g ++-  --                     "\nnewLayers" ++ show newLayers ++-  --                     "\nnodesWithoutChildren" ++ show nodesWithoutChildren ++-  --                     "\nverticalLayers" ++ show verticalLayers ++-  --                     "\noptionNodes" ++ show optionNodes ++-  --                     "\nnodesWithoutChildrenVertLayer" ++ show nodesWithoutChildrenVertLayer ++-  --                     "\n"++ showEdges g)-  (g, moveFinalNodesLeftToVert (map rmdups newLayers))-  where-    moveFinalNodesLeftToVert :: [[UINode]] -> [[UINode]]-    moveFinalNodesLeftToVert ls =-      -- Debug.Trace.trace ("nodesToMove "++ show (nodesToMove, nodesAndPrevious)) $-      (myhead 67 ls \\ nodesToMove) : (foldr insert (tail ls) nodesAndPrevious)-      where-        nodesToMove-          | length ls < 2 = []-          | otherwise = filter (notEl . VU.toList . parentsNoVertical g) (myhead 68 ls)-        notEl [n] = n `notElem` myhead 69 (tail ls)-        notEl _ = False-        insert (n, p) lays-          | null fpl = lays -- Debug.Trace.trace ("insert "++ show lays ++"\n\n"++ show (add lays (find p lays) n)) $-          | otherwise = add lays (head fpl) n-          where-            fpl = findn p lays-        nodesAndPrevious = zip nodesToMove (map (VU.head . parentsNoVertical g) nodesToMove)-        add list pos n = take (pos - 1) list ++ ((list !! (pos - 1)) ++ [n]) : (drop pos list)-        findn p l = [fst il | il <- zip [0 ..] l, p `elem` snd il]--    newLayers = layersrec (rmdups $ VU.toList nodesWithoutChildrenVertLayer) fil []-    fil = filter (not . null . sel2) verticalLayers-    sel1 (x, _, _) = x-    sel2 (_, y, _) = y-    ns = VU.map fromIntegral (VU.fromList (nodes g))-    nodesWithoutChildren = VU.filter (VU.null . cs) ns-    nodesWithoutChildrenVertLayer :: VU.Vector UINode-    nodesWithoutChildrenVertLayer =-      -- Debug.Trace.trace ("nwcvl "++ show (nodesWithoutChildren, nwcvl))-      nwcvl-      where-        nwcvl = VU.concatMap (findLayers (map sel1 verticalLayers)) nodesWithoutChildren-    findLayers :: [[UINode]] -> UINode -> VU.Vector UINode-    findLayers ls n-      | null ls = VU.singleton n-      | otherwise = VU.fromList (concat (map findL ls))-      where-        findL l-          | elem n l = l-          | otherwise = [n]-    cs node = Graph.children g node [dummyEdge Nothing 0]-    (_, optionNodes) = partitionNodes g ns -- nonOptionNodes-    verticalLayers =-      -- Debug.Trace.trace (show ("verticalLayers", VU.toList optionNodes, vLayers (VU.toList optionNodes))) $-      vLayers (VU.toList optionNodes)--    vLayers [] = []-    vLayers (n : ns1) =-      -- Debug.Trace.trace (show ("vLayers", n, newLayer, addUnconnectedChildren newLayer)) $-      (addUnconnectedChildren newLayer) : (vLayers (ns1 \\ newLayer))-      where-        newLayer = sort $ verticallyConnectedNodes g n-        addUnconnectedChildren :: [UINode] -> ([UINode], UnconnectedChildren, Bool)-        addUnconnectedChildren layer1 = (layer1, myNub $ VU.toList (VU.concat (map nonVertChildren layer1)), False)-        nonVertChildren node = childrenNoVertical g node--    -- the idea of this recursion is to go backwards from the final node and add non-vertical nodes that are fully connected at the input-    -- if there is only a vertical layer possible, add it-    layersrec :: [UINode] -> [([UINode], UnconnectedChildren, Bool)] -> [UINode] -> [[UINode]]-    layersrec curLayer vertLayers usedNodes-      | null curLayer -- Debug.Trace.trace "\n§§1 "-        =-        []-      | length usedNodes + length curLayer > length (nodes g) =-        Debug.Trace.trace-          ("\n§§2 " ++ show (curLayer, length usedNodes, usedNodes, length curLayer, length (nodes g)))-          [curLayer] -- should not happen-      | otherwise {-Debug.Trace.trace ("\n§§3 curLayer "++ show curLayer ++-                                     "\nfullyConnectedVertNodes2 " ++ show fullyConnectedVertNodes2 ++-                                     "\nnewCurLayerOrVert " ++ show newCurLayerOrVert ++-                                     "\nusedNodes " ++ show usedNodes ++-                                     "\nlayerParents curLayer " ++ show (layerParents curLayer) ++-                                     "\nvertLayers    " ++ show vertLayers ++-                                     "\nnewVertLayers " ++ show newVertLayers ++-                                     "\nfil" ++ show fil)-} =-        curLayer : (layersrec newCurLayerOrVert filtered (usedNodes ++ curLayer))-      where-        newVertLayers = map adjustConnected vertLayers-        adjustConnected (someLayer, unconnectedChildren, _) =-          -- Debug.Trace.trace ("adjustConnected " ++ show (someLayer, unconnectedChildren, newun, map (isNotMainFunctionArg g) someLayer)) $-          (someLayer, newun, null newun && all (isNotMainFunctionArg g) someLayer)-          where-            newun = unconnectedChildren \\ curLayer--        filtered-          | not (null newCurLayer) -- Debug.Trace.trace ("fil0 "++ show (newVertLayers)) $-            =-            filter (not . changed) newVertLayers-          | not (null fullyConnectedVertNodes2) -- Debug.Trace.trace ("fil1 "++ show (filter (not . isFullyConnected) newVertLayers)) $-            =-            filter (not . isFullyConnected) newVertLayers --remove fully connected vertical layers-          | otherwise -- Debug.Trace.trace ("fil2 "++ show (filter (not . isFullyConnected) newVertLayers)) $-            =-            filter (not . isFullyConnected) newVertLayers --remove fully connected vertical layers-            --        fullyConnectedVertNodes = concat (map fst (filter isFullyConnectedAndNotArg newVertLayers))-        fullyConnectedVertNodes2 = concatMap sel1 (filter isFullyConnected newVertLayers)-        --        isFullyConnectedAndNotArg (someLayer,unconnectedChildren) = Debug.Trace.trace ("isfully "++ show (null unconnectedChildren, map (isMainFunctionArg g) someLayer)) $-        --                                                                    null unconnectedChildren &&-        --                                                                    not (or (map (isMainFunctionArg g) someLayer))--        isFullyConnected (_someLayer, unconnectedChildren, _) = null unconnectedChildren--        newCurLayer =-          -- Debug.Trace.trace ("curParents"++ show (layerParents curLayer, filter shouldNodeBeAdded (layerParents curLayer))) $-          myNub (filter shouldNodeBeAdded (layerParents curLayer)) ++ concatMap sel1 (filter changed newVertLayers)-        changed (_, _, b) = b-        layerParents l = VU.toList (VU.concatMap (parentsNoVertical g) (VU.fromList l))-        newCurLayerOrVert-          | not (null newCurLayer) -- Debug.Trace.trace "not (null newCurLayer)" $ --prefer normal nodes to vertical nodes-            =-            myNub newCurLayer-          | not (null fullyConnectedVertNodes2) -- Debug.Trace.trace "not (null fullyConnectedVertNodes2)" $ --if no normal nodes are left-            =-            myNub fullyConnectedVertNodes2-          | otherwise = []-        shouldNodeBeAdded :: UINode -> Bool -- have all children been added, then node should be added-        shouldNodeBeAdded node-          | VU.null chs -- Debug.Trace.trace ("should0 "++ show (node, chs, VU.map isChildUsed chs)) $-            =-            False-          | otherwise -- Debug.Trace.trace ("should1 "++ show (node, chs, VU.map isChildUsed chs)) $-            =-            VU.and (VU.map isChildUsed chs)-              && not (isInVertLayer node)-          where-            chs = childrenNoVertical g node-            isChildUsed :: UINode -> Bool-            isChildUsed child = child `elem` (usedNodes ++ curLayer)-            isInVertLayer :: UINode -> Bool-            isInVertLayer n = any (elem n . sel1) vertLayers---- Some functions don't have an input (e.g. True).--- But a function without input can only appear directly after a case node--- That's why we insert a connection node between this case node and the function node-addMissingInputNodes :: (NodeClass n, Show n, EdgeClass e) => CGraph n e -> CGraph n e-addMissingInputNodes graph =-  -- Debug.Trace.trace ("\naddConnectionNodes"++ show (foldl addConnNode graph (map fromIntegral (nodes graph)))) $-  foldl addConnNode graph (map fromIntegral (nodes graph))-  where-    addConnNode :: (NodeClass n, Show n, EdgeClass e) => CGraph n e -> UINode -> CGraph n e-    addConnNode g n-      | VU.null ps = g-      | isFunction graph n =-        --        && isCase graph (vhead 501 ps) -- Debug.Trace.trace ("caseconn"++ show (n, VU.head ps)) $--        insertConnNode g n (vhead 502 ps) Nothing 0-      | otherwise = g-      where-        ps = parentsNoVertical graph n---- | partition nodes into non-vertically connected nodes and vertically connected nodes-partitionNodes :: EdgeClass e => CGraph n e -> VU.Vector UINode -> (VU.Vector UINode, VU.Vector UINode)-partitionNodes g =-  VU.partition-    ( \n ->-        VU.null (parentsVertical g n)-          && VU.null (childrenVertical g n)-    )---- coffmanGrahamAlgo :: Graph -> [[Int]]--- coffmanGrahamAlgo g =--addConnectionVertices :: (NodeClass n, Show n, EdgeClass e, Show e) => (CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])-addConnectionVertices (g, ls) =-  -- Debug.Trace.trace ("acv"++ show (ls, addConnectionVs (g,ls))) $-  addConnectionVs (g, ls)--addConnectionVs :: (NodeClass n, Show n, EdgeClass e, Show e) => (CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])-addConnectionVs (graph, []) = (graph, [])-addConnectionVs (graph, [l0]) = (graph, [l0])-addConnectionVs (graph, l0 : l1 : layers) = (fst adv, l0 : (snd adv))-  where-    adv = addConnectionVs (newGraph, (newLayer : layers))--    (newGraph, newLayer) = foldl dummyNodeEdge (graph, l1) (zip [(fromIntegral (m + 1)) ..] innerSs)-    m = maximum (nodes graph)--    innerSs = concatMap innerSegments l0-    innerSegments n =-      -- Debug.Trace.trace ("ps"++ show ps) $-      zip3 (repeat n) notInLayerL1Parents chans-      where-        notInLayerL1Parents = VU.toList (VU.filter isNotInLayerL1 ps)-        ps = parentsNoVertical graph n-        isNotInLayerL1 = not . (`elem` l1)-        chans = map (\e -> maybe (Nothing, 0) f e) edges-        f x = (channelNrIn (myhead 71 x), channelNrOut (myhead 72 x))-        edges = map (`lue` n) notInLayerL1Parents-        lue x y = Graph.lookupEdge (x, y) graph--    dummyNodeEdge :: (NodeClass n, Show n, EdgeClass e) => (CGraph n e, [UINode]) -> (UINode, (UINode, UINode, (Maybe Int, Int))) -> (CGraph n e, [UINode])-    dummyNodeEdge (g, l) (v, (from, to, (chanIn, chanOut))) =-      -- Debug.Trace.trace ("dummyNodeEdge"++ show (v,(from,to,chan)))-      (insertConnNode g from to chanIn chanOut, v : l)--insertConnNode :: (NodeClass n, Show n, EdgeClass e) => CGraph n e -> UINode -> UINode -> Maybe Channel -> Channel -> CGraph n e-insertConnNode graph from to chanIn chanOut =-  -- Debug.Trace.trace ("dummyNodeEdge"++ show (to, fromIntegral (m+1), chanIn, 0, chanOut, fromIntegral (m+1), from))-  Graph.deleteEdge (Just True) (to, from) $-    Graph.insertEdge (Just True) (to, fromIntegral (m + 1)) [dummyEdge chanIn 0] $-      Graph.insertEdge-        (Just True)-        (fromIntegral (m + 1), from)-        [dummyEdge Nothing chanOut]-        (Graph.insertNode (fromIntegral (m + 1)) connectionNode graph)-  where-    m = maximum (nodes graph)-    nest-      | isJust lu = Common.nestingFeatures (myFromJust 516 lu)-      | otherwise = Nothing-    lu = Graph.lookupNode from graph-    depth = maybe 1 Common.layer nest---- UIEdge 2 1 "" Curly "#ff5863" "" i False False]--crossingReduction :: (NodeClass n, Show n, EdgeClass e, Show e) => Int -> Bool -> (CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])-crossingReduction i longestP (graph, layers)-  | i > 0 -- Debug.Trace.trace ("crossingReduction\nlayers    " ++ show layers ++-  --         "\nc         "++ show c ++-  --         "\nnewlayers "++ show newLayers) $-    =-    crossingReduction (i - 1) longestP (graph, newLayers)-  | otherwise = (graph, layers)-  where-    -- nodes that are at the center of attention-    priorityNodes = VU.toList $ longestinfrequentPaths graph revLayers-    revLayers = reverse (map (map fromIntegral) layers)--    --  c = -- Debug.Trace.trace ("|r ") $ -- ++ show (layers, priorityNodes))-    --      (crossR graph LeftToRight (map (map fromIntegral) layers) priorityNodes longestP)-    --  newLayers = -- Debug.Trace.trace ("|l ") $ -- ++ show (layers, priorityNodes))-    --              map (map fromIntegral)-    --                  (reverse (crossR graph RightToLeft (reverse c) (reverse priorityNodes) longestP))--    c =-      -- Debug.Trace.trace ("|l ") $ -- ++ show (layers, priorityNodes))-      reverse (crossR graph RightToLeft (reverse (map (map fromIntegral) layers)) (reverse priorityNodes) longestP)--    newLayers =-      --      Debug.Trace.trace ("|r ") $ -- ++ show (layers, priorityNodes))-      map-        (map fromIntegral)-        (crossR graph LeftToRight c priorityNodes longestP)--crossR :: (NodeClass n, Show n, EdgeClass e, Show e) => CGraph n e -> Dir -> [[Int]] -> [Int] -> Bool -> [[Int]]-crossR _ _ [] _ _ = []-crossR g dir (l0 : l1 : layers) (n0 : n1 : ns) longestP-  | crossings l0Enum bEnum <= crossings l0Enum l1Enum =-    --          Debug.Trace.trace ("a0 " ++ show (dir,l0p, b, l1p, (n0:n1:ns), crossings l0Enum bEnum, crossings l0Enum l1Enum,l0,l1)-    --                                   ++ "\n   " ++ show (nl0,nl1)) $-    l0p : (crossR g dir (bv : layers) (n1 : ns) longestP)-  | otherwise -- map (lv g) $-  --        Debug.Trace.trace ("a1 " ++ show (dir,l0p, b, l1p,l0Enum,l1Enum,bEnum,crossings l0Enum bEnum,crossings l0Enum l1Enum)-  --                                 ++ "\n " ++ show (nl0,nl1)) $-    =-    l0p : (crossR g dir (l1p : layers) (n1 : ns) longestP)-  where-    nl0 = map fst (lv g l0)-    nl1 = map fst (lv g l1)-    --    isNoVert0 = not (or (map snd (lv g l0)))-    --    isNoVert1 = not (or (map snd (lv g l1)))-    b = barycenter g dir l0 l1 n1-    bv = map fst (lv g b)-    --    m = median     g nl0 nl1-    l0p-      | isJust (vertNum n0) || longestP = nl0-      | otherwise = nl0 -- n0 : (delete n0 nl0)-    l1p-      | isJust (vertNum n1) || longestP = nl1-      | otherwise = nl1 -- n1 : (delete n1 nl1)-    getY1 ((_, _, _, _), (y1, chan, _, _)) = (fromIntegral y1) * 10 + chan-    crossings en0 en1 =-      -- Debug.Trace.trace (if nl0 == [9] then "ee " ++ show (lexicographicSort ee) ++-      -- show (VU.map getY1 $ lexicographicSort ee) ++-      -- show (primitiveInversionCount (VU.map getY1 $ lexifromJustcographicSort ee)) else "") $-      primitiveInversionCount (VU.map getY1 $ lexicographicSort ee)-      where-        ee = VU.fromList (edgesEnum en0 en1 g dir (map fromIntegral nl0))-    l0Enum = IM.fromList (zip nl0 [0 ..])-    l1Enum = IM.fromList (zip nl1 [0 ..])-    bEnum = IM.fromList (zip b [0 ..])-    --    mEnum  = IM.fromList (zip m  [0..])--    lu n = Graph.lookupNode (fromIntegral n) g-    vertNum n = maybe Nothing Common.verticalNumber (lu n)-crossR _ _ ls ns _ = ls---- arrange vertical nodes directly below each other,--- returns Nothing if there are no vertical nodes in this layer-lv :: EdgeClass e => CGraph n e -> [Int] -> [(Int, Bool)]-lv _ [] = []-lv g (l : ls) =-  -- Debug.Trace.trace ("vertConnected "++ show ((l,ls,ls \\ vertConnected),(goUp ps),l,(goDown cs))) $-  vertConnected ++ (lv g (ls \\ (map fst vertConnected)))-  where-    vertConnected :: [(Int, Bool)]-    vertConnected-      | null up && null down = [(l, False)]-      | otherwise = map tr (up ++ [l] ++ down)-    tr ll = (ll, True)-    up = goUp ps-    down = goDown cs-    ps = map fromIntegral $ VU.toList $ parentsVertical g (fromIntegral l)-    goUp :: [Int] -> [Int]-    goUp n-      | null n = []-      | otherwise = goUp (map fromIntegral $ VU.toList $ parentsVertical g (fromIntegral (head n))) ++ [fromIntegral (head n)]--    cs = map fromIntegral $ VU.toList $ childrenVertical g (fromIntegral l)-    goDown :: [Int] -> [Int]-    goDown n-      | null n = []-      | otherwise = (fromIntegral (head n)) : (goDown (map fromIntegral $ VU.toList $ childrenVertical g (fromIntegral (head n))))---- type YNode = (YPos,Channel,UINode,IsDummy)-edgesEnum :: (NodeClass n, EdgeClass e, Show e) => IM.IntMap UINode -> IM.IntMap UINode -> CGraph n e -> Dir -> [UINode] -> [(YNode, YNode)]-edgesEnum en0 en1 gr dir l0 = catMaybes edges-  where-    edges :: [Maybe (YNode, YNode)]-    edges = map (edge en0 en1) (edgesOfLayer gr l0)-    edge :: IM.IntMap UINode -> IM.IntMap UINode -> (UINode, UINode) -> Maybe (YNode, YNode)-    edge e0 e1 (src, tgt)-      | isNothing s || isNothing t = Nothing-      | otherwise =-        Just-          ( (myFromJust 517 s, chanNr, src, isDummy gr src),-            (myFromJust 518 t, 0, tgt, isDummy gr tgt)-          )-      where-        s = IM.lookup (fromIntegral src) e0-        t = IM.lookup (fromIntegral tgt) e1-        chanNr-          | isJust lu && null (myFromJust 519 lu) = 0-          | isJust lu = channelNrOut (myhead 73 (myFromJust 520 lu))-          | otherwise = 0-        lu = Graph.lookupEdge (tgt, src) gr--    edgesOfLayer :: EdgeClass e => CGraph n e -> [UINode] -> [(UINode, UINode)]-    edgesOfLayer g l = concatMap (adjEdges g) l-    adjEdges :: EdgeClass e => CGraph n e -> Word32 -> [(UINode, UINode)]-    adjEdges g n-      | leftToRight dir = map (n,) (VU.toList (parentsNoVertical g n))-      | otherwise = map (n,) (VU.toList (childrenNoVertical g n))---- type YPos = Int--- type YNode = (YPos,Channel,UINode,IsDummy)--isNotMainFunctionArg :: NodeClass n => CGraph n e -> UINode -> Bool-isNotMainFunctionArg g node =-  -- not (maybe False isMainArg (Graph.lookupNode node g))-  not (isMainArg g node)---- Assign every node in l1 a number thats the barycenter of its neighbours in l0, then sort.--- If the node is marked as a vertical node with a number, this number has precedence in sorting-barycenter :: (NodeClass n, Show n, EdgeClass e, Show e) => CGraph n e -> Dir -> [Int] -> [Int] -> Int -> [Int]-barycenter g dir l0 l1 _ =-  -- Debug.Trace.trace ("bary " ++ show (map bc l1, sortOn snd (map bc l1))) $-  map fst (sortOn snd (map bc l1))-  where-    bc :: Int -> (Int, Double)-    bc node =-      -- Debug.Trace.trace ("bc" ++ show (dir, node, ps, cs, l0, l1, nodeWeight dir))-      (node, nodeWeight dir)-      where-        lenCs = VU.length cs-        lenPs = VU.length ps-        cs = VU.map fromIntegral (childrenNoVertical g (fromIntegral node))-        ps = VU.map fromIntegral (parentsNoVertical g (fromIntegral node))-        nodeWeight :: Dir -> Double-        nodeWeight LeftToRight-          | isJust vertNum -- Debug.Trace.trace ("bvert lr "++ show vertNum)-            =-            (fromIntegral (myFromJust 521 vertNum)) + (if VU.null cs then 0 else (subPos (VU.head cs)) * 10000)-          | lenCs == 0 =-            -- Debug.Trace.trace "bry -1"-            (-1)-          --                | node == prioNode = -2-          | otherwise =-            -- Debug.Trace.trace ("bsum lr "++ show (VU.map xpos cs)) $-            ((VU.sum (VU.map xpos cs)) / (fromIntegral lenCs)) + (if VU.null cs then 0 else (subPos (VU.head cs)) * 10000)-        nodeWeight RightToLeft-          | isJust vertNum =-            -- Debug.Trace.trace ("bvert rl "++ show vertNum)-            (fromIntegral (myFromJust 522 vertNum)) + (if VU.null cs then 0 else (subPos (VU.head cs)) * 10000)-          | lenPs == 0 -- Debug.Trace.trace "bry -1"-            =-            (-1)-          --                | node == prioNode = -2-          | otherwise -- Debug.Trace.trace ("bsum rl "++ show (VU.map xpos ps)) $-            =-            ((VU.sum (VU.map xpos ps)) / (fromIntegral lenPs)) + (if VU.null cs then 0 else (subPos (VU.head cs)) * 10000)--        lu = Graph.lookupNode (fromIntegral node) g-        vertNum = maybe Nothing Common.verticalNumber lu-        xpos :: Int -> Double-        xpos c =-          -- Debug.Trace.trace (show (c, l0,maybe 0 fromIntegral (elemIndex c l0), subPos c)) $-          (maybe 0 fromIntegral (elemIndex c l0))--        subPos :: Int -> Double-        subPos c =-          -- Debug.Trace.trace (show channel ++ " : " ++ show channels) $-          (fromIntegral channel) / (fromIntegral channels)-          where-            channel = maybe 0 channelNrOut edgeLabel-            channels = maybe 1 nrTypes (Graph.lookupNode (fromIntegral c) g)-            nrTypes x-              | isSubLabel x = subLabels x-              | otherwise = 1-            edgeLabel-              | isNothing (Graph.lookupEdge dEdge g) = Nothing-              | null (myFromJust 523 (Graph.lookupEdge dEdge g)) = Nothing-              | otherwise = fmap (myhead 74) (Graph.lookupEdge dEdge g)-            dEdge = (fromIntegral node, fromIntegral c)---- Assign every node in l0 a number thats the median of its neighbours in l1, then sort-median :: EdgeClass e => CGraph n e -> [Int] -> [Int] -> [Int]-median g l0 l1 = map fst $ sortOn snd $ map bc l0-  where-    bc :: Int -> (Int, Int)-    bc node = (node, if len == 0 then 0 else m VU.! (len `div` 2))-      where-        len = VU.length cs-        cs :: Vector Int-        cs =-          VU.map-            (\x -> fromMaybe 0 (elemIndex (fromIntegral x) l1))-            (childrenNoVertical g (fromIntegral node))-        m = VU.modify I.sort cs----TODO: radix sort---https://hackage.haskell.org/package/uvector-algorithms-0.2/docs/Data-Array-Vector-Algorithms-Radix.html---- Sort two edges lexicographically after their y-position in the layer--- An edge has two points, each point has a y-position (e.g. e0y0)--- and a node number (e.g. e0n0)-lexicographicSort :: Vector (YNode, YNode) -> VU.Vector (YNode, YNode)-lexicographicSort es = VU.modify (I.sortBy lexicographicOrdering) es-  where-    lexicographicOrdering-      ((e0y0, e0n0, _, _), (e0y1, e0n1, _, _))-      ((e1y0, e1n0, _, _), (e1y1, e1n1, _, _))-        | (e0y0 > e1y0)-            || (e0y0 == e1y0 && e0n0 > e1n0)-            || (e0y0 == e1y0 && e0n0 == e1n0 && e0y1 > e1y1)-            || (e0y0 == e1y0 && e0n0 == e1n0 && e0y1 == e1y1 && e0n1 > e1n1) =-          GT-        | e0y0 == e1y0 && e0n0 == e1n0 && e0y1 == e1y1 && e0n1 == e1n1 = EQ-        | otherwise = LT---- | See:  Simple and Efficient Bilayer Cross Counting by Barth, Mutzel, Jünger-primitiveInversionCount :: VU.Vector Int -> Int-primitiveInversionCount xs =-  sum-    [ if (xs VU.! i) > (xs VU.! j) then 1 else 0 | i <- [0 .. ((VU.length xs) - 1)], j <- [i .. ((VU.length xs) - 1)]-    ]----  where l = VU.length xs---- Modified merge sort for counting of edge crossings--- which is the same as counting inversions (see)--- http://www.geeksforgeeks.org/counting-inversions/--merge :: ([Int], Int) -> ([Int], Int) -> ([Int], Int)-merge ([], _) (ys, inv) = (ys, inv)-merge (xs, inv) ([], _) = (xs, inv)-merge (xs@(x : xt), inv0) (ys@(y : yt), inv1)-  | x <= y = (x : (fst (merge (xt, inv0) (ys, inv1))), inv0 + inv1)-  | otherwise = (y : (fst (merge (xs, inv0) (yt, inv1))), inv0 + inv1 + length xs)--split :: [a] -> ([a], [a])-split (x : y : zs) = let (xs, ys) = split zs in (x : xs, y : ys)-split [x] = ([x], [])-split [] = ([], [])--mergeSort :: ([Int], Int) -> ([Int], Int)-mergeSort ([], _) = ([], 0)-mergeSort ([x], _) = ([x], 0)-mergeSort (xs, _) =-  let (as, bs) = split xs -- num_inv-   in merge (mergeSort (as, 0)) (mergeSort (bs, 0))---- https://hackage.haskell.org/package/splaytree--- https://hackage.haskell.org/package/TreeStructures-0.0.1/docs/Data-Tree-Splay.html--fromAdj :: EdgeClass e => Map Word32 nl -> [(Word32, [Word32], [e])] -> Graph nl [e]-fromAdj nodesMap adj = foldl (newNodes nodesMap) Graph.empty adj-  where-    newNodes :: -- (Ord n, VU.Unbox n) =>-      EdgeClass e =>-      Map Word32 nl ->-      Graph nl [e] ->-      (Word32, [Word32], [e]) ->-      Graph nl [e]-    newNodes nm g (n, ns, eLabel) =-      Graph.insertEdges (Just True) edges $-        maybe id (Graph.insertNode (fromIntegral n)) (Map.lookup n nm) $-          Graph.insertNodes lookedUpNodes g-      where-        lookedUpNodes = mapMaybe addLabel ns-        addLabel n1 = fmap (n1,) (Map.lookup n nm)-        edges = zip es edgeLbls-        es = map (n,) ns-        edgeLbls = repeat eLabel------------------------------------------------------------------------------------------------------------------------------------ | To be able to jump vertically between nodes in an interactive ui-getColumns :: EdgeClass e => CGraphL n e -> (Map X [UINode], Map.Map Int [Column])-getColumns (gr, m) = (Map.fromList cols, Map.fromList (zip [0 ..] (divideTables cols)))-  where-    cols =-      map-        tupleWithX-        ( ( (map (sortBy sorty))-              . (groupBy groupx)-              . (sortBy sortx)-          )-            (map fromIntegral (Graph.nodes gr))-        )-    tupleWithX :: [UINode] -> (X, [UINode])-    tupleWithX ls = (maybe 0 fst (Map.lookup (myhead 504 ls) m), ls)-    groupx n0 n1 = maybe 0 fst (Map.lookup n0 m) == maybe 0 fst (Map.lookup n1 m)-    sortx n0 n1 = compare (maybe 0 fst (Map.lookup n0 m)) (maybe 0 fst (Map.lookup n1 m))-    sorty n0 n1 = compare (maybe 0 snd (Map.lookup n0 m)) (maybe 0 snd (Map.lookup n1 m))--    -- There can be several graphs on the screen that are connected with separating edges-    divideTables :: [Column] -> [[Column]]-    divideTables [] = []-    divideTables layers = layersWithoutSep : divideTables rest-      where-        (layersWithoutSep, rest) = sumLayers ([], layers)-        sumLayers :: ([Column], [Column]) -> ([Column], [Column])-        sumLayers (s, []) = (s, [])-        sumLayers (s, l : ls)-          | containsSeparatingEdge (snd l) = (s ++ [l], ls)-          | otherwise = sumLayers (s ++ [l], ls)-        containsSeparatingEdge ns = any cs ns-        cs n = VU.length (childrenSeparating gr n) > 0---- | To be able to jump horizontally between nodes in an interactive ui-getRows :: CGraphL n e -> Map Y [UINode]-getRows (gr, m) =-  Map.fromList $-    map-      tupleWithY-      ( ( (map (sortBy sortx))-            . (groupBy groupy)-            . (sortBy sorty)-        )-          (map fromIntegral (Graph.nodes gr))-      )-  where-    tupleWithY :: [UINode] -> (Y, [UINode])-    tupleWithY ls = (maybe 0 snd (Map.lookup (myhead 504 ls) m), ls)-    groupy n0 n1 = maybe 0 snd (Map.lookup n0 m) == maybe 0 snd (Map.lookup n1 m)-    sortx n0 n1 = compare (maybe 0 fst (Map.lookup n0 m)) (maybe 0 fst (Map.lookup n1 m))-    sorty n0 n1 = compare (maybe 0 snd (Map.lookup n0 m)) (maybe 0 snd (Map.lookup n1 m))+import           Data.List (elemIndex, find, group, groupBy, intercalate, sort, sortBy, sortOn, (\\), partition, deleteFirstsBy, zip4)+--import Data.List.Extra (groupOn, nubOrd)+import           Data.Map (Map)+import qualified Data.Map as Map+import           Data.Maybe (catMaybes, fromMaybe, isJust, fromJust, isNothing, mapMaybe)+import           Data.Set (Set)+import qualified Data.Set as Set+import           Data.Tuple (swap)+import qualified Data.Vector.Algorithms.Intro as I+import           Data.Vector.Unboxed (Vector)+import qualified Data.Vector.Unboxed as VU+import           Data.Word (Word32)+import           Graph.CommonGraph+  ( CGraph,+    CGraphL,+    Channel,+    Column,+    YBlock,+    YBlocks,+    YBlockLines,+    EdgeClass (channelNrIn, channelNrOut, dummyEdge, standard),+    EdgeType (NormalEdge),+    GraphMoveX,+    LayerFeatures (LayerFeatures, layer, boxId),+    Nesting,+    NodeClass (connectionNode, dummyNode, isConnNode, isDummy, isMainArg, isSubLabel, subLabels, nestingFeatures),+    UINode,+    X,+    Y,+    BoxId,+    childrenNoVertical,+    childrenSeparating,+    childrenVertical,+    isCase,+    isFunction,+    myFromJust,+    myHead,+    myLast,+    parentsNoVertical,+    parentsVertical,+    parentsNoVirtual,+    parentsNoVerticalOrVirtual,+    rmdups,+    verticallyConnectedNodes, updateLayer,+  )+import qualified Graph.CommonGraph as Common+import           Graph.IntMap (Graph (..), nodes)+import qualified Graph.IntMap as Graph+import           Graph.SubGraphWindows (subgraphWindows, subgraphWithWindows, getRows, getColumns, NestMap, ShowGraph)+import           Debug.Trace (trace)++------------------------------------------------------------------------------------------------------+-- * Main interface+--   ++-- | Also returns a map with Columns to allow navigation with arrows+layeredGraphAndCols ::+  (NodeClass n, EdgeClass e, ShowGraph n e) =>+  Bool ->+  CGraph n e ->+  (CGraphL n e, (Map.Map GraphMoveX [UINode], Map.Map Int ([Column], YBlockLines)))+layeredGraphAndCols cross graph = (g, getColumns g)+  where+    g = layeredGraphWithSub cross graph++-- | layered graph drawing with subgraph layouting+layeredGraphWithSub :: (NodeClass n, EdgeClass e, ShowGraph n e) => VU.Unbox UINode => Bool -> CGraph n e -> CGraphL n e+layeredGraphWithSub cross graph = -- Debug.Trace.trace (show("deepestNesting", deepestNesting graph)) $+                                  layeredGraph cross graph (nestedGraphs, Map.keys nodesOfBoxId, parentGraphOf)+  where (nestedGraphs, nodesOfBoxId, parentGraphOf) = deepestNesting graph++type BoxMap = Map BoxId (Set UINode) -- ^ nodes inside the box+type ParentGraphOf = Map (Maybe BoxId)  -- ^parent+                         (Set BoxId) -- ^children++-- | Similar to longestPathAlgo, we take the rightmost node (which is an output type node) and explore the graph from there to the left+--   When a function is exploded the nesting value of every node of this subgraph is increased by one by the explosion (ExplodeImplode.hs).+--   A difference of the nesting value of two adjacent nodes signals a new subgraph.+--   This function returns a map of subgraphs with a nesting and which graph is embedded in another graph+deepestNesting :: (NodeClass n, EdgeClass e, Show n, Enum n, Show e, Graph.ExtractNodeType n) => CGraph n e -> (NestMap, BoxMap, ParentGraphOf)+deepestNesting gr = -- Debug.Trace.trace (show ("gr", gr, "startNode", startNode, "subs", subs))+                    subs+  where+    subs | null startNode = (Map.empty, Map.empty, Map.empty)+         | otherwise = subGraphs (myHead 1 startNode) (Map.empty, Map.empty, Map.empty)+    startNode = rmdups $ VU.toList (nodesWithoutChildrenVertLayer gr)++    subGraphs :: UINode -> (NestMap, BoxMap, ParentGraphOf) -> (NestMap, BoxMap, ParentGraphOf)+    subGraphs node (nesting, boxNodes, parentOf)+      | null ps = -- Debug.Trace.trace "subGraphs0" +                  (nesting, boxNodes, parentOf)+      | otherwise = -- Debug.Trace.trace ("subGraphs1 " ++ show ps)+                    (foldr subGraphs (addNesting, addBoxNodes, addParentOf) ps)+      where lu n = Graph.lookupNode n gr+            nest n = maybe Nothing nestingFeatures (lu n)+            lay n = maybe 0 layer (nest n)+            bid n = maybe Nothing boxId (nest n)+            ps = VU.toList (parentsNoVirtual gr node)+            parentBIds = catMaybes (filter (/= (bid node)) (map bid ps))+            addNesting = -- Debug.Trace.trace ("addNesting" ++ show (node, lay node, bid node, nesting, maybe nesting (\b -> Map.insertWith Set.union (lay node) (Set.singleton b) nesting) (bid node)))+                         (maybe nesting (\b -> Map.insertWith Set.union (lay node) (Set.singleton b) nesting) (bid node))+            addBoxNodes = -- Debug.Trace.trace ("addBoxNodes" ++ show (node, lay node, bid node))+                          (maybe boxNodes (\b -> Map.insertWith Set.union b (Set.singleton node) boxNodes) (bid node))+            addParentOf :: ParentGraphOf+            addParentOf | lowerLayers (lay node) (map lay ps) = -- Debug.Trace.trace (show ("bid node", bid node, lay node, "parentBIds", node, ps, map lay ps, parentBIds))+                                                                Map.insertWith Set.union (bid node) (Set.fromList parentBIds) parentOf+                        | otherwise = parentOf+            lowerLayers n ns = any (n <) ns++-- Debug with https://dreampuf.github.io/GraphvizOnline using neato or fdp engine++-- ^ Layout a directed acyclic graph in several steps (Sugiyama)+-- 1. Assign the nodes to several layers (longest path)+-- 2. Dummy vertices for lines that are longer than a layer+-- 3. Reduce crossings, place the longest path on top+-- 4. Assign y-coordinates to the nodes so that long lines that pass several layers are+--    as straight as possible++layeredGraph ::+  (VU.Unbox UINode, NodeClass n, EdgeClass e, ShowGraph n e) =>+  Bool -> CGraph n e -> (NestMap, [BoxId], ParentGraphOf) -> CGraphL n e+layeredGraph cross graph (nest, boxids, parentGraphOf) =+  -- Debug.Trace.trace ("layered "++ show (graph, subgraphWindows (nest,boxids) ycoord) ++"\n") -- ++ showEdges graph ++ show (Graph.edgeLabels graph)) $ -- ++"\nnewGraph\n" ++ show newGraph ++"\n") $+  fst newGraph+  where+    newGraph =+      (   subgraphWithWindows (nest,boxids) .+            yCoordinateAssignement+          -- .+          --  primitiveYCoordinateAssignement+          . crossingReduction 2 cross (nest, boxids, parentGraphOf)+          . addBoxIdToLayers+          . arrangeMetaNodes+          . sortLayers+          . addConnectionNodes+          . longestPathAlgo -- does not change the graph, only computes layers+          . addMissingInputNodes+      )+        graph+    addBoxIdToLayers (gr,layers) = (gr, map (map (addBoxId gr)) layers)++    ycoord = (yCoordinateAssignement . crossingReduction 2 cross (nest, boxids, parentGraphOf) . addBoxIdToLayers+              . arrangeMetaNodes . sortLayers . addConnectionNodes . longestPathAlgo . addMissingInputNodes) graph++sortLayers (gr, ls) = (gr, map sort ls) -- makes the dummy vertices appear lower -- TODO don't move layouted nodes++addBoxId g n = (n, maybe Nothing boxId nest)+      where nest = maybe Nothing nestingFeatures lu+            lu = Graph.lookupNode (fromIntegral n) g++------------------------------------------------------------------------------------------------------+-- * Y-coordinate assignment+--++-- | No spaces between the nodes. This is good for testing purposes, because it is simple+primitiveYCoordinateAssignement :: (CGraph n e, [[UINode]]) -> CGraphL n e+primitiveYCoordinateAssignement (graph, layers) =+      -- Debug.Trace.trace ("primitiveY1 "++ show (layers,ns)) $+  (graph, Map.fromList ns, [])+  where+    ns :: [(UINode, (Int, Int))]+    ns = concat $ zipWith (\layer i -> map (incX i) layer) (map oneLayer layers) ([0 ..] :: [Int])+    oneLayer l = zip (iterate incY (0, 0)) l+    incX i ((x, y), n) = (n, (x - i, y))+    incY (x, y) = (x, y + 1)+{-+primitiveYCoordinateAssignement2 :: (CGraph, [[UINode]]) -> CGraph+primitiveYCoordinateAssignement2 (g, (la:layers)) =+    Debug.Trace.trace ("primitiveY2 "++ show (g, newGraph, ns, la, layers)) $+--                       ++ show (reverse $ oneLayer newLa layers)) $+    newGraph+  where+    newGraph = g { nodeLabels = I.fromList $ map fr2 $ map (positionNode g) (concat ns) }+    ns = zipWith (\layer i -> map (incX i) layer) (oneLayer newLa layers) ([0..] :: [Int])+    newLa = zip (iterate incY (0,0)) la+    oneLayer :: [((Int,Int), UINode)] -> [[UINode]] -> [[((Int,Int), UINode)]]+    oneLayer l0 [] = [l0]+    oneLayer l0 (l1:rest) = l0 : (oneLayer newL1 rest)+      where+        newL1 = childYOrInc 0 (-1) l1++        childYOrInc _ _ [] = []+        childYOrInc y lastY (e:es)+          | isJust cy && (fromJust cy) /= lastY =+--          Debug.Trace.trace ("cy " ++ show (fromJust cy) ++" "++ show e ++ " " ++ show lu) $+                        ((0,fromJust cy),e) : childYOrInc ((fromJust cy)+1) (fromJust cy) es+          | otherwise =+--         Debug.Trace.trace ("other y "++ show y ++" cy "++ show cy ++" "++ show e) $+                        ((0,y),e) : childYOrInc (y+1) (fromMaybe y cy) es+          where cy | VU.null (child e) = Nothing+                   | otherwise = fmap snd lu+                lu = lookup (vHead 500 (child e)) (map (\(a,b) -> (b,a)) l0)+    child el = childrenNoVertical g el+    incX i ((x,y),n) = (x-i,y,n)+    incY (x,y)     = (x,y+1)+-}+{-+positionNode :: CGraph -> (Int, Int, UINode) -> (UINode, UINodeLabel)+positionNode graph (x,y,n) =+  (n, UINodeLabel { option = maybe NoOption option lu,+                    formerNonOption = maybe False formerNonOption lu,+                    uinode = maybe (DN (DummyNode 1)) uinode lu,+                    nestingFeatures = maybe Nothing nestingFeatures lu,+                    verticalNumber = maybe Nothing verticalNumber lu+                  })+    where lu = Graph.lookupNode n graph+-}++-- | See "Fast and Simple Horizontal Coordinate Assignment" (Brandes, Köpf)+yCoordinateAssignement :: (NodeClass n, Show n, EdgeClass e, Graph.ExtractNodeType n, Show e, Enum n) => (CGraph n e, [[UINode]]) -> (CGraphL n e, [[UINode]])+yCoordinateAssignement (graph, layers) =+  --Debug.Trace.trace ("\nyCoordAssign "++ show (zipWith f [0 ..] layers, "startNs", startNs, "map (blockC", map (blockChildren edgeMap) startNs, "yblocks", yblocks)) $+  ((graph, pos, yblocks), layers)+  where+    -- newGraph = graph { nodeLabels = I.fromList placedNodes } -- for debugging (Map.fromList edgesToKeep)+    pos :: Map UINode (Int, Int)+    pos = horizontalBalancing alignUp alignDown+    alignUp = biasedAlignment graph yp ms (reverse nLayers) (True, True)+    alignDown = biasedAlignment graph yp ms (reverse nLayers) (True, False)+--  In the paper there is also a left/right alignment. I don't want this. +--  Every node is put in a fixed size column to show an order where function and type nodes alternate in the columns.+--    ru = biasedAlignment graph yp ms (reverse nLayers) (False, True)+--    rd = biasedAlignment graph yp ms (reverse nLayers) (False, False)++    ms = medians (graph, layers)+    yp = yPos layers++    nLayers = map (map connProp) layers+    connProp n = (n, isConnNode graph n)++    -- | Instead of arranging the graph nodes in a table, it can be better to arrange the nodes in columns where the nodes are placed with individual height+    -- This is necessary when nodes have highly different sizes. Since this depends on the final styling of the html, the individual height of the nodes has to be calcluated in javascript,+    -- taking the y-blocks of the yCoordinateAssignement algorithm+    yblocks = removeDups (longestPath (map (blockChildren edgeMap) startNs) [] 0 graph layers edgesToKeep True)+    removeDups :: YBlockLines -> YBlockLines+    removeDups ls = snd (foldr rm (Set.empty,[]) ls)+    rm :: YBlocks -> (Set UINode,YBlockLines) -> (Set UINode,YBlockLines)+    rm    (yb,l)     (s,res) | null new = (s, res)+                             | otherwise = (Set.union (Set.fromList (map (fst . head) (snd new))) s, new : res)+        where new :: YBlocks+              new = (yb, filter h l)+              h :: [(UINode, X)] -> Bool+              h block = not (Set.member (fst (head block)) s)++    startNs = mapMaybe (nodeWithoutParent layers edgesToKeep. last) (zipWith f (reverse [0 .. (length layers -1)]) layers)+    f i ns = map (i,) ns+    edgeMap = Map.fromList edgesToKeep+    edgesToKeep = rmdups $ concatMap (concatMap resolve . sweep2 (medians (graph, layers)) True) (tuples (reverse nLayers))+    resolve ts = rmdups $ map toNode (resolveConflicts (True, True) ts)++    -- for debugging+    --      edgesToKeep :: [(Graph.DirEdge UINode, [UIEdge])]+    --      edgesToKeep = map (\(x,y) -> (Graph.DirEdge x y, fromJust (Graph.lookupEdge (Graph.DirEdge x y) graph))) $+    --                      concat $ map (sweep medians Map.empty 0 (True,True)) (tuples (reverse nLayers))++yPos layers = Map.fromList (concat enumLayers)+  where enumLayers = map (\l -> zip l [0 ..]) layers++medians (graph, layers) = (Map.fromList lowerMedians, Map.fromList upperMedians)+  where+    upperMedians =+      -- Debug.Trace.trace ("upper"++ show (map upper ns, map (getMedian . upper) ns)) $+      mapMaybe (getMedian . upper) ns+    lowerMedians =+      -- Debug.Trace.trace ("lower"++ show (map lower ns)) $+      mapMaybe (getMedian . lower) ns+    ns = map fr $ I.toList (Graph.nodeLabels graph)+    upper (n, _) = (n, VU.toList (childrenNoVertical graph n))+    lower (n, _) = (n, VU.toList (parentsNoVertical graph n))++    getMedian (n, ns1)+      | l == 0 -- Debug.Trace.trace "get l0" $+        =+        Nothing+      | l == 1 = Just (n, Single rightMedian)+      | even l -- Debug.Trace.trace ("get lmod2"++ show (nodeLbls,ns1,(n, (leftMedian, rightMedian)))) $+        =+        Just (n, UpLowMedian leftMedian rightMedian) -- an even list has two medians+      | otherwise -- Debug.Trace.trace ("get other"++ show (nodeLbls,ns1,(n, (rightMedian, rightMedian)))) $+        =+        Just (n, Middle rightMedian) -- an odd list has only one median+      where+        leftMedian =+          -- Debug.Trace.trace ("median "++ show (n,ns1,nodeLbls,sorted,l)) $+          addConnProp (sorted !! ((l `div` 2) - 1))+        rightMedian = addConnProp (sorted !! (l `div` 2))+        l = length ns1+        sorted = sortOn fst nodeLbls+        nodeLbls = map (\node -> (fromMaybe 0 (Map.lookup node (yPos layers)), node)) ns1+        addConnProp (y, node) = (y, (node, isConnNode graph node))++-- the paper suggest to use an average of four alignments (TODO)+horizontalBalancing :: Map UINode (X, Y) -> Map UINode (X, Y) -> Map UINode (X, Y)+horizontalBalancing alignUp alignDown =+  -- Debug.Trace.trace ("horizontalBalancing "++ show (lu,ru)) --  ++"\n"++ show ld ++"\n"++ show average)+--  alignDown+  alignUp++-- average = zipWith f lu ru+--        f :: (UINode,(X,Y)) -> (UINode,(X,Y)) -> (UINode,(X,Y))+--        f (n0,(x0,y0)) (n1,(x1,y1)) | n0 /= n1 = error "horizontalBalancing n0 /= n1 "+--                                    | otherwise = (n0, (x0, (y0+y1) `div` 2 ))++type YN = (Y, (UINode, Bool))++data MYN+  = Single (Y, (UINode, Bool)) -- no medians because there is only one connection+  | Middle (Y, (UINode, Bool)) -- an odd number of connections has only one median+  | UpLowMedian (Y, (UINode, Bool)) (Y, (UINode, Bool))+  deriving (Eq, Ord, Show) -- an even number of connections has two medians++type Median = Map UINode MYN++toYN :: Bool -> (MYN, MYN) -> ((Y, (UINode, Bool)), (Y, (UINode, Bool)))+toYN left (n0, n1) = (getYN left n0, getYN left n1)++getYN :: Bool -> MYN -> (Y, (UINode, Bool))+getYN _ (Single (y, (n, b))) = (y, (n, b))+getYN _ (Middle (y, (n, b))) = (y, (n, b))+getYN left (UpLowMedian (y0, (n0, b0)) (y1, (n1, b1)))+  | left = (y0, (n0, b0))+  | otherwise = (y1, (n1, b1))++getY :: Bool -> MYN -> Y+getY _ (Single (y, _)) = y+getY _ (Middle (y, _)) = y+getY left (UpLowMedian (y0, (_n0, _b0)) (y1, (_n1, _b1)))+  | left = y0+  | otherwise = y1++getN :: MYN -> [UINode]+getN (Single (_y, (n, _b))) = [n]+getN (Middle (_y, (n, _b))) = [n]+getN (UpLowMedian (_y0, (n0, _b0)) (_y1, (n1, _b1))) = [n0, n1]++biasedAlignment ::+  (NodeClass n, Show n, EdgeClass e, Graph.ExtractNodeType n, Show e, Enum n) =>+  CGraph n e ->+  Map UINode Y ->+  (Median, Median) ->+  [[(UINode, Bool)]] ->+  (Bool, Bool) ->+  Map UINode (X, Y)+biasedAlignment graph _ medians layers dir =+  -- Debug.Trace.trace ("\nbalign"++ show (layers, balign)) $ --edgesToKeep, map sweep2 (tuples layers)) +++  --                                                                "\nunpositioned " ++ show (map removePositioned (map (map fst) layers))) $+  balign+  where+    (left, _up) = dir+    positioned = Map.keys balign+    _removePositioned ns = ns \\ positioned+    -- see with https://dreampuf.github.io/GraphvizOnline/+    balign =+      -- Debug.Trace.trace ("\n\nedgesToKeep "++ show dir ++ "\ndigraph G {" +++      --                   (concat $ map line edgesToKeep) ++"\n"++ placeNodes ++ "\n}") -- \n\nmedians "++ show medians) $+      align graph (map (map fst) layers) edgesToKeep dir+    edgesToKeep = rmdups $ concatMap (concatMap resolve . sweep2 medians left) (tuples layers)+    _line (from, to) = "\n" ++ show from ++ " -> " ++ show to+    _placeNodes = concat $ concatMap (map placeNode) (zipWith (zip . repeat) [1 ..] (map (zip [1 ..]) layers))+      where+        placeNode :: (X, (Y, (UINode, Bool))) -> String+        placeNode (x, (y, (n, _b))) = show n ++ " [pos=\"" ++ show x ++ "," ++ show (-y) ++ "!\"];\n"+    resolve :: [(MYN, MYN)] -> [(UINode, UINode)]+    resolve ts =+      -- Debug.Trace.trace ("\nresolve "++ show (ts, res))+      res+      where+        res = rmdups $ map toNode (resolveConflicts dir ts)++    _sweep :: ([(UINode, Bool)], [(UINode, Bool)]) -> [[(MYN, MYN)]]+    _sweep (layer0, layer1) =+      -- Debug.Trace.trace ("\nsweep "++ show (dir, layer0, layer1) ++"\n"++ show sfiel)+      -- Debug.Trace.trace ("(l0,l1)\n"++ show (layer0, layer1) ++"\n\n"++ show medians ++"\n\n"++ show sfiel) $+      sfiel+      where+        sfiel = sweepForIndependentEdgeLists graph medians allowedEdges dir (Map.empty, Map.empty) (0, 0) (layer0, layer1) Set.empty+        allowedEdges :: Set.Set (UINode, UINode)+        allowedEdges = Set.fromList (mapMaybe f layer0)+        --              f :: UINode -> (UINode, UINode)+        f (n, _b)+          | isJust lu = Just (n, dest)+          | otherwise = Nothing+          where+            dest = fst $ snd $ getYN (fst dir) (myFromJust 500 lu)+            lu = Map.lookup n (snd medians)++    -- sweeping through a layer to find all edges without separating them into independent lists+    -- maybe slower in some cases, faster in others+sweep2 :: (Median, Median) -> Bool -> ([(UINode, Bool)], [(UINode, Bool)]) -> [[(MYN, MYN)]]+sweep2 medians left (layer0, _layer1) =+  -- Debug.Trace.trace ("sweep2 "++ show (layer0, layer1,es))+  es+  where+    es = [catMaybes (zipWith f [0 ..] layer0)]+    f y (n, b)+      | isJust lu && isValidEdge -- Debug.Trace.trace ("sweep2lu0 "++ show lu) $+        =+        Just (Single (y, (n, b)), myFromJust 501 lu)+      | otherwise -- Debug.Trace.trace ("sweep2lu1 "++ show (n,lu))+        =+        Nothing+      where+        lu = Map.lookup n (snd medians)+        luBack = Map.lookup (fst $ snd $ getYN left $ myFromJust 502 lu) (fst medians)+        isValidEdge =+          -- Debug.Trace.trace ("n,lu,luBack "++ show (n,lu,luBack)) $+          isJust luBack && n == fst (snd $ getYN left $ myFromJust 503 luBack)++toNode :: ((a1, (a2, b1)), (a3, (b2, b3))) -> (a2, b2)+toNode ((_, (n0, _)), (_, (n1, _))) = (n0, n1)++type Insp = (Map Int (MYN, MYN), Map Int (MYN, MYN))++-- | Takes two layers and returns a list of lists of independent edges.+--   A list A of edges is independent of a list B of edges if every edge of A does not intersect or connect any edge of B.+--   This sweeping should save some time because graphs often have edges crossing near to each other.+--   The number of intersections has been reduced in crossingreduction.+--   Because of this we can assume that most edges are quite short and rectangular to layer0 and layer1.+--   A sweep in the parallel direction of the two layers should reduce the number of edges that have to be examined.+--   The overall algorithm (sweep + resolve) should have a runtime more like n*log(n) instead of n²,+--   because we only have to search for conflicts inside of these independent lists.+--   The Brandes-Köpf paper is not explaining very well how they find intersections between two layers.+--   I doubt that the whole algorithm is O(n). It seems more like a quadratic runtime in the worst case.+--   Even finding the number of intersections (without giving back the exact edges that intersect) is O(n log n),+--   See:  Simple and Efficient Bilayer Cross Counting by Barth, Mutzel, Jünger+--        or chapter 33 of Cormen: Introduction to algorithms+--   If several edges emanate from a node the algorithm takes (one of the) the median. (e.g. three edges have one median, 4 edges have two)+--   The sweep works by looking at the next node in the two layers, and comparing which node deletes more edges and+--   introduces less new edges from the set of edges to look at. Every edge has a start node (first appearing at its+--   y-position) and an end node. A start node means adding an edge when its source or target node appears in one of+--   the two layers, and the edge disappears when both its nodes have been swept over.+sweepForIndependentEdgeLists ::+  (NodeClass n, EdgeClass e) =>+  CGraph n e ->+  (Median, Median) ->+  Set (UINode, UINode) ->+  (Bool, Bool) ->+  Insp ->+  (Y, Y) ->+  ([(UINode, Bool)], [(UINode, Bool)]) ->+  Set (MYN, MYN) ->+  [[(MYN, MYN)]]+sweepForIndependentEdgeLists graph medians allowedEdges dir inspectionEdges (y0, y1) (layer0, layer1) missingEdges+  | null layer0 && null layer1 = Debug.Trace.trace ("nullnull " ++ show (layer0, layer1)) []+  | y0 >= 10 || y1 >= 10 = Debug.Trace.trace ("1010 " ++ show (y0, y1, layer0, layer1)) []+  | -- node at postion y1 is connected vertically with node at position y1+1+    (length layer1 >= 2) && verticalNode && isFunction graph hl1 =+    -- Debug.Trace.trace "sweep vert node" $+    sweepForIndependentEdgeLists graph medians allowedEdges dir sweepedOver (y0, y1 + 1) (layer0, tl1) Set.empty+  | Map.null sweepedOverFrom && Map.null sweepedOverTo =+    -- Debug.Trace.trace ("res"++ show (y0,y1) ++"\nlayer0 "++ show layer0 ++"\nlayer1 "++ show layer1+    --                    ++"\nresEdges "++ show resEdges ++"\nnewInsFrom "++ show newInsFrom ++"\nnewInsTo "+    --                    ++ show newInsTo ++"\nsweepedOver "++ show sweepedOver ++"\n") $+    resEdges : (sweepForIndependentEdgeLists graph medians allowedEdges dir sweepedOver (y0 + 1, y1 + 1) (tl0, tl1) Set.empty)+  | Map.size sweepedOverFrom < Map.size sweepedOverTo =+    -- Debug.Trace.trace (show (Map.size sweepedOverFrom)++ "<"++ show (Map.size sweepedOverTo) ++"\n"+++    --       show (y0,y1) ++"\nnewInsFrom "++ show newInsFrom ++"\nnewInsTo "++ show newInsTo+    --     ++"\nsweepedOverFrom "++ show sweepedOverFrom ++"\nsweepedOverTo "++ show sweepedOverTo ++"\n") $+    sweepForIndependentEdgeLists+      graph+      medians+      allowedEdges+      dir+      sweepedOver+      (y0 + 1, y1)+      (tl0, layer1)+      (Set.union missingEdges newMissingEdges)+  | otherwise -- Debug.Trace.trace (show (Map.size sweepedOverFrom)++ ">="++ show (Map.size sweepedOverTo) ++"\n"+++  --       show (y0,y1) ++"\nnewInsFrom "++ show newInsFrom ++"\nnewInsTo "++ show newInsTo+  --       ++"\nsweepedOverFrom "++ show sweepedOverFrom ++"\nsweepedOverTo "++ show sweepedOverTo ++"\n") $+    =+    sweepForIndependentEdgeLists+      graph+      medians+      allowedEdges+      dir+      sweepedOver+      (y0, y1 + 1)+      (layer0, tl1)+      (Set.union missingEdges newMissingEdges)+  where+    (inspectEdgesFrom, inspectEdgesTo) = inspectionEdges+    (lowerMedians, upperMedians) = medians+    (left, _up) = dir+    (n0, b0) = myHead 60 layer0+    (n1, b1) = myHead 61 layer1+    tl0+      | null layer0 = []+      | otherwise = tail layer0+    tl1+      | null layer1 = []+      | otherwise = tail layer1+    hl1 = fst (myHead 62 layer1)+    verticalNode = VU.elem (fst (myHead 63 tl1)) (Graph.adjacentNodesByAttr graph True hl1 (Graph.Edge8 Common.vertBit))+    resEdges = myNub (Map.elems newInsFrom ++ Map.elems newInsTo ++ Set.toList missingEdges)++    edgeFrom :: Maybe MYN+    edgeFrom+      | null layer0 = Nothing+      | otherwise -- Debug.Trace.trace ("up2 "++ show (n0, Map.lookup n0 upperMedians)) $+        =+        Map.lookup n0 upperMedians+    edgeTo :: Maybe MYN+    edgeTo+      | null layer1 --  || (not (Set.member (n0,n1) allowedEdges))+        =+        Nothing+      | otherwise -- Debug.Trace.trace ("up4 "++ show (n1, Map.lookup n1 lowerMedians)) $+        =+        Map.lookup n1 lowerMedians++    newInsFrom :: Map Int (MYN, MYN)+    newInsFrom+      | isJust edgeFrom && yy1 >= y1 = Map.insert yy1 (Single (y0, (n0, b0)), myFromJust 504 edgeFrom) inspectEdgesFrom+      | otherwise = inspectEdgesFrom+      where+        yy1 = getY left (myFromJust 505 edgeFrom)++    newInsTo :: Map Int (MYN, MYN)+    newInsTo+      | isJust edgeTo && yy0 >= y0 = Map.insert yy0 (myFromJust 506 edgeTo, Single (y1, (n1, b1))) inspectEdgesTo+      | otherwise = inspectEdgesTo+      where+        yy0 = getY left (myFromJust 506 edgeTo)++    newMissingEdges :: Set.Set (MYN, MYN)+    newMissingEdges+      | isJust edgeFrom && isJust edgeTo =+        Set.fromList+          [ (Single (y0, (n0, b0)), myFromJust 507 edgeFrom),+            (myFromJust 508 edgeTo, Single (y1, (n1, b1)))+          ]+      | isJust edgeFrom = Set.singleton (Single (y0, (n0, b0)), myFromJust 509 edgeFrom)+      | isJust edgeTo = Set.singleton (myFromJust 510 edgeTo, Single (y1, (n1, b1)))+      | otherwise = Set.empty++    sweepedOverFrom = Map.delete y1 newInsFrom+    sweepedOverTo = Map.delete y0 newInsTo+    sweepedOver = (sweepedOverFrom, sweepedOverTo) :: Insp++-- | Either e0 prevails against all e1s or all e1s prevail against e0+data EdgeTy a = E0Prevails a | E1Prevails a | NoIntersect (a, a) deriving (Eq, Show)++resolveConflicts :: (Bool, Bool) -> [(MYN, MYN)] -> [(YN, YN)]+resolveConflicts (_, _) [] = []+resolveConflicts (left, _) [e] = [toYN left e]+resolveConflicts (left, up) es =+  -- Debug.Trace.trace ("resolveConflicts"++ show (es, resolveConfs (left,up) es 0)) $+  map (toYN left) (resolveConfs (left, up) es 0)+++-- | Compare all edges of a layer with each other. Worst case: O(n²).+-- But n can shrink fast in every round and n is small, because of sweepForIndependentEdgeLists+resolveConfs :: (Bool, Bool) -> [(MYN, MYN)] -> Int -> [(MYN, MYN)]+resolveConfs (_, _) [] _ =+  -- Debug.Trace.trace "ch0 "+  []+resolveConfs (left, up) (e0 : edges) i+  | i > 20 -- Debug.Trace.trace ("ch1 "++ show (e0:edges))+    =+    e0 : edges -- avoid endless loop+  | checkE0 consistent -- Debug.Trace.trace ("checkE0 "++ show (map te (e0:edges)) ++"\n"++ show (map _toEdges2 conflictList) ++"\n") $+    =+    e0 : (resolveConfs (left, up) removeInferiorToE0 (i + 1))+  | checkNoIntersect consistent -- Debug.Trace.trace ("check noIntersect "++ show (map te (e0:edges)) ++"\n"++ show (conflictList, consistent, i) ++ "\n") $+    =+    if null conflictList+      then e0 : edges+      else e0 : (resolveConfs (left, up) edges (i + 1)) -- concat (map toEdges conflictList)+  | otherwise -- Debug.Trace.trace ("checkE1 "++ show (map te (e0:edges)) ++"\n"++ show (conflictList, consistent, i, firstE1, edgesE1First) ++ "\n") $+    =+    resolveConfs (left, up) edgesE1First (i + 1)+  where+    conflictList = map (conflict left e0) edges++    edgesE1First = e1 : (filter (\e -> e /= e0 && e /= e1) (concatMap toEdges conflictList))+    e1 = myHead 64 (toEdges firstE1)+    firstE1 = myFromJust 511 (find e1Prevails conflictList)++    consistent = isConsistent conflictList+    checkE0 (E0Prevails True) = True+    checkE0 _ = False+    _checkE1 (E1Prevails True) = True+    _checkE1 _ = False+    checkNoIntersect (NoIntersect _) = True+    checkNoIntersect _ = False+    removeInferiorToE0 = rmdups $ concatMap toEdges (filter isNoIntersect conflictList)+    isNoIntersect (NoIntersect _) = True+    isNoIntersect _ = False+    e1Prevails (E1Prevails _) = True+    e1Prevails _ = False+    toEdges (E0Prevails e) = [e]+    toEdges (E1Prevails e) = [e]+    toEdges (NoIntersect (edge0, edge1)) = [edge0, edge1]++    _toEdges2 (E0Prevails (n0, n1)) = [te1 (n0, n1)]+    _toEdges2 (E1Prevails (n0, n1)) = [te1 (n0, n1)]+    _toEdges2 (NoIntersect ((n0, n1), (n2, n3))) = [te1 (n0, n1), te1 (n2, n3)]+    te1 (n0, n1) = (getN n0, getN n1)++-- resolveConfs _ _ _ = Debug.Trace.trace "error resolveConfs " []++-- | The resolveConflicts-algorithm has to be constructed in a consistent way+--   It should be impossible that edge e has priority to edge x (keeping e),+--   and another edge y has priority to edge e (deleting e). It would not be clear if e has to be deleted or not+isConsistent :: [EdgeTy (MYN, MYN)] -> EdgeTy Bool+isConsistent (NoIntersect _ : es) = isConsistent es+isConsistent [] = NoIntersect (True, True) -- will only be called if there is no E0Prevails or E1Prevails+isConsistent ((E0Prevails _) : es) = isAllE0OrNoIntersect es+  where+    isAllE0OrNoIntersect [] = E0Prevails True+    isAllE0OrNoIntersect ((E0Prevails _) : edges) = isAllE0OrNoIntersect edges+    isAllE0OrNoIntersect ((NoIntersect _) : edges) = isAllE0OrNoIntersect edges+    isAllE0OrNoIntersect (_ : _) = E0Prevails False -- not consistent+isConsistent ((E1Prevails _) : es) = isAllE1OrNoIntersect es+  where+    isAllE1OrNoIntersect [] = E1Prevails True+    isAllE1OrNoIntersect ((E1Prevails _) : edges) = isAllE1OrNoIntersect edges+    isAllE1OrNoIntersect ((NoIntersect _) : edges) = isAllE1OrNoIntersect edges+    isAllE1OrNoIntersect (_ : _) = E1Prevails False++conflict :: Bool -> (MYN, MYN) -> (MYN, MYN) -> EdgeTy (MYN, MYN)+conflict left (n0, n1) (n2, n3)+  | isIntersecting -- Debug.Trace.trace ("intersecting "++ show (n0,n1,n2,n3)) $+    =+    cases left (n0, n1) (n2, n3)+  | otherwise = NoIntersect ((n0, n1), (n2, n3))+  where+    isIntersecting -- two segments intersect+      =+      (getY left n0 <= getY left n2 && getY left n1 >= getY left n3)+        || (getY left n0 >= getY left n2 && getY left n1 <= getY left n3)++-- | Given two edges that intersect or connect, which one will prevail?+cases :: Bool -> (MYN, MYN) -> (MYN, MYN) -> EdgeTy (MYN, MYN)+cases left (n0, n1) (n2, n3)+  -- type 2 (one segment consists of two connection nodes and is preferred then)+  | connNode n0 && connNode n1 -- Debug.Trace.trace ("type2 0 "++ show (n0,n1,n2,n3)) $+    =+    E0Prevails (n0, n1)+  | connNode n2 && connNode n3 -- Debug.Trace.trace ("type2 1 "++ show (n0,n1,n2,n3)) $+    =+    E1Prevails (n2, n3)+  | (connNode n0 || connNode n1)+      && (connNode n2 || connNode n3) -- one connection node (type 2)+    =+    if (isMedian n0 || isMedian n1) && isSingle n2 && isSingle n3+      then -- Debug.Trace.trace ("type2 2 "++ show (n0,n1,n2,n3)) $+        E0Prevails (n0, n1)+      else E0Prevails (n2, n3)+  -- type 1 (non-inner segment crosses an inner segment)+  | (connNode n0 || connNode n1)+      && not (connNode n2)+      && not (connNode n3) -- Debug.Trace.trace ("type1 0"++ show (n0,n1,n2,n3)) $+    =+    E0Prevails (n0, n1)+  | (connNode n2 || connNode n3)+      && not (connNode n0)+      && not (connNode n1) -- Debug.Trace.trace ("type1 1"++ show (n0,n1,n2,n3)) $+    =+    E1Prevails (n2, n3)+  -- type 0 (a pair of non-inner segments)+  | not (connNode n0) && not (connNode n1)+      && not (connNode n2)+      && not (connNode n3) -- Debug.Trace.trace ("type0 "++ show (preferE0,n0,n1,n2,n3)) $+    =+    if preferE0+      then E0Prevails (n0, n1)+      else E1Prevails (n2, n3)+  | otherwise = Debug.Trace.trace "cases err" $ E0Prevails (n0, n1) -- correct? just to fix a warning+  where+    connNode (Single (_, (_, b))) = b+    connNode (Middle (_, (_, b))) = b+    connNode (UpLowMedian (_, (_, b0)) (_, (_, b1)))+      | left = b0+      | otherwise = b1+    isMedian (Single _) = False+    isMedian (Middle _) = True+    isMedian (UpLowMedian _n0 _n1) = True+    isSingle (Single _) = True+    isSingle _ = False+    preferE0+      | (isMedian n0 || isMedian n1) && not (isMedian n2) && not (isMedian n3) -- Debug.Trace.trace "p0"+        =+        True+      | (isMedian n2 || isMedian n3) && not (isMedian n0) && not (isMedian n1) -- Debug.Trace.trace "p1"+        =+        False+      | abs (getY left n0 - getY left n1) < abs (getY left n2 - getY left n3) -- Debug.Trace.trace "p2"+        =+        True+      | otherwise -- Debug.Trace.trace "p3"+        =+        False+++blockChildren :: Map UINode UINode -> (X, UINode) -> [(X, UINode)]+blockChildren edgeMap (x, n)+  | isJust lu = (x, n) : blockChildren edgeMap (x + 1, myFromJust 513 lu)+  | otherwise = [(x, n)]+    where lu = Map.lookup n edgeMap++nodeWithoutParent :: [[UINode]] -> [(UINode, UINode)] -> (X, UINode) -> Maybe (X, UINode)+nodeWithoutParent layers edges (x, n)+  | isNothing (Map.lookup n reverseBlocks)+      && noParentInLayer (x, n) -- no parent in block+    =+      --  Debug.Trace.trace ("nodeWoPar0 "++ show (n, Map.lookup n reverseBlocks, noParentInLayer (x,n))) $+      Just (x, n)+  | otherwise =+    --  Debug.Trace.trace ("nodeWoPar1 "++ show (n, Map.lookup n reverseBlocks, noParentInLayer (x,n))) $+    Nothing+      where+        noParentInLayer root =+          -- Debug.Trace.trace ("noParInLayer "++ show (root, blockChildren root,+          --                   map hasNoLayerParent (blockChildren root))) $+          all hasNoLayerParent (blockChildren edgeMap root)++        hasNoLayerParent (_, _n) = isNothing (Map.lookup n layerConnections)+        reverseBlocks = Map.fromList (map swap edges)+        edgeMap = Map.fromList edges+        layerConnections = Map.fromList $ concatMap tuples layers++-- | Similar to Brandes-Köpf but without arrays and no placement of blocks+-- The basic algorithm is longest path.+-- debugging can be done with graphviz, also uncomment line 533 in longestPath | otherwise+align :: (EdgeClass e, Show n, NodeClass n, Graph.ExtractNodeType n, Show e, Enum n) => CGraph n e -> [[UINode]] -> [(UINode, UINode)] -> (Bool, Bool) -> Map UINode (X, Y)+align graph layers edges (_alignLeft, up) = -- Debug.Trace.trace ("\nalign " ++ show (lp True, lp False))+--  Debug.Trace.trace ("\nalign\ndigraph{\n" ++ (unlines (map ranksame layers))+--                      ++ (concat (map ((++ "\n") . (intercalate " -> ") . (map show)) layers))+--                      ++ (graphviz "[color=red,penwidth=2];" edges)+--                      ++ (graphviz "" _es) ++ "}\n"+--                      ++ show (startNs, map last (zipWith f [0..] layers))+--                      ++"\nblocks\n"++ show blocks ++ "\nnextInLayerMap" ++ show nextInLayerMap+--                    )+  mb2+  where+    --  | up = lp+    --  | otherwise = lpBackwards+    -- mb = Debug.Trace.trace ("lp\n" ++ show lp ++ "\nmb\n" ++ show (moveBlocks (Map.fromList lp))) $+    --     moveBlocks (Map.fromList lp)+    mb2 =+          -- Debug.Trace.trace ("lp\n" ++ show lp ++ "\nmb\n" ++ show (moveBlocks (Map.fromList lp), moveBlocksAgain (Map.fromList lp)) ++ "\n") $+          moveBlocksAgain (Map.fromList lpAddY)+    lpAddY = concat (concatMap addY (lp up))+    addY (y,ls) = map (map ay) ls where ay (n,x) = (n,(x,y))+    lp up | up        = longestPath (map (blockChildren edgeMap)          startNs)  [] 0 graph layers edges up+          | otherwise = longestPath (map (blockChildren edgeMap) (reverse startNs)) [] 0 graph layers edges up+    --        globalYMin = minimum (map (snd . snd) lp)+    --        lpBackwards = longestPath (map (blockChildren edgeMap) startNsBackwards) [] 0 graph layers edges+    edgeMap = Map.fromList edges+    reverseBlocks = Map.fromList (map swap edges)+    _es = Map.keys (Graph.edgeLabels graph) \\ edges++    startNs = mapMaybe (nodeWithoutParent layers edges . last) (zipWith f [0 ..] layers)+    --        startNsBackwards = catMaybes $ map (nodeWithoutParent . head) (zipWith f [0..] layers)+    f i ns = map (i,) ns++    -- debugging with http://www.webgraphviz.com/+    graphviz :: (Show a1, Show a2) => String -> [(a1, a2)] -> String+    graphviz col edges = concat (map l edges) ++ "\n"+      where+        l (n0, n1) = "\n" ++ show n0 ++ " -> " ++ show n1 ++ " " ++ col++    ranksame :: [UINode] -> String+    ranksame ls = "{ rank=same; " ++ intercalate " " (map show ls) ++ " }"++    blocks = extr ++ (map (\x -> [x]) rest)+      where+        extr = extractBlocks edgeMap+        rest = (concat layers \\ allNodes) \\ concat extr+        allNodes = Map.keys edgeMap ++ Map.elems edgeMap++    extractBlocks :: Map UINode UINode -> [[UINode]]+    extractBlocks m+      | Map.null m = []+      | otherwise = oneBlock ++ extractBlocks newEdgeMap -- extract one block and remove keys from the edge map+      where+        newEdgeMap =+          -- Debug.Trace.trace ("oneBlock " ++ show oneBlock) $+          foldr Map.delete m (concat oneBlock)+        oneBlock =+          filter+            (not . null)+            ( merge1 (map (fst . snd) oneBlockWithVerts)+                ++ [map fst oneBlockWithVerts]+                ++ merge1 (map (snd . snd) oneBlockWithVerts)+            )+        merge1 [] = []+        merge1 xs = (map (myHead 65) fil) : (merge1 (map myTail fil))+          where+            fil = filter (not . null) xs+        oneBlockWithVerts =+          reverse (blockNodesDown (myHead 66 ks))+            ++ myTail (blockNodesUp (myHead 67 ks))++        ks = Map.keys m ++ Map.elems m++        blockNodesDown :: UINode -> [(UINode, ([UINode], [UINode]))]+        blockNodesDown n+          | isJust lu = (n, (vertup, vertdown)) : (blockNodesDown (myFromJust 513 lu))+          | otherwise = [(n, (vertup, vertdown))]+          where+            lu = Map.lookup n edgeMap+            vertup = VU.toList (parentsVertical graph n)+            vertdown = VU.toList (childrenVertical graph n)++        blockNodesUp :: UINode -> [(UINode, ([UINode], [UINode]))]+        blockNodesUp n+          | isJust lu = (n, (vertup, vertdown)) : (blockNodesUp (myFromJust 513 lu))+          | otherwise = [(n, (vertup, vertdown))]+          where+            lu = Map.lookup n reverseBlocks+            vertup = VU.toList (parentsVertical graph n)+            vertdown = VU.toList (childrenVertical graph n)++    moveBlocks m =+      -- Debug.Trace.trace ("blocks" ++ show blocks ++ "\nm\n" ++ show (foldr moveToShortestConnection m (reverse blocks)))+      foldr moveToShortestConnection m (reverse blocks)+    moveBlocksAgain :: Map UINode (X, Y) -> Map UINode (X, Y)+    moveBlocksAgain m =+      -- Debug.Trace.trace ("blocks" ++ show blocks ++ "\nm\n" ++ show (foldr moveToShortestConnection m (reverse blocks)))+      foldr moveToShortestConnection (moveBlocks m) (reverse blocks)++    moveToShortestConnection block m+      | null bs = m+      | otherwise = -- Debug.Trace.trace ("\nblock " ++ show block +++      --       "\nbounds " ++ show bounds +++      --       "\nnewY " ++ show newY +++      --       "\nadjustY block newY m\n" ++ show (adjustY block newY m))+        adjustY block newY m+      where+        -- newY = ( (fromJust (fst (head bounds))) + (fromJust (snd (head bounds))) ) `div` 2+        bs = mapMaybe fst bounds+        newY = maximum bs + 1 -- TODO look at block connections+        bounds = map blockBound block+        blockBound b =+          -- Debug.Trace.trace ("blockBound " ++ show (b,n,(yTop,yBottom),m))+          (yTop, yBottom)+          where+            -- yTop = fmap snd (maybe (Just (0,globalYMin)) (\node -> Map.lookup node m) n)+            yTop = fmap snd (maybe Nothing (`Map.lookup` m) n)+            yBottom = fmap snd (Map.lookup b m)+            n = Map.lookup b nextInLayerMap++    nextInLayerMap = foldr addLayerEdges Map.empty layers+      where+        addLayerEdges layer m = foldr addEdge m (tuples layer)+        addEdge (from, to) m = Map.insert to from m++    adjustY block newY m = foldr adj m block+      where+        adj b mp = Map.adjust (\(x, _y) -> (x, newY)) b mp++-- * Longest Path for horizontal layers+--++longestPath :: (NodeClass n, EdgeClass e, ShowGraph n e) => +               [[(X, UINode)]] -> [UINode] -> Int -> CGraph n e -> [[UINode]] -> [(UINode, UINode)] -> Bool -> YBlockLines+longestPath [] _ _ _ _ _ _ =+  -- Debug.Trace.trace "finish"+  []+longestPath blockNodes used i graph layers edges up+  | i > 100 = [] -- Debug.Trace.trace ("reverseBlocks " ++ show (edges, reverseBlocks)) $+  | otherwise =+--      Debug.Trace.trace ( -- (concat $ map (col i) blns) ++ "\n") $+--           "\n" ++ show up ++ " blockNodes " ++ show blockNodes ++ "\n"+--        ++ " map layerChild " ++ show (map layerChild (concat blockNodes)) ++ "\n"+--        ++ "nextLayerRoots " ++ show nextLayerRoots ++ "\n"+--        ++ "map blockChildren nextLayerRoots " ++ show (map (blockChildren edgeMap) nextLayerRoots) ++ "\n"+--        ++ "blocksWithOnlyUsedParents " ++ show blocksWithOnlyUsedParents ++ "\n"+--        ++ "newUsed " ++ show newUsed+--                        ) $+    newLayer : (longestPath blocksWithOnlyUsedParents newUsed (i + 1) graph layers edges up)+  where+    newLayer = (-i, map oneLayer blockNodes)++    oneLayer :: [(X, UINode)] -> [(UINode, X)]+    oneLayer ns = map (\(x, n) -> (n, x)) ns++    nextPossibleLayerNodes | up = mapMaybe layerChild (concat blockNodes)+                           | otherwise = mapMaybe layerParent (concat blockNodes)+    --                nextPossibleLayerNodesBackwards = catMaybes (map layerParent (concat blockNodes))++    nextLayerRoots = myNub2 (map findRoot nextPossibleLayerNodes)+    --                nextLayerRootsBackwards = myNub2 (map findRoot nextPossibleLayerNodesBackwards)++    findRoot :: (X, UINode) -> (X, UINode)+    findRoot (x, n)+      | isJust lu && x >= 0 -- Debug.Trace.trace ("findRoot " ++ show (x,n)) $+        =+        findRoot (x - 1, myFromJust 515 lu)+      | otherwise = (x, n)+      where+        lu = Map.lookup n reverseBlocks++    getBoxId n = maybe Nothing Common.boxId nest+      where nest = maybe Nothing Common.nestingFeatures lu+            lu = Graph.lookupNode n graph++    reverseBlocks = Map.fromList (map swap edges)++    layerConnections :: Map UINode UINode+    layerConnections =        Map.fromList $ concatMap tuples layers+    reverseLayerConnections = Map.fromList $ concatMap (tuples . reverse) layers++    bcs :: [[(X, UINode)]]+    bcs = -- Debug.Trace.trace ("bcs " ++ show (nextLayerRoots, map (blockChildren edgeMap) nextLayerRoots)) $+          map (blockChildren edgeMap) nextLayerRoots+    edgeMap = Map.fromList edges++    blocksWithOnlyUsedParents | up        = rmdups $ filter (noParentOrUsed layerConnections) bcs+                              | otherwise = rmdups $ filter (noParentOrUsed reverseLayerConnections) bcs+ +    layerChild (x, n) = maybe Nothing (\node -> Just (x, node)) (Map.lookup n reverseLayerConnections)+    layerParent (x,n) = maybe Nothing (\node -> Just (x,node)) (Map.lookup n layerConnections)+    newUsed = used ++ blns+    blns = map snd (concat blockNodes)+    noParentOrUsed :: Map UINode UINode -> [(X, UINode)] -> Bool+    noParentOrUsed layerCs block =+      if all (noParOrUsed layerCs) block && not (sameBoxId block) -- && (not (sameBoxId block || (not hasBlockWithSameBoxId && not (sameBoxId block))))+       then -- Debug.Trace.trace ("\nnoParentOrUsed "++ show (map snd block, Map.lookup (snd (head block)) layerConnections, map (map snd) blockNodes, "samBoxId", sameBoxId block) ++"\n" ++ +            --                  show ("bcs", bcs) ++ "\n" ++ +            --                  show ("blocksWithSameBoxId",map (map snd) blocksWithSameBoxId) ++ "\n" ++ +            --                  show ("filter f           ", map (map snd) (filter f blocksWithSameBoxId)) ++ "\n" +++            --                  show ("hasBlockWithSameBoxId", hasBlockWithSameBoxId) ++ "\n" +++            --                  show ("not (sameBoxId block)", not (sameBoxId block), "map sameBoxId bcs", map sameBoxId bcs)+            --                  ) $+           all (noParOrUsed layerCs) block -- && (sameBoxId block || (not hasBlockWithSameBoxId && not (sameBoxId block)))+      else all (noParOrUsed layerCs) block+        where hasBlockWithSameBoxId = not (null (filter f blocksWithSameBoxId)) --(blocksWithSameBoxId \\ block))+              f bs = not ((snd (head block)) `elem` (map snd bs))+                  +              blocksWithSameBoxId :: [[(X, UINode)]]+              blocksWithSameBoxId = filter sameBoxId2 bcs+              sameBoxId2 b0 | isNothing lu = True+                            | otherwise = getBoxId (snd (head b0)) == getBoxId (fromJust lu)+                where lu = Map.lookup (snd (head block)) layerCs+              block2 = concat blockNodes+              sameBoxId b0 | isNothing lu = True+                           | otherwise = getBoxId (snd (head b0)) == getBoxId (fromJust lu)+                where lu = Map.lookup (snd (head b0)) layerCs+--              curBoxId = getBoxId (snd (head block))+    noParOrUsed layerCs (_, n) =+      -- Debug.Trace.trace ("noParOrUsed "++ show (n,lu)) $+      (isNothing lu || (isJust lu && elem (myFromJust 514 lu) newUsed))+      where+        lu = Map.lookup n layerCs++-- * Longest Path  for vertical layers+--++type UnconnectedChildren = [UINode]+type SubgraphLayers = [[[UINode]]] -- several graphs, where each graph has several layers, and a layer is a list of nodes++-- | Every graph has a longest path, which is the center of attention for us+-- Return layers of node ids+-- This algorithm is a little bit more complicated because we have to connect nodes vertically,+-- so that they are guaranteed to be all in one vertical layer+-- All nodes before this vertical layer have to be placed in layers before we can proceed+longestPathAlgo :: (NodeClass n, EdgeClass e, ShowGraph n e) => CGraph n e -> (CGraph n e, [[UINode]])+longestPathAlgo g = -- Debug.Trace.trace ("\nlongestPathAlgo\n" ++ show (subgraphs)) $ -- ,newLayers, moveFinalNodesLeftToVert newLayers)) $+--  Debug.Trace.trace ("\nlongestPathAlgo " ++ show (g,moveFinalNodesLeftToVert (map rmdups newLayers))) -- +++--                     "\nnewLayers" ++ show newLayers)+--                     "\nnodesWithoutChildren" ++ show nodesWithoutChildren +++--                     "\nverticalLayers" ++ show (verticalLayers g) +++--                     "\noptionNodes" ++ show optionNodes +++--                     "\nnodesWithoutChildrenVertLayer" ++ show nodesWithoutChildrenVertLayer +++--                     "\n"++ showEdges g)+                    (g, moveFinalNodesLeftToVert (map rmdups newLayers))+  where+    moveFinalNodesLeftToVert :: [[UINode]] -> [[UINode]]+    moveFinalNodesLeftToVert ls | null ls = ls -- Debug.Trace.trace ("nodesToMove "++ show (nodesToMove, nodesAndPrevious)) $+                                | otherwise = ((myHead 71 ls) \\ nodesToMove) : (foldr insert (tail ls) nodesAndPrevious)+      where nodesToMove | (length ls) < 2 = []+                        | otherwise = filter (notEl . VU.toList . (parentsNoVertical g)) (myHead 72 ls)+            notEl [n] = not (elem n (myHead 73 (tail ls)))+            notEl _ = False+            insert (n,p) lays | null fpl  = lays -- Debug.Trace.trace ("insert "++ show lays ++"\n\n"++ show (add lays (find p lays) n)) $+                              | otherwise = add lays (head fpl) n+              where fpl = find p lays+            nodesAndPrevious = zip nodesToMove (map (vHead . (parentsNoVertical g)) nodesToMove)+            add list pos n = (take (pos-1) list) ++ ((list !! (pos-1)) ++ [n]) : (drop pos list)+            find p l = [ fst il | il <- (zip [0..] l), elem p (snd il) ]++    startNode = rmdups $ VU.toList (nodesWithoutChildrenVertLayer g)+    newLayers = layersrec startNode fil [] -- (newActiveSubgraphs startNode)+    fil = filter (not . null . sel2) (verticalLayers g)++    -- the idea of this recursion is to go backwards from the final node and add non-vertical nodes that are fully connected at the input+    -- if there is only a vertical layer possible, add it+    layersrec :: [UINode] -> [([UINode],UnconnectedChildren,Bool)] -> [UINode] -> [[UINode]] -- -> SubgraphLayers+    layersrec curLayer vertLayers usedNodes -- activeSubgraphLayers+      | null curLayer = -- Debug.Trace.trace "\n§§1 "+                        []+      | (length usedNodes) + (length curLayer) > (length (nodes g)) =+                        -- Debug.Trace.trace ("\n§§2 "++ show (curLayer,length usedNodes,usedNodes,length curLayer,length (nodes g)))+                        [curLayer] -- should not happen+      | otherwise = -- Debug.Trace.trace ("\n§§3 curLayer "++ show curLayer +++                    --                   "\nfullyConnectedVertNodes " ++ show fullyConnectedVertNodes +++                    --                   "\nnewCurLayerOrVert " ++ show newCurLayerOrVert +++                    --                   "\nusedNodes " ++ show usedNodes +++                    --                   "\nlayerParents curLayer " ++ show (layerParents curLayer) +++                    --                   "\nvertLayers    " ++ show vertLayers +++                    --                   "\nnewVertLayers " ++ show newVertLayers +++                    --                   "\nfil" ++ show fil)+                    curLayer : (layersrec newCurLayerOrVert fil (usedNodes ++ curLayer)) -- ((map myTail activeSubgraphLayers) ++ (newActiveSubgraphs curLayer)))+      where+        newVertLayers = map adjustConnected vertLayers+        adjustConnected (someLayer, unconnectedChildren, _) = -- Debug.Trace.trace ("adjustConnected " ++ show (someLayer, unconnectedChildren, newun, map (isNotMainFunctionArg g) someLayer)) $+                        (someLayer, newun, null newun && all (isNotMainFunctionArg g) someLayer)+          where newun = unconnectedChildren \\ curLayer++        isNotMainFunctionArg :: (NodeClass n, EdgeClass e) => CGraph n e -> UINode -> Bool+        isNotMainFunctionArg g node = -- not (maybe False isMainArg (Graph.lookupNode node g))+                                      not (isMainArg g node)++        fil | not (null newCurLayer) = -- Debug.Trace.trace ("fil0 "++ show (newVertLayers)) $+                                       filter (not . changed) newVertLayers+            | not (null fullyConnectedVertNodes) = -- Debug.Trace.trace ("fil1 "++ show (filter (not . isFullyConnected) newVertLayers)) $+                                                    filter (not . isFullyConnected) newVertLayers --remove fully connected vertical layers+            | otherwise = -- Debug.Trace.trace ("fil2 "++ show (filter (not . isFullyConnected) newVertLayers)) $+                                                    filter (not . isFullyConnected) newVertLayers --remove fully connected vertical layers+--        fullyConnectedVertNodes = concat (map fst (filter isFullyConnectedAndNotArg newVertLayers))+        fullyConnectedVertNodes = concatMap sel1 (filter isFullyConnected newVertLayers)+--        isFullyConnectedAndNotArg (someLayer,unconnectedChildren) = Debug.Trace.trace ("isfully "++ show (null unconnectedChildren, map (isMainFunctionArg g) someLayer)) $+--                                                                    null unconnectedChildren &&+--                                                                    not (or (map (isMainFunctionArg g) someLayer))++        isFullyConnected (someLayer,unconnectedChildren,_) = null unconnectedChildren++        newCurLayer = -- Debug.Trace.trace (show ("layerParents curLayer", layerParents curLayer,+                      --                         "filter shouldNodeBeAdded (layerParents curLayer)", filter shouldNodeBeAdded (layerParents curLayer),+                      --                         "concatMap sel1 (filter changed newVertLayers)", concatMap sel1 (filter changed newVertLayers))) $+                      (myNub (filter shouldNodeBeAdded (layerParents curLayer))) +++                      (concatMap sel1 (filter changed newVertLayers)) -- +++                      -- (concatMap pickFirstLayer activeSubgraphLayers)++--        pickFirstLayer :: [[UINode]] -> [UINode]+--        pickFirstLayer graphLayers = map head (filter (not . null) graphLayers)+        changed (_,_,b) = b+        layerParents l = VU.toList (VU.concatMap (parentsNoVertical g) (VU.fromList l))+        newCurLayerOrVert+            | not (null newCurLayer) = -- Debug.Trace.trace ("not (null newCurLayer)" ++ show newCurLayer) $ --prefer normal nodes to vertical nodes+                                       myNub newCurLayer+            | not (null fullyConnectedVertNodes) = -- Debug.Trace.trace ("not (null fullyConnectedVertNodes2)"++ show fullyConnectedVertNodes) $ --if no normal nodes are left+                                                   myNub fullyConnectedVertNodes+            | otherwise = -- Debug.Trace.trace "newCurLayerOrVert2" $+                          []++        -- | Have all children been added, then node should be added+        --   No vertical nodes are added here+        shouldNodeBeAdded :: UINode -> Bool+        shouldNodeBeAdded node | VU.null chs = -- Debug.Trace.trace ("should0 "++ show (node, chs, VU.map isChildUsed chs)) $+                                               False+                               | otherwise = -- Debug.Trace.trace ("should1 "++ show (node, chs, VU.map isChildUsed chs, isInVertLayer node)) $+                                             VU.and (VU.map isChildUsed chs) &&+                                             (not (isInVertLayer node))+          where chs = childrenNoVertical g node+                isChildUsed :: UINode -> Bool+                isChildUsed child = elem child (usedNodes ++ curLayer)+                isInVertLayer :: UINode -> Bool+                isInVertLayer n = or (map ((elem n). sel1) vertLayers)++        myTail ls | null ls = []+                  | otherwise = tail ls++--    newActiveSubgraphs :: [UINode] -> [[[UINode]]]+--    newActiveSubgraphs nodes = Debug.Trace.trace ("newActiveSubgraphs" ++ show (nodes, concatMap matchingSubgraph nodes, subgraphs))+--                               [] -- concatMap matchingSubgraph nodes -- O(n²), but nobody will explode more than 10 subgraphs+--      where matchingSubgraph :: UINode -> [[[UINode]]]+--            matchingSubgraph node = map (snd . subgraph) (filter sameNode subgraphs)+--              where sameNode (LayoutedSubgraph n gr) = elem node n -- n should have only 1 element++verticalLayers g = -- Debug.Trace.trace (show ("verticalLayers", VU.toList optionNodes, vLayers (VU.toList optionNodes))) $+                   vLayers (VU.toList optionNodes)+  where (_, optionNodes) = partitionNodes g ns -- nonOptionNodes+        ns = VU.map fromIntegral (VU.fromList (nodes g))+        vLayers [] = []+        vLayers (n:ns1) = -- Debug.Trace.trace (show ("vLayers", n, newLayer, addUnconnectedChildren newLayer)) $+                          (addUnconnectedChildren newLayer): (vLayers (ns1 \\ newLayer))+          where newLayer = sort $ verticallyConnectedNodes g n+                addUnconnectedChildren :: [UINode] -> ([UINode],UnconnectedChildren,Bool)+                addUnconnectedChildren layer1 = (layer1, myNub $ VU.toList (VU.concat (map nonVertChildren layer1)), False)+                nonVertChildren node = childrenNoVertical g node+++nodesWithoutChildrenVertLayer :: (NodeClass n, EdgeClass e) => CGraph n e -> VU.Vector UINode+nodesWithoutChildrenVertLayer g = -- Debug.Trace.trace ("nwcvl "++ show (nodesWithoutChildren, nwcvl))+                                  nwcvl+  where nwcvl = VU.concatMap (findLayers (map sel1 (verticalLayers g))) nodesWithoutChildren+        nodesWithoutChildren = VU.filter (\n -> not (isDummy g n) && VU.null (cs n)) ns+        cs node = Graph.children g node [dummyEdge Nothing 0]+        ns = VU.map fromIntegral (VU.fromList (nodes g))+        (_, optionNodes) = partitionNodes g ns+        findLayers :: [[UINode]] -> UINode -> VU.Vector UINode+        findLayers ls n | null ls = VU.singleton n+                        | otherwise = VU.fromList (concat (map findL ls))+          where findL l | elem n l = l+                        | otherwise = [n]+++-- | partition nodes into non-vertically connected nodes and vertically connected nodes+partitionNodes :: EdgeClass e => CGraph n e -> VU.Vector UINode -> (VU.Vector UINode, VU.Vector UINode)+partitionNodes g =+  VU.partition+    ( \n ->+        VU.null (parentsVertical g n)+          && VU.null (childrenVertical g n)+    )++-- coffmanGrahamAlgo :: Graph -> [[Int]]+-- coffmanGrahamAlgo g =++------------------------------------------------------------------------------------------------------+-- * Special needs for function networks++-- | Some functions don't have an input (e.g. True).+-- But a function without input can only appear directly after a case node+-- That's why we insert a connection node between this case node and the function node+addMissingInputNodes :: (NodeClass n, Show n, Show e, EdgeClass e) => CGraph n e -> CGraph n e+addMissingInputNodes graph =+  -- Debug.Trace.trace ("\naddConnectionNodes"++ show (foldl addConnNode graph (map fromIntegral (nodes graph)))) $+  foldl addConnNode graph (map fromIntegral (nodes graph))+  where+    addConnNode :: (NodeClass n, Show n, EdgeClass e) => CGraph n e -> UINode -> CGraph n e+    addConnNode g n+      | VU.null ps = g+      | isFunction graph n && isCase graph (vHead ps) = -- Debug.Trace.trace ("caseconn"++ show (n, vHead 1 ps)) $+        insertConnNode g n (vHead ps) Nothing 0 (Nothing,0)+      | otherwise = g+      where+        ps = parentsNoVertical graph n++-- | To prevent crossing reduction from changing the order of vertically connected nodes+--   we insert them in the right order again+arrangeMetaNodes :: (NodeClass n, Show n, EdgeClass e, Show e) => (CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])+arrangeMetaNodes (graph, layers) =+  -- Debug.Trace.trace ("arrangeMetaNodes"++ show layers ++ "\n" ++ show newLayers ++ "\n" ++ show graph)+                                   (graph, newLayers)+  where+    newLayers = map oneLayer layers+    oneLayer :: [UINode] -> [UINode]+    oneLayer ls | null metaNodes = ls+                | otherwise = (ls \\ metaNodes) ++ metaNodes+      where metaNodes = filter (\n -> isMetaNode graph n) ls++    isMetaNode :: (NodeClass n, EdgeClass e, Show n) => CGraph n e -> UINode -> Bool+    isMetaNode g node = maybe False isMetaLabel (Graph.lookupNode node g)++    isMetaLabel _ = False++------------------------------------------------------------------------------------------------------+-- * Add connection vertices+--+-- $conn+--+-- When a connection line passes several layers, connection nodes have to be added++addConnectionNodes :: (NodeClass n, Show n, Graph.ExtractNodeType n, Enum n, EdgeClass e, Show e) => (CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])+addConnectionNodes (g, ls) = addConnectionNs (g, ls)++addConnectionNs :: (NodeClass n, Show n, EdgeClass e, Show e) => (CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])+addConnectionNs (graph, []) = (graph, [])+addConnectionNs (graph, [l0]) = (graph, [l0])+addConnectionNs (graph, l0 : l1 : layers) = (fst adv, l0 : (snd adv))+  where+    adv = addConnectionNs (newGraph, (newLayer : layers))++    (newGraph, newLayer) = foldl dummyNodeEdge (graph, l1) (zip [(fromIntegral (m + 1)) ..] innerSs)+    m = maximum (nodes graph)++    innerSs = concatMap innerSegments l0+    innerSegments n =+      zip4 (repeat n) notInLayerL1Parents chans (repeat (bid,lay))+      where+        ps = parentsNoVertical graph n+        isNotInLayerL1 = not . (`elem` l1)+        notInLayerL1Parents = VU.toList (VU.filter isNotInLayerL1 ps)+        chans = map (\e -> maybe (Nothing, 0) f e) edges+        f x = (channelNrIn (myHead 74 x), channelNrOut (myHead 75 x))+        edges = map (`lue` n) notInLayerL1Parents+        lue x y = Graph.lookupEdge (x, y) graph+        nest | isJust lu = Common.nestingFeatures (myFromJust 516 lu)+             | otherwise = Nothing+        lu = Graph.lookupNode n graph+        bid = maybe Nothing Common.boxId nest+        lay = maybe 1 Common.layer nest++    dummyNodeEdge :: (NodeClass n, Show n, EdgeClass e) => (CGraph n e, [UINode]) -> (UINode, (UINode, UINode, (Maybe Int, Int), (Maybe BoxId, Nesting))) -> (CGraph n e, [UINode])+    dummyNodeEdge (g, l) (v, (from, to, (chanIn, chanOut), boxId)) =+      (insertConnNode g from to chanIn chanOut boxId, v : l)++insertConnNode :: (NodeClass n, Show n, EdgeClass e) => CGraph n e -> UINode -> UINode -> Maybe Channel -> Channel -> (Maybe BoxId, Nesting) -> CGraph n e+insertConnNode graph from to chanIn chanOut (boxId, nest) =+  Graph.deleteEdge (Just True) (to, from) $+    Graph.insertEdge (Just True) (to, fromIntegral (m + 1)) [dummyEdge chanIn 0] $+      Graph.insertEdge+        (Just True)+        (fromIntegral (m + 1), from)+        [dummyEdge Nothing chanOut]+        (Graph.insertNode (fromIntegral (m + 1)) (updateLayer (Just (LayerFeatures nest boxId Nothing)) connectionNode) graph)+  where+    m = maximum (nodes graph)++-- UIEdge 2 1 "" Curly "#ff5863" "" i False False]++------------------------------------------------------------------------------------------------------+-- * Crossing reduction+--+crossingReduction :: (NodeClass n, Show n, EdgeClass e, Show e, Graph.ExtractNodeType n, Enum n) =>+                     Int -> Bool -> (NestMap, [BoxId], ParentGraphOf) -> (CGraph n e, [[(UINode, Maybe BoxId)]]) -> (CGraph n e, [[UINode]])+crossingReduction i longestP (nestedGraphs, boxIds, parentGraphOf) (graph, layers) =+    -- Debug.Trace.trace ("parentGraphOf " ++ show (parentGraphOf)) $+    (newGraph, map (map fst) newLayers)+  where (newGraph, newLayers) = crossingRed i longestP (nestedGraphs, boxIds, parentGraphOf) (graph, layers)++-- | Crossing reduction is like taking a comb and aligning a chain of nodes from left to right and right to left until it is ordered with as little crossings as possible+crossingRed :: (NodeClass n, Show n, EdgeClass e, Show e, Graph.ExtractNodeType n, Enum n) =>+               Int -> Bool -> (NestMap, [BoxId], ParentGraphOf) -> (CGraph n e, [[(UINode, Maybe BoxId)]]) -> (CGraph n e, [[(UINode, Maybe BoxId)]])+crossingRed i longestP (nestedGraphs, boxIds, parentGraphOf) (graph, layers)+  | i > 0 =+--      Debug.Trace.trace ( -- "crossingReduction\nlayers    " ++ listShow layers +++--                         "\nc         "++ listShow c +++--                         "\nnewlayers "++ listShow newLayers) $+    crossingRed (i - 1) longestP (nestedGraphs, boxIds, parentGraphOf) (graph, newLayers)+  | otherwise = (graph, layers)+  where+    -- nodes that are at the center of attention+    priorityNodes = VU.toList $ longestinfrequentPaths graph revLayers+    revLayers = reverse (map (map first) layers)+    --  c = -- Debug.Trace.trace ("|r ") $ -- ++ show (layers, priorityNodes))+    --      (crossR graph LeftToRight (map (map fromIntegral) layers) priorityNodes longestP)+    --  newLayers = -- Debug.Trace.trace ("|l ") $ -- ++ show (layers, priorityNodes))+    --              map (map fromIntegral)+    --                  (reverse (crossR graph RightToLeft (reverse c) (reverse priorityNodes) longestP))++    c = -- Debug.Trace.trace ("|l " ++ show subgraphLayers) $ -- ++ show (layers, priorityNodes))+        reverse (crossR graph RightToLeft (reverse (map (map fi) layers)) (reverse priorityNodes) longestP parentGraphOf)++    newLayers =+      -- Debug.Trace.trace ("|r " ++ show subgraphLayers) $ -- ++ show (layers, priorityNodes))+      map+        (map fi)+        (crossR graph LeftToRight c priorityNodes longestP parentGraphOf)++first :: (Integral a, Num b1) => (a, b2) -> b1+first (n,b) = fromIntegral n+fi :: (Integral a1, Num a2) => (a1, b) -> (a2, b)+fi (n,b) = (fromIntegral n, b)++data Dir = LeftToRight | RightToLeft deriving (Show)++leftToRight :: Dir -> Bool+leftToRight LeftToRight = True+leftToRight RightToLeft = False++-- | One pass right to left and left to right+crossR :: (NodeClass n, Show n, EdgeClass e, Show e) =>+          CGraph n e -> Dir -> [[(Int, Maybe BoxId)]] -> [Int] -> Bool -> ParentGraphOf -> [[(Int, Maybe BoxId)]]+crossR _ _ [] _ _ _ = []+crossR g dir (l0 : l1 : layers) (n0 : n1 : ns) longestP parentGraphOf+  | crossings l0Enum bEnum <= crossings l0Enum l1Enum =+    --          Debug.Trace.trace ("a0 " ++ show (dir,l0p, b, l1p, (n0:n1:ns), crossings l0Enum bEnum, crossings l0Enum l1Enum,l0,l1)+    --                                   ++ "\n   " ++ show (nl0,nl1)) $+    l0p : (crossR g dir (bv : layers) (n1 : ns) longestP parentGraphOf)+  | otherwise -- map (lv g) $+  --        Debug.Trace.trace ("a1 " ++ show (dir,l0p, b, l1p,l0Enum,l1Enum,bEnum,crossings l0Enum bEnum,crossings l0Enum l1Enum)+  --                                 ++ "\n " ++ show (nl0,nl1)) $+    =+    l0p : (crossR g dir (l1p : layers) (n1 : ns) longestP parentGraphOf)+  where+    nl0 = map fst (lv g l0)+    nl1 = map fst (lv g l1)+    --    isNoVert0 = not (or (map snd (lv g l0)))+    --    isNoVert1 = not (or (map snd (lv g l1)))+    b = barycenter g dir l0 l1 parentGraphOf n1+    bv = map fst (lv g b)+    --    m = median     g nl0 nl1+    l0p+      | isJust (vertNum n0) || longestP = nl0+      | otherwise = nl0 -- n0 : (delete n0 nl0)+    l1p+      | isJust (vertNum n1) || longestP = nl1+      | otherwise = nl1 -- n1 : (delete n1 nl1)+    getY1 ((_, _, _, _), (y1, chan, _, _)) = (fromIntegral y1) * 10 + chan+    crossings en0 en1 =+      -- Debug.Trace.trace (if nl0 == [9] then "ee " ++ show (lexicographicSort ee) +++      -- show (VU.map getY1 $ lexicographicSort ee) +++      -- show (primitiveInversionCount (VU.map getY1 $ lexifromJustcographicSort ee)) else "") $+      primitiveInversionCount (VU.map getY1 $ lexicographicSort ee)+      where+        ee = VU.fromList (edgesEnum en0 en1 g dir (map first nl0))+    l0Enum = IM.fromList (zip (map fst nl0) [0 ..])+    l1Enum = IM.fromList (zip (map fst nl1) [0 ..])+    bEnum = IM.fromList (zip (map fst b) [0 ..])+    --    mEnum  = IM.fromList (zip m  [0..])++    lu n = Graph.lookupNode (fromIntegral n) g+    vertNum n = maybe Nothing Common.verticalNumber (lu n)+crossR _ _ ls ns _ _ = ls++-- | Arrange vertical nodes directly below each other,+-- returns Nothing if there are no vertical nodes in this layer+lv :: (EdgeClass e, Show n, NodeClass n) => CGraph n e -> [(Int, Maybe BoxId)] -> [((Int, Maybe BoxId), Bool)]+lv _ [] = []+lv g (l : ls) =+  -- Debug.Trace.trace ("vertConnected "++ show ((l,ls,ls \\ vertConnected),(goUp ps),l,(goDown cs))) $+  vertConnected ++ (lv g (ls \\ (map fst vertConnected)))+  where+    vertConnected :: [((Int, Maybe BoxId), Bool)]+    vertConnected+      | null up && null down = [(l, False)]+      | otherwise = map tr (up ++ [l] ++ down)+    tr ll = (ll, True)+    up = goUp ps+    down = goDown cs+    ps = map addBid $ VU.toList $ parentsVertical g (fromIntegral (fst l))+    goUp :: [(Int, Maybe BoxId)] -> [(Int, Maybe BoxId)]+    goUp n+      | null n = []+      | otherwise = goUp (map addBid $ VU.toList $ parentsVertical g (fromIntegral (fst (head n))))+                     ++ [fi (head n)]++    cs = map addBid $ VU.toList $ childrenVertical g (fromIntegral (fst l))+    goDown :: [(Int, Maybe BoxId)] -> [(Int, Maybe BoxId)]+    goDown n+      | null n = []+      | otherwise = (fi (head n)) : (goDown (map addBid $ VU.toList $ childrenVertical g (fromIntegral (fst (head n)))))+    addBid i = addBoxId g (fromIntegral i)++type YPos = Word32+type IsDummy = Bool+type YNode = (YPos, Channel, UINode, IsDummy)++edgesEnum :: (NodeClass n, EdgeClass e, Show e) => IM.IntMap UINode -> IM.IntMap UINode -> CGraph n e -> Dir -> [UINode] -> [(YNode, YNode)]+edgesEnum en0 en1 gr dir l0 = catMaybes edges+  where+    edges :: [Maybe (YNode, YNode)]+    edges = map (edge en0 en1) (edgesOfLayer gr l0)+    edge :: IM.IntMap UINode -> IM.IntMap UINode -> (UINode, UINode) -> Maybe (YNode, YNode)+    edge e0 e1 (src, tgt)+      | isNothing s || isNothing t = Nothing+      | otherwise =+        Just+          ( (myFromJust 517 s, chanNr, src, isDummy gr src),+            (myFromJust 518 t, 0, tgt, isDummy gr tgt)+          )+      where+        s = IM.lookup (fromIntegral src) e0+        t = IM.lookup (fromIntegral tgt) e1+        chanNr+          | isJust lu && null (myFromJust 519 lu) = 0+          | isJust lu = channelNrOut (myHead 77 (myFromJust 520 lu))+          | otherwise = 0+        lu = Graph.lookupEdge (tgt, src) gr++    edgesOfLayer :: EdgeClass e => CGraph n e -> [UINode] -> [(UINode, UINode)]+    edgesOfLayer g l = concatMap (adjEdges g) l+    adjEdges :: EdgeClass e => CGraph n e -> Word32 -> [(UINode, UINode)]+    adjEdges g n+      | leftToRight dir = map (n,) (VU.toList (parentsNoVertical g n))+      | otherwise = map (n,) (VU.toList (childrenNoVertical g n))+++data BaryNode = BarySingle (Int, Maybe BoxId)+              | BaryGroup [BaryNode]+instance Show BaryNode+  where show (BarySingle (i,_)) = "s " ++ show i+        show (BaryGroup is) = "g " ++ show is++-- | Assign every node in l1 a number thats the barycenter of its neighbours in l0, then sort.+-- If the node is marked as a vertical node with a number, this number has precedence in sorting+-- subgraph layouting is done here, by sorting nodes inside of blocks recursively+barycenter :: (NodeClass n, Show n, EdgeClass e, Show e) =>+              CGraph n e -> Dir -> [(Int, Maybe BoxId)] -> [(Int, Maybe BoxId)] -> ParentGraphOf -> Int -> [(Int, Maybe BoxId)]+barycenter g dir l0 l1 parentGraphOf _ =+    -- Debug.Trace.trace ("bary " ++ show (dir, l1, tree, flatten tree, integrate start)) $+    flatten tree+--    map fst (sortOn snd (zip l1 (map (bc . fst) l1))) -- use this, if there subgraph layouting makes problems+  where+    tree = map fst (integrate start)+    start = Nothing :: Maybe BoxId++    integrate :: Maybe BoxId -> [(BaryNode, Double)]+    integrate currentBlock = -- Debug.Trace.trace ("integrate " ++ show (currentBlock, nbs, singleNodes, newBaryNodes)) $+                             sortOn snd (map bcSingle singleNodes)+                             ++ map (bcGroup . sortOn snd) newBaryNodes+      where singleNodes = filter upperBlockNode l1+            upperBlockNode (n, mbid) = mbid == currentBlock+            bcSingle i = (BarySingle i, bc (fst i)) -- a single node gets a barycenter weight++            nbs = nextBlocks currentBlock+            newBaryNodes :: [[(BaryNode, Double)]]+            newBaryNodes = map integrate nbs+            bcGroup ns = (BaryGroup (map fst ns), sum (map snd ns) / fromIntegral (length ns)) -- a group of nodes from a subgraph gets an average barycenter weight++    nextBlocks :: Maybe BoxId -> [Maybe BoxId]+    nextBlocks startBlock = maybe [] (map Just . Set.toList) (Map.lookup startBlock parentGraphOf)++    flatten :: [BaryNode] -> [(Int, Maybe BoxId)]+    flatten bs = concatMap f bs+      where f (BarySingle i) = [i]+            f (BaryGroup is) = flatten is++    bc :: Int -> Double+    bc node =+      -- Debug.Trace.trace ("bc" ++ show (dir, node, ps, cs, l0, l1, nodeWeight dir))+        nodeWeight dir+      where+        lenCs = fromIntegral (VU.length cs)+        lenPs = fromIntegral (VU.length ps)+        startCs :: Vector Int+        startCs = VU.map fromIntegral (childrenNoVertical g (fromIntegral node))+        startPs :: Vector Int+        startPs = VU.map fromIntegral (parentsNoVertical g (fromIntegral node))+        verts = verticallyConnectedNodes g (fromIntegral node)+        connectedNode :: UINode+        connectedNode | VU.null startCs && VU.null startPs =+                        fromMaybe (fromIntegral node) (find isConnected verts) -- This is necessary for lambda functions where two nodes +                      | otherwise = fromIntegral node+        isConnected :: UINode -> Bool+        isConnected n = not (VU.null (childrenNoVertical g n) && VU.null (parentsNoVertical g n))++        cs = VU.map fromIntegral (childrenNoVertical g connectedNode)+        ps = VU.map fromIntegral (parentsNoVertical g connectedNode)+        size :: Double+        size = fromIntegral (length (Graph.nodes g))++        nodeWeight :: Dir -> Double+        nodeWeight LeftToRight+          | lenCs == 0 = -- Debug.Trace.trace ("b lr " ++ show (node, sumPs + subPos ps + vertFrac, sumPs, subPos ps, vertFrac)) $+                         sumPs + subPos ps + vertFrac+          | otherwise = -- Debug.Trace.trace ("b lr other "++ show (node, sumCs + subPos cs + vertFrac, sumCs, subPos cs, vertFrac )) $+                        sumCs + subPos cs + vertFrac+        nodeWeight RightToLeft+          | lenPs == 0 = -- Debug.Trace.trace ("b#rl " ++ show (node, sumCs + subPos cs + vertFrac, sumCs, subPos cs, vertFrac))$+                         sumCs + subPos cs + vertFrac+          | otherwise = -- Debug.Trace.trace ("b#rl other "++ show (node, sumPs + subPos ps + vertFrac, sumPs, subPos ps, vertFrac)) $+                        sumPs + subPos ps + vertFrac++        sumCs = VU.sum (VU.map xpos cs) / lenCs+        sumPs = VU.sum (VU.map xpos ps) / lenPs+        lu = Graph.lookupNode connectedNode g+        vertFrac :: Double+        vertFrac = (fromIntegral (fromMaybe 0 (maybe Nothing Common.verticalNumber lu))) / (size * 64)+        xpos :: Int -> Double+        xpos c =+          -- Debug.Trace.trace (show (c, l0,maybe 0 fromIntegral (elemIndex c l0), subPos c)) $+                 (maybe 0 fromIntegral (elemIndex c (map fst l0)))++        subPos :: VU.Vector Int -> Double+        subPos cs | VU.null cs = 0+                  | otherwise = -- Debug.Trace.trace (show channel ++ " : " ++ show channels) $+                                (fromIntegral channel) / ((fromIntegral channels) * 2)+          where+            channel = maybe 0 channelNrOut edgeLabel+            channels = maybe 1 nrTypes (Graph.lookupNode (fromIntegral (vHead cs)) g)+            nrTypes x+              | isSubLabel x = subLabels x+              | otherwise = 1+            edgeLabel+              | isNothing (Graph.lookupEdge dEdge g) = Nothing+              | null (myFromJust 523 (Graph.lookupEdge dEdge g)) = Nothing+              | otherwise = fmap (myHead 80) (Graph.lookupEdge dEdge g)+            dEdge = (fromIntegral connectedNode, fromIntegral (vHead cs))++-- Assign every node in l0 a number thats the median of its neighbours in l1, then sort+median :: EdgeClass e => CGraph n e -> [Int] -> [Int] -> [Int]+median g l0 l1 = map fst $ sortOn snd $ map bc l0+  where+    bc :: Int -> (Int, Int)+    bc node = (node, if len == 0 then 0 else m VU.! (len `div` 2))+      where+        len = VU.length cs+        cs :: Vector Int+        cs =+          VU.map+            (\x -> fromMaybe 0 (elemIndex (fromIntegral x) l1))+            (childrenNoVertical g (fromIntegral node))+        m = VU.modify I.sort cs++--TODO: radix sort+--https://hackage.haskell.org/package/uvector-algorithms-0.2/docs/Data-Array-Vector-Algorithms-Radix.html++-- | Sort two edges lexicographically after their y-position in the layer+-- An edge has two points, each point has a y-position (e.g. e0y0)+-- and a node number (e.g. e0n0)+lexicographicSort :: Vector (YNode, YNode) -> VU.Vector (YNode, YNode)+lexicographicSort es = VU.modify (I.sortBy lexicographicOrdering) es+  where+    lexicographicOrdering+      ((e0y0, e0n0, _, _), (e0y1, e0n1, _, _))+      ((e1y0, e1n0, _, _), (e1y1, e1n1, _, _))+        | (e0y0 > e1y0)+            || (e0y0 == e1y0 && e0n0 > e1n0)+            || (e0y0 == e1y0 && e0n0 == e1n0 && e0y1 > e1y1)+            || (e0y0 == e1y0 && e0n0 == e1n0 && e0y1 == e1y1 && e0n1 > e1n1) =+          GT+        | e0y0 == e1y0 && e0n0 == e1n0 && e0y1 == e1y1 && e0n1 == e1n1 = EQ+        | otherwise = LT++-- | See:  Simple and Efficient Bilayer Cross Counting by Barth, Mutzel, Jünger+primitiveInversionCount :: VU.Vector Int -> Int+primitiveInversionCount xs =+  sum+    [ if (xs VU.! i) > (xs VU.! j) then 1 else 0 | i <- [0 .. (l-1)], j <- [i .. (l-1)]+    ]+  where l = VU.length xs++-- | Modified merge sort for counting of edge crossings+-- which is the same as counting inversions (see)+-- http://www.geeksforgeeks.org/counting-inversions/+mergeSort :: ([Int], Int) -> ([Int], Int)+mergeSort ([], _) = ([], 0)+mergeSort ([x], _) = ([x], 0)+mergeSort (xs, _) =+  let (as, bs) = split xs -- num_inv+   in merge (mergeSort (as, 0)) (mergeSort (bs, 0))+ where+  merge :: ([Int], Int) -> ([Int], Int) -> ([Int], Int)+  merge ([], _) (ys, inv) = (ys, inv)+  merge (xs, inv) ([], _) = (xs, inv)+  merge (xs@(x : xt), inv0) (ys@(y : yt), inv1)+    | x <= y = (x : (fst (merge (xt, inv0) (ys, inv1))), inv0 + inv1)+    | otherwise = (y : (fst (merge (xs, inv0) (yt, inv1))), inv0 + inv1 + length xs)++  split :: [a] -> ([a], [a])+  split (x : y : zs) = let (xs, ys) = split zs in (x : xs, y : ys)+  split [x] = ([x], [])+  split [] = ([], [])++---------------------------------------------------------------------------------------------------------++-- | The idea behind the following heuristic:+-- Very frequent chaining of functions are obvious and need no attention, e.g. Data.Text.pack str+-- unusual chainings need the highest attention+-- a long path means it is the main path of activity, like a table of contents in a book that+-- is a guide where to go. This long path should be a straight line at the top of the page.++-- Sort nodes in the layers by:+--   Finding the longest path with the most infrequent connections, make these nodes appear+--   first (y=0) use dfs to find the second longest/infrequent path+longestinfrequentPaths :: EdgeClass e => NodeClass n => CGraph n e -> [[UINode]] -> Vector Int+longestinfrequentPaths _ [] = VU.empty+longestinfrequentPaths _ [_] = VU.empty+longestinfrequentPaths g (l0 : l1 : layers)+  | null r = VU.empty+  | otherwise = VU.take (length layers + 2) $ myHead 68 r+  where+    r = map (liPaths g (l1 : layers) []) (startNodes g l0 l1)++startNodes :: EdgeClass e => CGraph n e -> [Word32] -> [Word32] -> [Word32]+startNodes g l0 l1 = mapMaybe (nodeWithChildInLayer l1) l0+  where+    nodeWithChildInLayer layer1 node+      | VU.null $+          VU.filter+            (`elem` layer1)+            (childrenNoVertical g node) =+        Nothing+      | otherwise = Just node++liPaths :: EdgeClass e => NodeClass n => CGraph n e -> [[UINode]] -> [UINode] -> UINode -> Vector Int+liPaths _ [] ns node = VU.fromList (map fromIntegral (node : ns))+liPaths g (l0 : layers) ns node = VU.concatMap (liPaths g layers (node : ns)) cs+  where+    cs =+      VU.filter+        --        (\x -> (maybe False (not . isDummyLabel) (Graph.lookupNode x g)) && elem x l0)+        (\x -> not (isDummy g x) && elem x l0)+        (childrenNoVertical g node)++------------------------------------------------------------------------------------------------------+-- * Helper functions+--   ++fr :: (Int, n) -> (UINode, n)+fr (n, nl) = (fromIntegral n, nl)++fromAdj :: EdgeClass e => Map Word32 nl -> [(Word32, [Word32], [e])] -> Graph nl [e]+fromAdj nodesMap adj = foldl (newNodes nodesMap) Graph.empty adj+  where+    newNodes :: -- (Ord n, VU.Unbox n) =>+      EdgeClass e =>+      Map Word32 nl ->+      Graph nl [e] ->+      (Word32, [Word32], [e]) ->+      Graph nl [e]+    newNodes nm g (n, ns, eLabel) =+      Graph.insertEdges (Just True) edges $+        maybe id (Graph.insertNode (fromIntegral n)) (Map.lookup n nm) $+          Graph.insertNodes lookedUpNodes g+      where+        lookedUpNodes = mapMaybe addLabel ns+        addLabel n1 = fmap (n1,) (Map.lookup n nm)+        edges = zip es edgeLbls+        es = map (n,) ns+        edgeLbls = repeat eLabel++myTail ls | null ls = []+          | otherwise = tail ls++myNub :: Ord a => [a] -> [a]+myNub = map (myHead 69) . group . sort -- nubOrd++myNub2 :: [(Int, UINode)] -> [(Int, UINode)]+myNub2 = map (myHead 70) . groupBy nnn . sortBy nn -- nubOrd+  where+    nn (_, n0) (_, n1) = compare n0 n1+    nnn (_, n0) (_, n1) = n0 == n1++sel1 (x,y,z) = x+sel2 (x,y,z) = y+sel3 (x,y,z) = z++tuples :: [a] -> [(a, a)]+tuples (x : y : xs) = (x, y) : tuples (y : xs)+tuples _ = []++vHead = VU.head++------------------------------------------------------------------------------------------------------+-- * Debugging+--   ++col :: Int -> UINode -> String+col i n = show n ++ " " ++ c (i `mod` 5) ++ "\n"+  where+    c m+      | m == 0 = "[color = red" ++ width+      | m == 1 = "[color = green" ++ width+      | m == 2 = "[color = blue" ++ width+      | m == 3 = "[color = yellow" ++ width+      | m == 4 = "[color = turquoise" ++ width+    c _ = "[color = black" ++ width+    width = ",penwidth=" ++ show (1 + (i `div` 2)) ++ "]"++graphvizNodes :: (CGraph n e, Map.Map Int [Column]) -> String+graphvizNodes (gr, m) = concatMap ((++ "\n") . sh) (I.toList (Graph.nodeLabels gr))+  where+    sh (n, _nl) = show n ++ " [ pos = \"" ++ show (myFromJust 499 $ Map.lookup n m) ++ "!\"]"++listShow :: Show a => [a] -> String+listShow ls = concatMap ((++ "\n"). show) ls

@@ -1,218 +1,267 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, OverloadedStrings, TypeFamilies, NoMonomorphismRestriction #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TupleSections #-} -module Graph.SubGraphWindows (subgraphWindows, getColumns, getRows) where+module Graph.SubGraphWindows (subgraphWindows, subgraphWithWindows, getColumns, getRows, ShowGraph, NestMap) where  import qualified Data.IntMap as I import Data.List (groupBy, sortBy, (\\)) import Data.Map (Map) import qualified Data.Map as Map-import Data.Maybe (fromJust, fromMaybe, isJust)+import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust)+import Data.Set (Set)+import qualified Data.Set as Set import qualified Data.Vector.Unboxed as VU import Debug.Trace ( trace ) import Graph.CommonGraph-  ( CGraph,-    CGraphL,-    Column,-    LayerFeatures (..),-    NodeClass (dummyNode, isArgLabel, updateLayer),-    EdgeClass,-    UINode,-    bb,-    childrenSeparating,-    layer,-    lb,-    lbb,-    ltb,-    mid,-    myhead,-    nestingFeatures,-    parentsVertical,-    rb,-    rbb,-    rtb,-    tb,+  ( CGraph, CGraphL, Column, YBlocks, YBlockLines, BoxId, Nesting, Border(..), LayerFeatures (..), NodeClass (dummyNode, isArgLabel, updateLayer),  EdgeClass, UINode, X, Y,+    bb, childrenSeparating, layer, lb, lbb, ltb,  mid, myHead, nestingFeatures, parentsVertical, rb, rbb, rtb, tb, vHead   )-import Graph.GraphDrawing (getColumns, getRows) import Graph.IntMap (nodes) import qualified Graph.IntMap as Graph -data Span = SpanLeftBorder | SpanMiddle | SpanRightBorder | SpanOutside deriving (Show)-+data Span = SpanLeftBorder | SpanMiddle | SpanRightBorder | SpanOutside deriving (Eq,Show) data SpanInOut = Outside | Inside -type Layer = Int -- the nesting of the window:--- 0 -> dummy node--- 1 -> not part of a window--- 2 -> first window layer--type X = Int--type Y = Int- type Min = Int- type Max = Int -subgraphWindows :: (EdgeClass e, NodeClass n, Show n, VU.Unbox UINode) => CGraphL n e -> CGraphL n e-subgraphWindows (graph, pos)-  | null ns = (graph, pos)-  | otherwise -- Debug.Trace.trace ("subgraphWindows "++ show (graph,pos,newGraph,normalisedPos) ++"\n") -- ++ -- show newGraph ++"\n"+++type ShowGraph n e = (Enum n, Graph.ExtractNodeType n, Show n, Show e)+type NestMap = Map Nesting (Set BoxId) -- ^ boxes/subgraphs in layer+type RowNodesPartOfBox = (X, [Bool]) -- for every element in the row/column: Is it a box node?++-- | Returns the boxes of the graph by examining the boxID of the cell+subgraphWindows :: (NodeClass n, EdgeClass e, ShowGraph n e, VU.Unbox UINode) =>+                   (NestMap, [BoxId]) -> (CGraphL n e, [[UINode]]) -> [(Nesting, BoxId, (Min,Max), (Min,Max))]+subgraphWindows (nestedGraphs, boxIds) ((graph, pos, yblocks), layers)+  | null ns = []+  | otherwise = concat boxes+  where+    ns = I.toList (Graph.nodeLabels graph)+    normPos = strip (normalisedPos (graph, pos))+    rows :: Map Y [UINode]+    rows    =    getRows (graph, normPos, yblocks)+    columns = getColumns (graph, normPos, yblocks)+    zRows :: [(Nesting, [(BoxId, [RowNodesPartOfBox])])]+    zRows    = zLayers graph nestedGraphs (Map.toList rows)+    zColumns = zLayers graph nestedGraphs (Map.toList (fst columns))+    spansZRows = spans zRows :: Map Nesting [(BoxId, (Map X [(Min, Max)]))]+    spansZColumns = spans zColumns :: Map Nesting [(BoxId, (Map X [(Min, Max)]))]+    boxes = zipWith f (Map.toList spansZRows) (Map.toList spansZColumns)+    f :: (Nesting, [(BoxId, (Map X [(Min, Max)]))]) -> (Nesting, [(BoxId, (Map X [(Min, Max)]))]) -> [(Nesting, BoxId, (X,X), (Y,Y))]+    f (nest0, bs0) (nest1, bs1) = bs+      where bs = zipWith boxMinMax bs0 bs1+            boxMinMax (bid0, ms0) (bid1, ms1) = (nest0, bid0, minmax (concatMap snd (Map.toList ms0)), minmax (concatMap snd (Map.toList ms1)))+            minmax mm = (minimum (map fst mm),+                         maximum (map snd mm))++-- | Adds windows by changing the border property of every cell by examining the boxID of the cell+subgraphWithWindows :: (NodeClass n, EdgeClass e, ShowGraph n e, VU.Unbox UINode) =>+                   (NestMap, [BoxId]) -> (CGraphL n e, [[UINode]]) -> (CGraphL n e, [[UINode]])+subgraphWithWindows (nestedGraphs, boxIds) ((graph, pos, yblocks), layers)+  | null ns = ((graph, pos, yblocks), layers)+  | otherwise = -- Debug.Trace.trace ("filledGraph " ++ show (filledGraph, newGraph))+    -- Debug.Trace.trace ("\n\nsubgraphWindows ") -- ++ show (graph,pos,newGraph,normalisedPos) ++"\n") -- ++ -- show newGraph ++"\n"++   --                                      show pos ++"\n"++ show (rows,zRows,spans zRows) ++"\n"++ show (fst columns,zColumns, spans zColumns)) $-    =-    (newGraph, normalisedPos)+--    Debug.Trace.trace ("subgraphWindows newYblocks" ++ show (borders, newBlockNodes, yblocks, newYblocks))+    ((newGraph, normPos, newYblocks), layers)   where     newGraph =       Graph.mapNodeWithKey         changeNode         filledGraph -    changeNode :: NodeClass n => I.Key -> n -> n+    normPos = strip (normalisedPos (graph, pos))+    origPos = strip (originalPos (graph, pos))+    newYblocks = Map.toList (Map.unionWith f (Map.fromList yblocks) (Map.fromList (map extractY yblocksWithHorBorders)))++    f :: [[(UINode, X)]] -> [[(UINode, X)]] -> [[(UINode, X)]]+    f blocks0 blocks1 = foldr integrate blocks1 blocks0+      where integrate :: [(UINode, X)] -> [[(UINode, X)]] -> [[(UINode, X)]]+            integrate b0 blocks | any (oneNodePartOf b0) blocks = blocks+                                | otherwise = b0 : blocks++    oneNodePartOf :: [(UINode, X)] -> [(UINode, X)] -> Bool+    oneNodePartOf block0 block1 = any (`elem` nb1) nb0+      where nb0 = map fst block0+            nb1 = map fst block1+    extractY :: [[(UINode, (X,Y))]] -> (Y, [[(UINode, X)]])+    extractY ls = (snd (snd (head (concat ls))), map (map dropY ) ls) where dropY (n, (x,y)) = (n,x)+    -- The horizontal borders of the box are new yblocks. In javascript the borders also have to be in the same vertical position+    yblocksWithHorBorders :: [[[(UINode, (X,Y))]]]+    yblocksWithHorBorders = (map (continuousRow . sortBy sortx) . groupBy groupy . sortBy sorty) newBlockNodes+    continuousRow :: [(UINode, (X, Y))] -> [[(UINode, (X,Y))]]+    continuousRow row = continuous [head row] row+    groupy (_,(x0,y0)) (_,(x1,y1)) = y0 == y1+    sortx (_,(x0,y0)) (_,(x1,y1)) = compare x0 x1+    sorty (_,(x0,y0)) (_,(x1,y1)) = compare y0 y1++    continuous :: [(UINode, (X,Y))] -> [(UINode, (X,Y))] -> [[(UINode, (X,Y))]]+    continuous cblock (b0@(n0,(x0,y0)) : b1@(n1,(x1,y1)) : rest)+      | x0+1 == x1 = continuous (cblock ++ [b1]) (b1 : rest)+      | otherwise  = cblock : (continuous [b1] (b1 : rest))+    continuous cblock [b0@(n0,(x0,y0))] = [init cblock ++ [b0]]+    continuous cblock _ = [cblock]++    newBlockNodes :: [(UINode, (X,Y))]+    newBlockNodes = zip borders (catMaybes (map (\n -> Map.lookup (fromIntegral n) origPos) borders)) -- should all be Just values+--    borders :: [(I.Key, n)]+    borders = map (fromIntegral . fst)+                  (filter (isHorizontalBorder . fmap border . nestingFeatures . snd) (I.toList (Graph.nodeLabels newGraph)))++    isHorizontalBorder (Just (Just TopBorder)) = True+    isHorizontalBorder (Just (Just LeftTopBorder)) = True+    isHorizontalBorder (Just (Just RightTopBorder)) = True+    isHorizontalBorder (Just (Just BottomBorder)) = True+    isHorizontalBorder (Just (Just LeftBottomBorder)) = True+    isHorizontalBorder (Just (Just RightBottomBorder)) = True+    isHorizontalBorder _ = False++    changeNode :: (NodeClass n, Show n) => I.Key -> n -> n     changeNode n node = changeLayer nf n node       where nf = nestingFeatures node -    changeLayer :: NodeClass n => Maybe LayerFeatures -> I.Key -> n -> n+    changeLayer :: (NodeClass n, Show n) => Maybe LayerFeatures -> I.Key -> n -> n     changeLayer Nothing n node-      | isArgLabel node = updateLayer (changeStyle l defaultFeatures) node-      | otherwise =       updateLayer (changeStyle l defaultFeatures) node+      | isArgLabel node = -- Debug.Trace.trace ("changeLayer0 " ++ show (n,l,xy)) $ +                          updateLayer (changeStyle l defaultFeatures) node+      | otherwise =       -- Debug.Trace.trace ("changeLayer1 " ++ show (n,l,xy,changeStyle l defaultFeatures)) $ +                          updateLayer (changeStyle l defaultFeatures) node       where-        l = highestLayer xy (spans zRows) (spans zColumns)-        xy = fromMaybe (0, 0) (Map.lookup (fromIntegral n) normalisedPos)-        _xy2 = fromMaybe (0, 0) (Map.lookup (fromIntegral root) normalisedPos)-        root = rootOf graph (fromIntegral n)+        l = highestLayer xy spansZRows spansZColumns+        xy = fromMaybe (0, 0, Nothing) (Map.lookup (fromIntegral n) (normalisedPos (graph, pos)))+--        _xy2 = fromMaybe (0, 0) (Map.lookup (fromIntegral root) normalisedPos)+--        root = rootOf graph (fromIntegral n)      changeLayer nestingFeats n node-      | isArgLabel node = updateLayer (changeStyle l (Just ((fromJust nestingFeats) {layer = fst l}))) node-      | otherwise = updateLayer (changeStyle l nestingFeats) node+      | isArgLabel node = --Debug.Trace.trace ("changeLayer2 " ++ show xy) $ +                          updateLayer (changeStyle l (Just ((fromJust nestingFeats) {layer = sel1 l}))) node+      | otherwise =       --Debug.Trace.trace ("changeLayer3 " ++ show xy) $ +                          updateLayer (changeStyle l nestingFeats) node       where-        l = highestLayer xy (spans zRows) (spans zColumns)-        xy = fromMaybe (0, 0) (Map.lookup (fromIntegral n) normalisedPos)+        l = highestLayer xy spansZRows spansZColumns+        sel1 (x,y,z) = x+        xy = fromMaybe (0, 0, Nothing) (Map.lookup (fromIntegral n) (normalisedPos (graph, pos)))      rootOf :: EdgeClass e => CGraph n e -> UINode -> UINode     rootOf gr node       | VU.null psVert = node-      | otherwise = rootOf gr (VU.head psVert)+      | otherwise = rootOf gr (vHead 0 psVert)       where         psVert = parentsVertical gr node -    defaultFeatures = Just (LayerFeatures 0 Nothing)+    defaultFeatures = Just (LayerFeatures 0 Nothing Nothing) -    changeStyle :: (Int, (Span, Span)) -> Maybe LayerFeatures -> Maybe LayerFeatures-    changeStyle (n, (SpanLeftBorder, SpanLeftBorder)) style = maybeReplace style n lbb -- LeftBottomBorder-    changeStyle (n, (SpanLeftBorder, SpanMiddle)) style -- n >= 2    = maybeReplace style n mid-      =-      maybeReplace style n bb -- BottomBorder-    changeStyle (n, (SpanLeftBorder, SpanRightBorder)) style -- n >= 2    = maybeReplace style n mid-      =-      maybeReplace style n rbb -- RightBottomBorder-    changeStyle (n, (SpanMiddle, SpanLeftBorder)) style = maybeReplace style n lb -- LeftBorder-    changeStyle (n, (SpanMiddle, SpanMiddle)) style = maybeReplace style n mid-    changeStyle (n, (SpanMiddle, SpanRightBorder)) style -- n >= 2    = maybeReplace style n mid-      =-      maybeReplace style n rb -- RightBorder-    changeStyle (n, (SpanRightBorder, SpanLeftBorder)) style -- n >= 4    = maybeReplace style n mid-      =-      maybeReplace style n ltb -- LeftTopBorder-    changeStyle (n, (SpanRightBorder, SpanMiddle)) style -- n >= 4    = maybeReplace style n mid-      =-      maybeReplace style n tb -- TopBorder-    changeStyle (n, (SpanRightBorder, SpanRightBorder)) style -- n >= 4    = maybeReplace style n mid-      =-      maybeReplace style n rtb -- RightTopBorder-    changeStyle (_, _) style = style+    changeStyle :: (Nesting, Maybe BoxId, (Span, Span)) -> Maybe LayerFeatures -> Maybe LayerFeatures+    changeStyle (n, b, (SpanLeftBorder, SpanLeftBorder)) style+      = maybeReplace style n b lbb -- LeftBottomBorder+    changeStyle (n, b, (SpanLeftBorder, SpanMiddle)) style -- n >= 2    = maybeReplace style n mid+      = maybeReplace style n b bb -- BottomBorder+    changeStyle (n, b, (SpanLeftBorder, SpanRightBorder)) style -- n >= 2    = maybeReplace style n mid+      = maybeReplace style n b rbb -- RightBottomBorder+    changeStyle (n, b, (SpanMiddle, SpanLeftBorder)) style+      = maybeReplace style n b lb -- LeftBorder+    changeStyle (n, b, (SpanMiddle, SpanMiddle)) style -- No border+      = maybeReplace style n b mid+    changeStyle (n, b, (SpanMiddle, SpanRightBorder)) style -- n >= 2    = maybeReplace style n mid+      = maybeReplace style n b rb -- RightBorder+    changeStyle (n, b, (SpanRightBorder, SpanLeftBorder)) style -- n >= 4    = maybeReplace style n mid+      = maybeReplace style n b ltb -- LeftTopBorder+    changeStyle (n, b, (SpanRightBorder, SpanMiddle)) style -- n >= 4    = maybeReplace style n mid+      = maybeReplace style n b tb -- TopBorder+    changeStyle (n, b, (SpanRightBorder, SpanRightBorder)) style -- n >= 4    = maybeReplace style n mid+      = maybeReplace style n b rtb -- RightTopBorder+    changeStyle (_, _, _) style = style -    maybeReplace :: Maybe LayerFeatures -> Int -> (Int -> Maybe LayerFeatures) -> Maybe LayerFeatures-    maybeReplace (Just (LayerFeatures 0 _)) n lf = lf n-    maybeReplace (Just (LayerFeatures x _)) _ lf = lf x-    maybeReplace _ n lf = Debug.Trace.trace "_" lf n+    maybeReplace :: Maybe LayerFeatures -> Nesting -> Maybe BoxId -> (Nesting -> Maybe BoxId -> Maybe LayerFeatures) -> Maybe LayerFeatures+    maybeReplace (Just (LayerFeatures 0 Nothing _)) n b lf = lf n b+    maybeReplace (Just (LayerFeatures n b _)) _ _ lf = lf n b+    maybeReplace _ n b lf = Debug.Trace.trace "_" lf n b      filledGraph = Graph.insertNodes (map fr newNodes) graph     fr (n, nl) = (fromIntegral n, nl)-    normalisedPos = Map.map (\(x, y) -> (x - minX, y - minY)) (Map.union pos newPos) +    addBoxId k (x,y) = (x,y, bid)+      where bid = maybe Nothing boxId lf :: Maybe BoxId+            lf = maybe Nothing nestingFeatures lu :: Maybe LayerFeatures+            lu = Graph.lookupNode k graph     newNodes = zipWith dNode [(m + 1) ..] holes     newPos = Map.fromList (zip (map fromIntegral [(m + 1) ..]) holes)     dNode n _ = (n, dummyNode 1)-    m = maximum (nodes graph)+    m | null nodePositions = maximum (nodes graph)+      | otherwise = 0 -    holes :: [(Int, Int)]-    holes = [(x, y) | x <- [minX .. maxX], y <- [minY .. maxY]] \\ nodePositions+    holes :: [(Int, Int, Maybe BoxId)]+    holes = map (\(x,y) -> (x,y,Nothing))  ([(x, y) | x <- [minX .. maxX], y <- [minY .. maxY]] \\ nodePositions)      nodePositions = Map.elems pos      ns = I.toList (Graph.nodeLabels graph) -    minX = minimum (map fst nodePositions)-    minY = minimum (map snd nodePositions)-    maxX = maximum (map fst nodePositions)-    maxY = maximum (map snd nodePositions)+    minX | null nodePositions = 0+         | otherwise = minimum (map fst nodePositions)+    minY | null nodePositions = 0+         | otherwise = minimum (map snd nodePositions)+    maxX | null nodePositions = 0+         | otherwise = maximum (map fst nodePositions)+    maxY | null nodePositions = 0+         | otherwise = maximum (map snd nodePositions)      rows :: Map Y [UINode]-    rows = getRows (filledGraph, normalisedPos)-    columns = getColumns (filledGraph, normalisedPos)+    rows    = getRows    (filledGraph, strip (normalisedPos (graph, pos)), yblocks)+    columns = getColumns (filledGraph, strip (normalisedPos (graph, pos)), yblocks) -    maxZCoord = maximum $ map (\(_, nl) -> zOfNode nl) ns+    maxZCoord :: Nesting+    maxZCoord | null ns = 0+              | otherwise = maximum $ map (\(_, nl) -> zOfNode nl) ns     zOfNode nl = maybe 0 layer (nestingFeatures nl) -    zLayers :: [(X, [UINode])] -> [(Layer, [(X, [Layer])])]-    zLayers xs = map getLayer (reverse [1 .. maxZCoord])-      where-        getLayer l = (l, map zOfNodes xs)-          where-            zOfNodes (x, ns1) = (x, map zLayer ns1)-            zLayer n-              | isJust lu && zOfNode (fromJust lu) >= l = l-              | otherwise = 0-              where-                lu = Graph.lookupNode n graph--    zRows :: [(Layer, [(X, [Layer])])]-    zRows = zLayers (Map.toList rows)-    zColumns = zLayers (Map.toList (fst columns))+    spansZRows = --Debug.Trace.trace ("zRows\n" ++ show (rows,zRows) ++ "\nspans zRows\n" ++ show (spans zRows) ++ +                 --                   "\nzColumns\n" ++ show (fst columns, zColumns) ++ "\nspans zColumns\n" ++ show (spans zColumns)) $+                    spans zRows+    spansZColumns = spans zColumns -    spans :: [(Layer, [(X, [Layer])])] -> Map Layer (Map X [(Min, Max)])-    spans ls = Map.fromList (map zSpans ls)-      where-        zSpans (z, rs) = (z, Map.fromList (map rowsColums rs))-          where-            rowsColums (x, layers) = (x, minMax layers 0 0 Outside)+    zRows :: [(Nesting, [(BoxId, [RowNodesPartOfBox])])]+    zRows    = zLayers graph nestedGraphs (Map.toList rows)+    zColumns = zLayers graph nestedGraphs (Map.toList (fst columns)) -            minMax :: [Layer] -> Int -> Int -> SpanInOut -> [(Min, Max)]-            minMax [] start i Inside = [(start, i - 1)]-            minMax [] _ _ _ = []-            minMax (l : layers) start i Outside-              | l == z = minMax layers i (i + 1) Inside-              | otherwise = minMax layers start (i + 1) Outside-            minMax (l : layers) start i Inside-              | l == z = minMax layers start (i + 1) Inside-              | otherwise = (start, i - 1) : minMax layers start (i + 1) Outside+--------------------------------------------------------------------------------------------      highestLayer ::-      (X, Y) ->-      Map Layer (Map X [(Min, Max)]) ->-      Map Layer (Map X [(Min, Max)]) ->-      (Layer, (Span, Span))-    highestLayer (x, y) hrows cols = findFirstWindow maxZCoord+      (X, Y, Maybe BoxId) ->+      Map Nesting [(BoxId, Map X [(Min, Max)])] ->+      Map Nesting [(BoxId, Map X [(Min, Max)])] ->+      (Nesting, Maybe BoxId, (Span, Span))+    highestLayer (x, y, bid) hrows cols = -- Debug.Trace.trace ("highestLayer " ++ show ((x,y,bid))) $+                                          findFirstWindow maxZCoord       where-        findFirstWindow 0 = (0, (SpanOutside, SpanOutside))+        findFirstWindow 0 = (0, bid, (SpanOutside, SpanOutside))         findFirstWindow z-          | found c r = (z, (c, r))+          | found chead rhead = (z, bid, (chead, rhead))           | otherwise = findFirstWindow (z - 1)           where-            c = maybe SpanOutside (overlappedByNeighbouringSpans (x, y) True) (Map.lookup z cols)-            r = maybe SpanOutside (overlappedByNeighbouringSpans (x, y) False) (Map.lookup z hrows)+            c = filter (/= SpanOutside) (map (overlappedByNeighbouringSpans (x, y) True . snd) layerCols)+            r = filter (/= SpanOutside) (map (overlappedByNeighbouringSpans (x, y) False . snd) layerRows)+            chead | null c = SpanOutside+                  | otherwise = head c+            rhead | null r = SpanOutside+                  | otherwise = head r+            layerCols = -- Debug.Trace.trace ("layerCols " ++ show (Map.lookup z cols)) $+                        fromMaybe [] (Map.lookup z cols)+            layerRows = -- Debug.Trace.trace ("layerRows " ++ show (Map.lookup z hrows))+                        fromMaybe [] (Map.lookup z hrows)             found SpanOutside _ = False             found _ SpanOutside = False             found _ _ = True +     -- Is there at least one neighboring row/column that includes the X/Y coordinate in its span     overlappedByNeighbouringSpans :: (X, Y) -> Bool -> Map X [(Min, Max)] -> Span     overlappedByNeighbouringSpans (x, y) isColumn nspans-      | isColumn = maybe SpanOutside spanPositionColumn (minmax (goLeft x ++ goRight (x + 1)))-      | otherwise = maybe SpanOutside spanPositionRow (minmax (goLeft y ++ goRight (y + 1)))+      | isColumn = -- Debug.Trace.trace (show ("overlappedByNeighbouringSpans col",(x,y),nspans, minmax spansCol, maybe SpanOutside spanPositionColumn (minmax spansCol)))+                                     (maybe SpanOutside spanPositionColumn (minmax spansCol))+      | otherwise = -- Debug.Trace.trace (show ("overlappedByNeighbouringSpans row",(x,y),nspans, minmax spansRow, maybe SpanOutside spanPositionRow (minmax spansRow)))+                    maybe SpanOutside spanPositionRow (minmax spansRow)       where         spanPositionColumn (smin, smax)           | y == smin = SpanRightBorder@@ -229,6 +278,19 @@           | otherwise = Just (minimum (map fst xs), maximum (map snd xs))          goLeft p+          | p >= 0 = mm ++ goLeft (p - 1)+          | otherwise = mm+          where+            mm = fromMaybe [] (Map.lookup p nspans)++        goRight p+          | p < Map.size nspans = mm ++ goRight (p + 1)+          | otherwise = mm+          where+            mm = fromMaybe [] (Map.lookup p nspans)++{-+        goLeft p           | null mm = mm           | otherwise = mm ++ goLeft (p - 1)           where@@ -239,3 +301,195 @@           | otherwise = mm ++ goRight (p + 1)           where             mm = fromMaybe [] (Map.lookup p nspans)+-}+        spansCol = goLeft x ++ goRight (x + 1)+        spansRow = goLeft y ++ goRight (y + 1)+++strip :: Map k (a, b, c) -> Map k (a, b)+strip m = Map.map (\(x, y, bid) -> (x, y)) m++originalPos :: (NodeClass n, EdgeClass e, ShowGraph n e, VU.Unbox UINode) =>+                 (CGraph n e, Map UINode (X, Y)) -> Map UINode (X, Y, Maybe BoxId)+originalPos (graph, pos) = Map.map (\(x, y, bid) -> (x, y, bid)) (Map.union (Map.mapWithKey addBoxId pos) newPos)+  where+    minX | null nodePositions = 0+         | otherwise = minimum (map fst nodePositions)+    minY | null nodePositions = 0+         | otherwise = minimum (map snd nodePositions)+    maxX | null nodePositions = 0+         | otherwise = maximum (map fst nodePositions)+    maxY | null nodePositions = 0+         | otherwise = maximum (map snd nodePositions)++    nodePositions = Map.elems pos++    addBoxId k (x,y) = (x,y, bid)+      where bid = maybe Nothing boxId lf :: Maybe BoxId+            lf = maybe Nothing nestingFeatures lu :: Maybe LayerFeatures+            lu = Graph.lookupNode k graph++    newPos = Map.fromList (zip (map fromIntegral [(m + 1) ..]) holes)++    m | null nodePositions = maximum (nodes graph)+      | otherwise = 0++    holes :: [(Int, Int, Maybe BoxId)]+    holes = map (\(x,y) -> (x,y,Nothing))  ([(x, y) | x <- [minX .. maxX], y <- [minY .. maxY]] \\ nodePositions)++normalisedPos :: (NodeClass n, EdgeClass e, ShowGraph n e, VU.Unbox UINode) =>+                 (CGraph n e, Map UINode (X, Y)) -> Map UINode (X, Y, Maybe BoxId)+normalisedPos (graph, pos) = Map.map (\(x, y, bid) -> (x - minX, y - minY, bid)) (Map.union (Map.mapWithKey addBoxId pos) newPos)+  where+    minX | null nodePositions = 0+         | otherwise = minimum (map fst nodePositions)+    minY | null nodePositions = 0+         | otherwise = minimum (map snd nodePositions)+    maxX | null nodePositions = 0+         | otherwise = maximum (map fst nodePositions)+    maxY | null nodePositions = 0+         | otherwise = maximum (map snd nodePositions)++    nodePositions = Map.elems pos++    addBoxId k (x,y) = (x,y, bid)+      where bid = maybe Nothing boxId lf :: Maybe BoxId+            lf = maybe Nothing nestingFeatures lu :: Maybe LayerFeatures+            lu = Graph.lookupNode k graph++    newPos = Map.fromList (zip (map fromIntegral [(m + 1) ..]) holes)++    m | null nodePositions = maximum (nodes graph)+      | otherwise = 0++    holes :: [(Int, Int, Maybe BoxId)]+    holes = map (\(x,y) -> (x,y,Nothing))  ([(x, y) | x <- [minX .. maxX], y <- [minY .. maxY]] \\ nodePositions)+++-- In every z-layer there can be several boxes+-- first we draw the big boxes in the 1-layer (0-layer is the unboxed graph) and the more embedded ones on top (2..maxZCoord)+zLayers :: (NodeClass n, EdgeClass e, ShowGraph n e, VU.Unbox UINode) =>+           CGraph n e -> NestMap -> [(X, [UINode])] -> [(Nesting, [(BoxId, [RowNodesPartOfBox])])]+zLayers graph nestedGraphs xs = map getLayer (reverse [1 .. maxZCoord])+  where+    getLayer :: Nesting -> (Nesting, [(BoxId, [RowNodesPartOfBox])])+    getLayer z = -- Debug.Trace.trace ("zLayers " ++ show (z, maybe [] (map nodesPartOfBox) boxesOfLayerZ)) $+                 (z, maybe [] (map nodesPartOfBox) boxesOfLayerZ)+      where+        boxesOfLayerZ :: Maybe [BoxId]+        boxesOfLayerZ = fmap Set.toList (Map.lookup z nestedGraphs)+        nodesPartOfBox :: BoxId -> (BoxId, [RowNodesPartOfBox])+        nodesPartOfBox bid = (bid, map rowCol xs)+          where+            rowCol :: (X, [UINode]) -> RowNodesPartOfBox+            rowCol (x, ns) = -- Debug.Trace.trace ("zLayers " ++ show (z, x, map zBoxId ns, map lu ns)) $+                             (x, map zBoxId ns)+              where+                lu n = (n, Graph.lookupNode n graph)++            zBoxId :: UINode -> Bool+            zBoxId n = -- Debug.Trace.trace ("zBoxId " ++ show (z,n,boxIdOfNode,bid,boxIdOfNode == Just bid,lu)) $+                       boxIdOfNode == Just bid+              where+                lu = Graph.lookupNode n graph+                b = maybe Nothing nestingFeatures lu+                boxIdOfNode = maybe Nothing boxId b++    maxZCoord :: Nesting+    maxZCoord | null ns = 0+              | otherwise = maximum $ map (\(_, nl) -> zOfNode nl) ns+    zOfNode nl = maybe 0 layer (nestingFeatures nl)++    ns = I.toList (Graph.nodeLabels graph)++spans :: [(Nesting, [(BoxId, [RowNodesPartOfBox])])] -> Map Nesting [(BoxId, (Map X [(Min, Max)]))]+spans ls = Map.fromList (map zSpans ls)+  where+    zSpans :: (Nesting, [(BoxId, [RowNodesPartOfBox])]) -> (Nesting, [(BoxId, Map X [(Min, Max)])])+    zSpans (z, bs) = (z, map box bs)+      where+        box :: (BoxId, [RowNodesPartOfBox]) -> (BoxId, Map X [(Min, Max)])+        box (b, rowNodes) = (b, Map.fromList (map rowsColums rowNodes))+        rowsColums :: (X, [Bool]) -> (X, [(Min, Max)])+        rowsColums (x, nodePartOfBox) = -- Debug.Trace.trace (show ("boxids", boxids, bis, map minmax bis)) +                                        (x, map minmax fbis)+          where minmax :: [(Int, Bool)] -> (Min,Max)+                minmax group = (fst (head group), fst (last group))+                bis :: [[(Int, Bool)]]+                bis = groupBy sec (zip [0..] nodePartOfBox)+                fbis :: [[(Int, Bool)]]+                fbis = filter (not . null) (map (filter snd) bis)+                sec (_,a) (_,b) = a == b++-- | To be able to jump vertically between nodes in an interactive ui+getColumns :: EdgeClass e => CGraphL n e -> (Map X [UINode], Map.Map Int ([Column], YBlockLines))+getColumns (gr, m, yblocks) = -- Debug.Trace.trace ("(zip tables yblocksOfTables)" ++ show (zip tables yblocksOfTables)) $+                              (Map.fromList cols, Map.fromList (zip [0 ..] (zip tables yblocksOfTablesAdj)))+  where+    srt = map (sortBy sorty) . groupBy groupx . sortBy sortx+    cols = map tupleWithX ( srt (map fromIntegral (Graph.nodes gr)) )+    tupleWithX :: [UINode] -> (X, [UINode])+    tupleWithX ls = (maybe 0 fst (Map.lookup (myHead 78 ls) m), ls)+    groupx n0 n1 = maybe 0 fst (Map.lookup n0 m) == maybe 0 fst (Map.lookup n1 m)+    sortx n0 n1 = compare (maybe 0 fst (Map.lookup n0 m)) (maybe 0 fst (Map.lookup n1 m))+    sorty n0 n1 = compare (maybe 0 snd (Map.lookup n0 m)) (maybe 0 snd (Map.lookup n1 m))++    tables = divideTables cols++    yblocksOfTablesAdj = map adjustTable yblocksOfTables+    adjustTable :: YBlockLines -> YBlockLines+    adjustTable table = map adjustLine table+      where adjustLine :: YBlocks -> YBlocks+            adjustLine (y,line) = (y, map adjustBlock line)+            adjustBlock block = map node block+            node (n,x) = (n,x-lowestX)+    lowestX = minimum (map snd (concat (concat (concat (map (map snd) yblocksOfTables)))))+    yblocksOfTables :: [YBlockLines]+    yblocksOfTables = snd (foldr blocksOfTable (yblocks,[]) tables)++    -- There can be several graphs on the screen that are connected with separating edges+    divideTables :: [Column] -> [[Column]]+    divideTables [] = []+    divideTables layers = layersWithoutSep : divideTables rest+      where+        (layersWithoutSep, rest) = sumLayers ([], layers)++        sumLayers :: ([Column], [Column]) -> ([Column], [Column]) -- type Column = (GraphMoveX, [UINode])+        sumLayers (s, []) = (s, [])+        sumLayers (s, l : ls)+          | containsSeparatingEdge (snd l) = (s ++ [l], ls)+          | otherwise = sumLayers (s ++ [l], ls)++        containsSeparatingEdge = any cs+          where cs n = VU.length (childrenSeparating gr n) > 0++    blocksOfTable :: [Column] -> (YBlockLines, [YBlockLines]) -> (YBlockLines, [YBlockLines])+    blocksOfTable _ ([],res) = ([],res)+    blocksOfTable cols (ybs, res)+        | and (map (null . snd)  newYBlocks) = ([],res)+        | otherwise = blocksOfTable cols (reducedYBlocks, newYBlocks : res)+      where+        table = Set.fromList (concatMap snd cols)+        (reducedYBlocks, newYBlocks) = (map fst sub, map snd sub)+          where sub = map addBlockRemoveBlock ybs+        addBlockRemoveBlock :: YBlocks -> (YBlocks,YBlocks)+        addBlockRemoveBlock (y,yb) = addY (break f yb) -- | (head yb) `elem` table = (head yb, tail yb)+          where addY (yb0,yb1) = ((y,yb0),(y,yb1))+                f :: [(UINode, X)] -> Bool+                f block = or (map el block)+                el (n,_) = n `elem` table++--        (elem table . head . head) ybs++-- | To be able to jump horizontally between nodes in an interactive ui+getRows :: CGraphL n e -> Map Y [UINode]+getRows (gr, m, _) =+  Map.fromList $+    map tupleWithY ( srt (map fromIntegral (Graph.nodes gr)) )+  where+    srt = map (sortBy sortx) . groupBy groupy . sortBy sorty+    tupleWithY :: [UINode] -> (Y, [UINode])+    tupleWithY ls = (maybe 0 snd (Map.lookup (myHead 579 ls) m), ls)+    groupy n0 n1 = maybe 0 snd (Map.lookup n0 m) == maybe 0 snd (Map.lookup n1 m)+    sortx n0 n1 = compare (maybe 0 fst (Map.lookup n0 m)) (maybe 0 fst (Map.lookup n1 m))+    sorty n0 n1 = compare (maybe 0 snd (Map.lookup n0 m)) (maybe 0 snd (Map.lookup n1 m))