{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Eta reduce" #-}
{-# HLINT ignore "Use =<<" #-}

module Graph.GraphDrawing where

import qualified Data.IntMap as I
import qualified Data.IntMap.Strict as IM
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 :: forall n e.
(NodeClass n, EdgeClass e, ShowGraph n e) =>
Bool
-> CGraph n e
-> (CGraphL n e,
    (Map Int [UINode], Map Int ([Column], YBlockLines)))
layeredGraphAndCols Bool
cross CGraph n e
graph = (CGraphL n e
g, CGraphL n e -> (Map Int [UINode], Map Int ([Column], YBlockLines))
forall e n.
EdgeClass e =>
CGraphL n e -> (Map Int [UINode], Map Int ([Column], YBlockLines))
getColumns CGraphL n e
g)
  where
    g :: CGraphL n e
g = Bool -> CGraph n e -> CGraphL n e
forall n e.
(NodeClass n, EdgeClass e, ShowGraph n e, Unbox UINode) =>
Bool -> CGraph n e -> CGraphL n e
layeredGraphWithSub Bool
cross CGraph n e
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 :: forall n e.
(NodeClass n, EdgeClass e, ShowGraph n e, Unbox UINode) =>
Bool -> CGraph n e -> CGraphL n e
layeredGraphWithSub Bool
cross CGraph n e
graph = -- Debug.Trace.trace (show("deepestNesting", deepestNesting graph)) $
                                  Bool
-> CGraph n e -> (NestMap, [UINode], ParentGraphOf) -> CGraphL n e
forall n e.
(Unbox UINode, NodeClass n, EdgeClass e, ShowGraph n e) =>
Bool
-> CGraph n e -> (NestMap, [UINode], ParentGraphOf) -> CGraphL n e
layeredGraph Bool
cross CGraph n e
graph (NestMap
nestedGraphs, Map UINode (Set UINode) -> [UINode]
forall k a. Map k a -> [k]
Map.keys Map UINode (Set UINode)
nodesOfBoxId, ParentGraphOf
parentGraphOf)
  where (NestMap
nestedGraphs, Map UINode (Set UINode)
nodesOfBoxId, ParentGraphOf
parentGraphOf) = CGraph n e -> (NestMap, Map UINode (Set UINode), ParentGraphOf)
forall n e.
(NodeClass n, EdgeClass e, Show n, Enum n, Show e,
 ExtractNodeType n) =>
CGraph n e -> (NestMap, Map UINode (Set UINode), ParentGraphOf)
deepestNesting CGraph n e
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 :: forall n e.
(NodeClass n, EdgeClass e, Show n, Enum n, Show e,
 ExtractNodeType n) =>
CGraph n e -> (NestMap, Map UINode (Set UINode), ParentGraphOf)
deepestNesting CGraph n e
gr = -- Debug.Trace.trace (show ("gr", gr, "startNode", startNode, "subs", subs))
                    (NestMap, Map UINode (Set UINode), ParentGraphOf)
subs
  where
    subs :: (NestMap, Map UINode (Set UINode), ParentGraphOf)
subs | [UINode] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UINode]
startNode = (NestMap
forall k a. Map k a
Map.empty, Map UINode (Set UINode)
forall k a. Map k a
Map.empty, ParentGraphOf
forall k a. Map k a
Map.empty)
         | Bool
otherwise = UINode
-> (NestMap, Map UINode (Set UINode), ParentGraphOf)
-> (NestMap, Map UINode (Set UINode), ParentGraphOf)
subGraphs (Int -> [UINode] -> UINode
forall a. Int -> [a] -> a
myHead Int
1 [UINode]
startNode) (NestMap
forall k a. Map k a
Map.empty, Map UINode (Set UINode)
forall k a. Map k a
Map.empty, ParentGraphOf
forall k a. Map k a
Map.empty)
    startNode :: [UINode]
startNode = [UINode] -> [UINode]
forall a. Ord a => [a] -> [a]
rmdups ([UINode] -> [UINode]) -> [UINode] -> [UINode]
forall a b. (a -> b) -> a -> b
$ Vector UINode -> [UINode]
forall a. Unbox a => Vector a -> [a]
VU.toList (CGraph n e -> Vector UINode
forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e -> Vector UINode
nodesWithoutChildrenVertLayer CGraph n e
gr)

    subGraphs :: UINode -> (NestMap, BoxMap, ParentGraphOf) -> (NestMap, BoxMap, ParentGraphOf)
    subGraphs :: UINode
-> (NestMap, Map UINode (Set UINode), ParentGraphOf)
-> (NestMap, Map UINode (Set UINode), ParentGraphOf)
subGraphs UINode
node (NestMap
nesting, Map UINode (Set UINode)
boxNodes, ParentGraphOf
parentOf)
      | [UINode] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UINode]
ps = -- Debug.Trace.trace "subGraphs0" 
                  (NestMap
nesting, Map UINode (Set UINode)
boxNodes, ParentGraphOf
parentOf)
      | Bool
otherwise = -- Debug.Trace.trace ("subGraphs1 " ++ show ps)
                    ((UINode
 -> (NestMap, Map UINode (Set UINode), ParentGraphOf)
 -> (NestMap, Map UINode (Set UINode), ParentGraphOf))
-> (NestMap, Map UINode (Set UINode), ParentGraphOf)
-> [UINode]
-> (NestMap, Map UINode (Set UINode), ParentGraphOf)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr UINode
-> (NestMap, Map UINode (Set UINode), ParentGraphOf)
-> (NestMap, Map UINode (Set UINode), ParentGraphOf)
subGraphs (NestMap
addNesting, Map UINode (Set UINode)
addBoxNodes, ParentGraphOf
addParentOf) [UINode]
ps)
      where lu :: UINode -> Maybe n
lu UINode
n = UINode -> CGraph n e -> Maybe n
forall nl el.
(Show nl, EdgeAttribute el) =>
UINode -> Graph nl el -> Maybe nl
Graph.lookupNode UINode
n CGraph n e
gr
            nest :: UINode -> Maybe LayerFeatures
nest UINode
n = Maybe LayerFeatures
-> (n -> Maybe LayerFeatures) -> Maybe n -> Maybe LayerFeatures
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe LayerFeatures
forall a. Maybe a
Nothing n -> Maybe LayerFeatures
forall n. NodeClass n => n -> Maybe LayerFeatures
nestingFeatures (UINode -> Maybe n
lu UINode
n)
            lay :: UINode -> Int
lay UINode
n = Int -> (LayerFeatures -> Int) -> Maybe LayerFeatures -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 LayerFeatures -> Int
layer (UINode -> Maybe LayerFeatures
nest UINode
n)
            bid :: UINode -> Maybe UINode
bid UINode
n = Maybe UINode
-> (LayerFeatures -> Maybe UINode)
-> Maybe LayerFeatures
-> Maybe UINode
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe UINode
forall a. Maybe a
Nothing LayerFeatures -> Maybe UINode
boxId (UINode -> Maybe LayerFeatures
nest UINode
n)
            ps :: [UINode]
ps = Vector UINode -> [UINode]
forall a. Unbox a => Vector a -> [a]
VU.toList (CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
parentsNoVirtual CGraph n e
gr UINode
node)
            parentBIds :: [UINode]
parentBIds = [Maybe UINode] -> [UINode]
forall a. [Maybe a] -> [a]
catMaybes ((Maybe UINode -> Bool) -> [Maybe UINode] -> [Maybe UINode]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe UINode -> Maybe UINode -> Bool
forall a. Eq a => a -> a -> Bool
/= (UINode -> Maybe UINode
bid UINode
node)) ((UINode -> Maybe UINode) -> [UINode] -> [Maybe UINode]
forall a b. (a -> b) -> [a] -> [b]
map UINode -> Maybe UINode
bid [UINode]
ps))
            addNesting :: NestMap
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)))
                         (NestMap -> (UINode -> NestMap) -> Maybe UINode -> NestMap
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NestMap
nesting (\UINode
b -> (Set UINode -> Set UINode -> Set UINode)
-> Int -> Set UINode -> NestMap -> NestMap
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Set UINode -> Set UINode -> Set UINode
forall a. Ord a => Set a -> Set a -> Set a
Set.union (UINode -> Int
lay UINode
node) (UINode -> Set UINode
forall a. a -> Set a
Set.singleton UINode
b) NestMap
nesting) (UINode -> Maybe UINode
bid UINode
node))
            addBoxNodes :: Map UINode (Set UINode)
addBoxNodes = -- Debug.Trace.trace ("addBoxNodes" ++ show (node, lay node, bid node))
                          (Map UINode (Set UINode)
-> (UINode -> Map UINode (Set UINode))
-> Maybe UINode
-> Map UINode (Set UINode)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map UINode (Set UINode)
boxNodes (\UINode
b -> (Set UINode -> Set UINode -> Set UINode)
-> UINode
-> Set UINode
-> Map UINode (Set UINode)
-> Map UINode (Set UINode)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Set UINode -> Set UINode -> Set UINode
forall a. Ord a => Set a -> Set a -> Set a
Set.union UINode
b (UINode -> Set UINode
forall a. a -> Set a
Set.singleton UINode
node) Map UINode (Set UINode)
boxNodes) (UINode -> Maybe UINode
bid UINode
node))
            addParentOf :: ParentGraphOf
            addParentOf :: ParentGraphOf
addParentOf | Int -> [Int] -> Bool
forall {t :: * -> *} {a}. (Foldable t, Ord a) => a -> t a -> Bool
lowerLayers (UINode -> Int
lay UINode
node) ((UINode -> Int) -> [UINode] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map UINode -> Int
lay [UINode]
ps) = -- Debug.Trace.trace (show ("bid node", bid node, lay node, "parentBIds", node, ps, map lay ps, parentBIds))
                                                                (Set UINode -> Set UINode -> Set UINode)
-> Maybe UINode -> Set UINode -> ParentGraphOf -> ParentGraphOf
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Set UINode -> Set UINode -> Set UINode
forall a. Ord a => Set a -> Set a -> Set a
Set.union (UINode -> Maybe UINode
bid UINode
node) ([UINode] -> Set UINode
forall a. Ord a => [a] -> Set a
Set.fromList [UINode]
parentBIds) ParentGraphOf
parentOf
                        | Bool
otherwise = ParentGraphOf
parentOf
            lowerLayers :: a -> t a -> Bool
lowerLayers a
n t a
ns = (a -> Bool) -> t a -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<) t a
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 :: forall n e.
(Unbox UINode, NodeClass n, EdgeClass e, ShowGraph n e) =>
Bool
-> CGraph n e -> (NestMap, [UINode], ParentGraphOf) -> CGraphL n e
layeredGraph Bool
cross CGraph n e
graph (NestMap
nest, [UINode]
boxids, ParentGraphOf
parentGraphOf) =
  -- Debug.Trace.trace ("layered "++ show (graph, subgraphWindows (nest,boxids) ycoord) ++"\n") -- ++ showEdges graph ++ show (Graph.edgeLabels graph)) $ -- ++"\nnewGraph\n" ++ show newGraph ++"\n") $
  (CGraphL n e, [[UINode]]) -> CGraphL n e
forall a b. (a, b) -> a
fst (CGraphL n e, [[UINode]])
newGraph
  where
    newGraph :: (CGraphL n e, [[UINode]])
newGraph =
      (   (NestMap, [UINode])
-> (CGraphL n e, [[UINode]]) -> (CGraphL n e, [[UINode]])
forall n e.
(NodeClass n, EdgeClass e, ShowGraph n e, Unbox UINode) =>
(NestMap, [UINode])
-> (CGraphL n e, [[UINode]]) -> (CGraphL n e, [[UINode]])
subgraphWithWindows (NestMap
nest,[UINode]
boxids) ((CGraphL n e, [[UINode]]) -> (CGraphL n e, [[UINode]]))
-> (CGraph n e -> (CGraphL n e, [[UINode]]))
-> CGraph n e
-> (CGraphL n e, [[UINode]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            (CGraph n e, [[UINode]]) -> (CGraphL n e, [[UINode]])
forall n e.
(NodeClass n, Show n, EdgeClass e, ExtractNodeType n, Show e,
 Enum n) =>
(CGraph n e, [[UINode]]) -> (CGraphL n e, [[UINode]])
yCoordinateAssignement
          -- .
          --  primitiveYCoordinateAssignement
          ((CGraph n e, [[UINode]]) -> (CGraphL n e, [[UINode]]))
-> (CGraph n e -> (CGraph n e, [[UINode]]))
-> CGraph n e
-> (CGraphL n e, [[UINode]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> Bool
-> (NestMap, [UINode], ParentGraphOf)
-> (CGraph n e, [[(UINode, Maybe UINode)]])
-> (CGraph n e, [[UINode]])
forall n e.
(NodeClass n, Show n, EdgeClass e, Show e, ExtractNodeType n,
 Enum n) =>
Int
-> Bool
-> (NestMap, [UINode], ParentGraphOf)
-> (CGraph n e, [[(UINode, Maybe UINode)]])
-> (CGraph n e, [[UINode]])
crossingReduction Int
2 Bool
cross (NestMap
nest, [UINode]
boxids, ParentGraphOf
parentGraphOf)
          ((CGraph n e, [[(UINode, Maybe UINode)]])
 -> (CGraph n e, [[UINode]]))
-> (CGraph n e -> (CGraph n e, [[(UINode, Maybe UINode)]]))
-> CGraph n e
-> (CGraph n e, [[UINode]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CGraph n e, [[UINode]])
-> (CGraph n e, [[(UINode, Maybe UINode)]])
forall {a} {el} {a}.
(Show a, EdgeAttribute el, Integral a, NodeClass a) =>
(Graph a el, [[a]]) -> (Graph a el, [[(a, Maybe UINode)]])
addBoxIdToLayers
          ((CGraph n e, [[UINode]])
 -> (CGraph n e, [[(UINode, Maybe UINode)]]))
-> (CGraph n e -> (CGraph n e, [[UINode]]))
-> CGraph n e
-> (CGraph n e, [[(UINode, Maybe UINode)]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])
forall n e.
(NodeClass n, Show n, EdgeClass e, Show e) =>
(CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])
arrangeMetaNodes
          ((CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]]))
-> (CGraph n e -> (CGraph n e, [[UINode]]))
-> CGraph n e
-> (CGraph n e, [[UINode]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])
forall {a} {a}. Ord a => (a, [[a]]) -> (a, [[a]])
sortLayers
          ((CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]]))
-> (CGraph n e -> (CGraph n e, [[UINode]]))
-> CGraph n e
-> (CGraph n e, [[UINode]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])
forall n e.
(NodeClass n, Show n, ExtractNodeType n, Enum n, EdgeClass e,
 Show e) =>
(CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])
addConnectionNodes
          ((CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]]))
-> (CGraph n e -> (CGraph n e, [[UINode]]))
-> CGraph n e
-> (CGraph n e, [[UINode]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CGraph n e -> (CGraph n e, [[UINode]])
forall n e.
(NodeClass n, EdgeClass e, ShowGraph n e) =>
CGraph n e -> (CGraph n e, [[UINode]])
longestPathAlgo -- does not change the graph, only computes layers
          (CGraph n e -> (CGraph n e, [[UINode]]))
-> (CGraph n e -> CGraph n e)
-> CGraph n e
-> (CGraph n e, [[UINode]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CGraph n e -> CGraph n e
forall n e.
(NodeClass n, Show n, Show e, EdgeClass e) =>
CGraph n e -> CGraph n e
addMissingInputNodes
      )
        CGraph n e
graph
    addBoxIdToLayers :: (Graph a el, [[a]]) -> (Graph a el, [[(a, Maybe UINode)]])
addBoxIdToLayers (Graph a el
gr,[[a]]
layers) = (Graph a el
gr, ([a] -> [(a, Maybe UINode)]) -> [[a]] -> [[(a, Maybe UINode)]]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> (a, Maybe UINode)) -> [a] -> [(a, Maybe UINode)]
forall a b. (a -> b) -> [a] -> [b]
map (Graph a el -> a -> (a, Maybe UINode)
forall {a} {el} {a}.
(Show a, EdgeAttribute el, Integral a, NodeClass a) =>
Graph a el -> a -> (a, Maybe UINode)
addBoxId Graph a el
gr)) [[a]]
layers)

    ycoord :: (CGraphL n e, [[UINode]])
ycoord = ((CGraph n e, [[UINode]]) -> (CGraphL n e, [[UINode]])
forall n e.
(NodeClass n, Show n, EdgeClass e, ExtractNodeType n, Show e,
 Enum n) =>
(CGraph n e, [[UINode]]) -> (CGraphL n e, [[UINode]])
yCoordinateAssignement ((CGraph n e, [[UINode]]) -> (CGraphL n e, [[UINode]]))
-> (CGraph n e -> (CGraph n e, [[UINode]]))
-> CGraph n e
-> (CGraphL n e, [[UINode]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> Bool
-> (NestMap, [UINode], ParentGraphOf)
-> (CGraph n e, [[(UINode, Maybe UINode)]])
-> (CGraph n e, [[UINode]])
forall n e.
(NodeClass n, Show n, EdgeClass e, Show e, ExtractNodeType n,
 Enum n) =>
Int
-> Bool
-> (NestMap, [UINode], ParentGraphOf)
-> (CGraph n e, [[(UINode, Maybe UINode)]])
-> (CGraph n e, [[UINode]])
crossingReduction Int
2 Bool
cross (NestMap
nest, [UINode]
boxids, ParentGraphOf
parentGraphOf) ((CGraph n e, [[(UINode, Maybe UINode)]])
 -> (CGraph n e, [[UINode]]))
-> (CGraph n e -> (CGraph n e, [[(UINode, Maybe UINode)]]))
-> CGraph n e
-> (CGraph n e, [[UINode]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CGraph n e, [[UINode]])
-> (CGraph n e, [[(UINode, Maybe UINode)]])
forall {a} {el} {a}.
(Show a, EdgeAttribute el, Integral a, NodeClass a) =>
(Graph a el, [[a]]) -> (Graph a el, [[(a, Maybe UINode)]])
addBoxIdToLayers
              ((CGraph n e, [[UINode]])
 -> (CGraph n e, [[(UINode, Maybe UINode)]]))
-> (CGraph n e -> (CGraph n e, [[UINode]]))
-> CGraph n e
-> (CGraph n e, [[(UINode, Maybe UINode)]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])
forall n e.
(NodeClass n, Show n, EdgeClass e, Show e) =>
(CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])
arrangeMetaNodes ((CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]]))
-> (CGraph n e -> (CGraph n e, [[UINode]]))
-> CGraph n e
-> (CGraph n e, [[UINode]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])
forall {a} {a}. Ord a => (a, [[a]]) -> (a, [[a]])
sortLayers ((CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]]))
-> (CGraph n e -> (CGraph n e, [[UINode]]))
-> CGraph n e
-> (CGraph n e, [[UINode]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])
forall n e.
(NodeClass n, Show n, ExtractNodeType n, Enum n, EdgeClass e,
 Show e) =>
(CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])
addConnectionNodes ((CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]]))
-> (CGraph n e -> (CGraph n e, [[UINode]]))
-> CGraph n e
-> (CGraph n e, [[UINode]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CGraph n e -> (CGraph n e, [[UINode]])
forall n e.
(NodeClass n, EdgeClass e, ShowGraph n e) =>
CGraph n e -> (CGraph n e, [[UINode]])
longestPathAlgo (CGraph n e -> (CGraph n e, [[UINode]]))
-> (CGraph n e -> CGraph n e)
-> CGraph n e
-> (CGraph n e, [[UINode]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CGraph n e -> CGraph n e
forall n e.
(NodeClass n, Show n, Show e, EdgeClass e) =>
CGraph n e -> CGraph n e
addMissingInputNodes) CGraph n e
graph

sortLayers :: (a, [[a]]) -> (a, [[a]])
sortLayers (a
gr, [[a]]
ls) = (a
gr, ([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> [a]
forall a. Ord a => [a] -> [a]
sort [[a]]
ls) -- makes the dummy vertices appear lower -- TODO don't move layouted nodes

addBoxId :: Graph a el -> a -> (a, Maybe UINode)
addBoxId Graph a el
g a
n = (a
n, Maybe UINode
-> (LayerFeatures -> Maybe UINode)
-> Maybe LayerFeatures
-> Maybe UINode
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe UINode
forall a. Maybe a
Nothing LayerFeatures -> Maybe UINode
boxId Maybe LayerFeatures
nest)
      where nest :: Maybe LayerFeatures
nest = Maybe LayerFeatures
-> (a -> Maybe LayerFeatures) -> Maybe a -> Maybe LayerFeatures
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe LayerFeatures
forall a. Maybe a
Nothing a -> Maybe LayerFeatures
forall n. NodeClass n => n -> Maybe LayerFeatures
nestingFeatures Maybe a
lu
            lu :: Maybe a
lu = UINode -> Graph a el -> Maybe a
forall nl el.
(Show nl, EdgeAttribute el) =>
UINode -> Graph nl el -> Maybe nl
Graph.lookupNode (a -> UINode
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n) Graph a el
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 :: forall n e. (CGraph n e, [[UINode]]) -> CGraphL n e
primitiveYCoordinateAssignement (CGraph n e
graph, [[UINode]]
layers) =
      -- Debug.Trace.trace ("primitiveY1 "++ show (layers,ns)) $
  (CGraph n e
graph, [(UINode, (Int, Int))] -> Map UINode (Int, Int)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(UINode, (Int, Int))]
ns, [])
  where
    ns :: [(UINode, (Int, Int))]
    ns :: [(UINode, (Int, Int))]
ns = [[(UINode, (Int, Int))]] -> [(UINode, (Int, Int))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(UINode, (Int, Int))]] -> [(UINode, (Int, Int))])
-> [[(UINode, (Int, Int))]] -> [(UINode, (Int, Int))]
forall a b. (a -> b) -> a -> b
$ ([((Int, Int), UINode)] -> Int -> [(UINode, (Int, Int))])
-> [[((Int, Int), UINode)]] -> [Int] -> [[(UINode, (Int, Int))]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\[((Int, Int), UINode)]
layer Int
i -> (((Int, Int), UINode) -> (UINode, (Int, Int)))
-> [((Int, Int), UINode)] -> [(UINode, (Int, Int))]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> ((Int, Int), UINode) -> (UINode, (Int, Int))
forall {a} {b} {a}. Num a => a -> ((a, b), a) -> (a, (a, b))
incX Int
i) [((Int, Int), UINode)]
layer) (([UINode] -> [((Int, Int), UINode)])
-> [[UINode]] -> [[((Int, Int), UINode)]]
forall a b. (a -> b) -> [a] -> [b]
map [UINode] -> [((Int, Int), UINode)]
forall {b} {a} {b}. (Num b, Num a) => [b] -> [((a, b), b)]
oneLayer [[UINode]]
layers) ([Int
0 ..] :: [Int])
    oneLayer :: [b] -> [((a, b), b)]
oneLayer [b]
l = [(a, b)] -> [b] -> [((a, b), b)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((a, b) -> (a, b)) -> (a, b) -> [(a, b)]
forall a. (a -> a) -> a -> [a]
iterate (a, b) -> (a, b)
forall {b} {a}. Num b => (a, b) -> (a, b)
incY (a
0, b
0)) [b]
l
    incX :: a -> ((a, b), a) -> (a, (a, b))
incX a
i ((a
x, b
y), a
n) = (a
n, (a
x a -> a -> a
forall a. Num a => a -> a -> a
- a
i, b
y))
    incY :: (a, b) -> (a, b)
incY (a
x, b
y) = (a
x, b
y b -> b -> b
forall a. Num a => a -> a -> a
+ b
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 :: forall n e.
(NodeClass n, Show n, EdgeClass e, ExtractNodeType n, Show e,
 Enum n) =>
(CGraph n e, [[UINode]]) -> (CGraphL n e, [[UINode]])
yCoordinateAssignement (CGraph n e
graph, [[UINode]]
layers) =
  --Debug.Trace.trace ("\nyCoordAssign "++ show (zipWith f [0 ..] layers, "startNs", startNs, "map (blockC", map (blockChildren edgeMap) startNs, "yblocks", yblocks)) $
  ((CGraph n e
graph, Map UINode (Int, Int)
pos, YBlockLines
yblocks), [[UINode]]
layers)
  where
    -- newGraph = graph { nodeLabels = I.fromList placedNodes } -- for debugging (Map.fromList edgesToKeep)
    pos :: Map UINode (Int, Int)
    pos :: Map UINode (Int, Int)
pos = Map UINode (Int, Int)
-> Map UINode (Int, Int) -> Map UINode (Int, Int)
horizontalBalancing Map UINode (Int, Int)
alignUp Map UINode (Int, Int)
alignDown
    alignUp :: Map UINode (Int, Int)
alignUp = CGraph n e
-> Map UINode Int
-> (Median, Median)
-> [[(UINode, Bool)]]
-> (Bool, Bool)
-> Map UINode (Int, Int)
forall n e.
(NodeClass n, Show n, EdgeClass e, ExtractNodeType n, Show e,
 Enum n) =>
CGraph n e
-> Map UINode Int
-> (Median, Median)
-> [[(UINode, Bool)]]
-> (Bool, Bool)
-> Map UINode (Int, Int)
biasedAlignment CGraph n e
graph Map UINode Int
yp (Median, Median)
ms ([[(UINode, Bool)]] -> [[(UINode, Bool)]]
forall a. [a] -> [a]
reverse [[(UINode, Bool)]]
nLayers) (Bool
True, Bool
True)
    alignDown :: Map UINode (Int, Int)
alignDown = CGraph n e
-> Map UINode Int
-> (Median, Median)
-> [[(UINode, Bool)]]
-> (Bool, Bool)
-> Map UINode (Int, Int)
forall n e.
(NodeClass n, Show n, EdgeClass e, ExtractNodeType n, Show e,
 Enum n) =>
CGraph n e
-> Map UINode Int
-> (Median, Median)
-> [[(UINode, Bool)]]
-> (Bool, Bool)
-> Map UINode (Int, Int)
biasedAlignment CGraph n e
graph Map UINode Int
yp (Median, Median)
ms ([[(UINode, Bool)]] -> [[(UINode, Bool)]]
forall a. [a] -> [a]
reverse [[(UINode, Bool)]]
nLayers) (Bool
True, Bool
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 :: (Median, Median)
ms = (CGraph n e, [[UINode]]) -> (Median, Median)
forall {b} {e}.
(NodeClass b, EdgeClass e) =>
(CGraph b e, [[UINode]]) -> (Median, Median)
medians (CGraph n e
graph, [[UINode]]
layers)
    yp :: Map UINode Int
yp = [[UINode]] -> Map UINode Int
forall {a} {k}. (Num a, Enum a, Ord k) => [[k]] -> Map k a
yPos [[UINode]]
layers

    nLayers :: [[(UINode, Bool)]]
nLayers = ([UINode] -> [(UINode, Bool)]) -> [[UINode]] -> [[(UINode, Bool)]]
forall a b. (a -> b) -> [a] -> [b]
map ((UINode -> (UINode, Bool)) -> [UINode] -> [(UINode, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map UINode -> (UINode, Bool)
connProp) [[UINode]]
layers
    connProp :: UINode -> (UINode, Bool)
connProp UINode
n = (UINode
n, CGraph n e -> UINode -> Bool
forall e. EdgeClass e => CGraph n e -> UINode -> Bool
forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e -> UINode -> Bool
isConnNode CGraph n e
graph UINode
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 :: YBlockLines
yblocks = YBlockLines -> YBlockLines
removeDups ([[(Int, UINode)]]
-> [UINode]
-> Int
-> CGraph n e
-> [[UINode]]
-> [(UINode, UINode)]
-> Bool
-> YBlockLines
forall n e.
(NodeClass n, EdgeClass e, ShowGraph n e) =>
[[(Int, UINode)]]
-> [UINode]
-> Int
-> CGraph n e
-> [[UINode]]
-> [(UINode, UINode)]
-> Bool
-> YBlockLines
longestPath (((Int, UINode) -> [(Int, UINode)])
-> [(Int, UINode)] -> [[(Int, UINode)]]
forall a b. (a -> b) -> [a] -> [b]
map (Map UINode UINode -> (Int, UINode) -> [(Int, UINode)]
blockChildren Map UINode UINode
edgeMap) [(Int, UINode)]
startNs) [] Int
0 CGraph n e
graph [[UINode]]
layers [(UINode, UINode)]
edgesToKeep Bool
True)
    removeDups :: YBlockLines -> YBlockLines
    removeDups :: YBlockLines -> YBlockLines
removeDups YBlockLines
ls = (Set UINode, YBlockLines) -> YBlockLines
forall a b. (a, b) -> b
snd ((YBlocks -> (Set UINode, YBlockLines) -> (Set UINode, YBlockLines))
-> (Set UINode, YBlockLines)
-> YBlockLines
-> (Set UINode, YBlockLines)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr YBlocks -> (Set UINode, YBlockLines) -> (Set UINode, YBlockLines)
rm (Set UINode
forall a. Set a
Set.empty,[]) YBlockLines
ls)
    rm :: YBlocks -> (Set UINode,YBlockLines) -> (Set UINode,YBlockLines)
    rm :: YBlocks -> (Set UINode, YBlockLines) -> (Set UINode, YBlockLines)
rm    (Int
yb,[[(UINode, Int)]]
l)     (Set UINode
s,YBlockLines
res) | YBlocks -> Bool
forall a. (Int, a) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null YBlocks
new = (Set UINode
s, YBlockLines
res)
                             | Bool
otherwise = (Set UINode -> Set UINode -> Set UINode
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([UINode] -> Set UINode
forall a. Ord a => [a] -> Set a
Set.fromList (([(UINode, Int)] -> UINode) -> [[(UINode, Int)]] -> [UINode]
forall a b. (a -> b) -> [a] -> [b]
map ((UINode, Int) -> UINode
forall a b. (a, b) -> a
fst ((UINode, Int) -> UINode)
-> ([(UINode, Int)] -> (UINode, Int)) -> [(UINode, Int)] -> UINode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(UINode, Int)] -> (UINode, Int)
forall a. HasCallStack => [a] -> a
head) (YBlocks -> [[(UINode, Int)]]
forall a b. (a, b) -> b
snd YBlocks
new))) Set UINode
s, YBlocks
new YBlocks -> YBlockLines -> YBlockLines
forall a. a -> [a] -> [a]
: YBlockLines
res)
        where new :: YBlocks
              new :: YBlocks
new = (Int
yb, ([(UINode, Int)] -> Bool) -> [[(UINode, Int)]] -> [[(UINode, Int)]]
forall a. (a -> Bool) -> [a] -> [a]
filter [(UINode, Int)] -> Bool
h [[(UINode, Int)]]
l)
              h :: [(UINode, X)] -> Bool
              h :: [(UINode, Int)] -> Bool
h [(UINode, Int)]
block = Bool -> Bool
not (UINode -> Set UINode -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member ((UINode, Int) -> UINode
forall a b. (a, b) -> a
fst ([(UINode, Int)] -> (UINode, Int)
forall a. HasCallStack => [a] -> a
head [(UINode, Int)]
block)) Set UINode
s)

    startNs :: [(Int, UINode)]
startNs = ([(Int, UINode)] -> Maybe (Int, UINode))
-> [[(Int, UINode)]] -> [(Int, UINode)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([[UINode]]
-> [(UINode, UINode)] -> (Int, UINode) -> Maybe (Int, UINode)
nodeWithoutParent [[UINode]]
layers [(UINode, UINode)]
edgesToKeep((Int, UINode) -> Maybe (Int, UINode))
-> ([(Int, UINode)] -> (Int, UINode))
-> [(Int, UINode)]
-> Maybe (Int, UINode)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, UINode)] -> (Int, UINode)
forall a. HasCallStack => [a] -> a
last) ((Int -> [UINode] -> [(Int, UINode)])
-> [Int] -> [[UINode]] -> [[(Int, UINode)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> [UINode] -> [(Int, UINode)]
forall {t} {a}. t -> [a] -> [(t, a)]
f ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int
0 .. ([[UINode]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[UINode]]
layers Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)]) [[UINode]]
layers)
    f :: t -> [a] -> [(t, a)]
f t
i [a]
ns = (a -> (t, a)) -> [a] -> [(t, a)]
forall a b. (a -> b) -> [a] -> [b]
map (t
i,) [a]
ns
    edgeMap :: Map UINode UINode
edgeMap = [(UINode, UINode)] -> Map UINode UINode
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(UINode, UINode)]
edgesToKeep
    edgesToKeep :: [(UINode, UINode)]
edgesToKeep = [(UINode, UINode)] -> [(UINode, UINode)]
forall a. Ord a => [a] -> [a]
rmdups ([(UINode, UINode)] -> [(UINode, UINode)])
-> [(UINode, UINode)] -> [(UINode, UINode)]
forall a b. (a -> b) -> a -> b
$ (([(UINode, Bool)], [(UINode, Bool)]) -> [(UINode, UINode)])
-> [([(UINode, Bool)], [(UINode, Bool)])] -> [(UINode, UINode)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([(MYN, MYN)] -> [(UINode, UINode)])
-> [[(MYN, MYN)]] -> [(UINode, UINode)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [(MYN, MYN)] -> [(UINode, UINode)]
resolve ([[(MYN, MYN)]] -> [(UINode, UINode)])
-> (([(UINode, Bool)], [(UINode, Bool)]) -> [[(MYN, MYN)]])
-> ([(UINode, Bool)], [(UINode, Bool)])
-> [(UINode, UINode)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Median, Median)
-> Bool -> ([(UINode, Bool)], [(UINode, Bool)]) -> [[(MYN, MYN)]]
sweep2 ((CGraph n e, [[UINode]]) -> (Median, Median)
forall {b} {e}.
(NodeClass b, EdgeClass e) =>
(CGraph b e, [[UINode]]) -> (Median, Median)
medians (CGraph n e
graph, [[UINode]]
layers)) Bool
True) ([[(UINode, Bool)]] -> [([(UINode, Bool)], [(UINode, Bool)])]
forall a. [a] -> [(a, a)]
tuples ([[(UINode, Bool)]] -> [[(UINode, Bool)]]
forall a. [a] -> [a]
reverse [[(UINode, Bool)]]
nLayers))
    resolve :: [(MYN, MYN)] -> [(UINode, UINode)]
resolve [(MYN, MYN)]
ts = [(UINode, UINode)] -> [(UINode, UINode)]
forall a. Ord a => [a] -> [a]
rmdups ([(UINode, UINode)] -> [(UINode, UINode)])
-> [(UINode, UINode)] -> [(UINode, UINode)]
forall a b. (a -> b) -> a -> b
$ (((Int, (UINode, Bool)), (Int, (UINode, Bool)))
 -> (UINode, UINode))
-> [((Int, (UINode, Bool)), (Int, (UINode, Bool)))]
-> [(UINode, UINode)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, (UINode, Bool)), (Int, (UINode, Bool))) -> (UINode, UINode)
forall a1 a2 b1 a3 b2 b3.
((a1, (a2, b1)), (a3, (b2, b3))) -> (a2, b2)
toNode ((Bool, Bool)
-> [(MYN, MYN)] -> [((Int, (UINode, Bool)), (Int, (UINode, Bool)))]
resolveConflicts (Bool
True, Bool
True) [(MYN, MYN)]
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 :: [[k]] -> Map k a
yPos [[k]]
layers = [(k, a)] -> Map k a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([[(k, a)]] -> [(k, a)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(k, a)]]
enumLayers)
  where enumLayers :: [[(k, a)]]
enumLayers = ([k] -> [(k, a)]) -> [[k]] -> [[(k, a)]]
forall a b. (a -> b) -> [a] -> [b]
map (\[k]
l -> [k] -> [a] -> [(k, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [k]
l [a
0 ..]) [[k]]
layers

medians :: (CGraph b e, [[UINode]]) -> (Median, Median)
medians (CGraph b e
graph, [[UINode]]
layers) = ([(UINode, MYN)] -> Median
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(UINode, MYN)]
lowerMedians, [(UINode, MYN)] -> Median
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(UINode, MYN)]
upperMedians)
  where
    upperMedians :: [(UINode, MYN)]
upperMedians =
      -- Debug.Trace.trace ("upper"++ show (map upper ns, map (getMedian . upper) ns)) $
      ((UINode, b) -> Maybe (UINode, MYN))
-> [(UINode, b)] -> [(UINode, MYN)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((UINode, [UINode]) -> Maybe (UINode, MYN)
getMedian ((UINode, [UINode]) -> Maybe (UINode, MYN))
-> ((UINode, b) -> (UINode, [UINode]))
-> (UINode, b)
-> Maybe (UINode, MYN)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UINode, b) -> (UINode, [UINode])
upper) [(UINode, b)]
ns
    lowerMedians :: [(UINode, MYN)]
lowerMedians =
      -- Debug.Trace.trace ("lower"++ show (map lower ns)) $
      ((UINode, b) -> Maybe (UINode, MYN))
-> [(UINode, b)] -> [(UINode, MYN)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((UINode, [UINode]) -> Maybe (UINode, MYN)
getMedian ((UINode, [UINode]) -> Maybe (UINode, MYN))
-> ((UINode, b) -> (UINode, [UINode]))
-> (UINode, b)
-> Maybe (UINode, MYN)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UINode, b) -> (UINode, [UINode])
lower) [(UINode, b)]
ns
    ns :: [(UINode, b)]
ns = ((Int, b) -> (UINode, b)) -> [(Int, b)] -> [(UINode, b)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, b) -> (UINode, b)
forall n. (Int, n) -> (UINode, n)
fr ([(Int, b)] -> [(UINode, b)]) -> [(Int, b)] -> [(UINode, b)]
forall a b. (a -> b) -> a -> b
$ IntMap b -> [(Int, b)]
forall a. IntMap a -> [(Int, a)]
I.toList (CGraph b e -> IntMap b
forall nl el. Graph nl el -> IntMap nl
Graph.nodeLabels CGraph b e
graph)
    upper :: (UINode, b) -> (UINode, [UINode])
upper (UINode
n, b
_) = (UINode
n, Vector UINode -> [UINode]
forall a. Unbox a => Vector a -> [a]
VU.toList (CGraph b e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
childrenNoVertical CGraph b e
graph UINode
n))
    lower :: (UINode, b) -> (UINode, [UINode])
lower (UINode
n, b
_) = (UINode
n, Vector UINode -> [UINode]
forall a. Unbox a => Vector a -> [a]
VU.toList (CGraph b e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
parentsNoVertical CGraph b e
graph UINode
n))

    getMedian :: (UINode, [UINode]) -> Maybe (UINode, MYN)
getMedian (UINode
n, [UINode]
ns1)
      | Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -- Debug.Trace.trace "get l0" $
        =
        Maybe (UINode, MYN)
forall a. Maybe a
Nothing
      | Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = (UINode, MYN) -> Maybe (UINode, MYN)
forall a. a -> Maybe a
Just (UINode
n, (Int, (UINode, Bool)) -> MYN
Single (Int, (UINode, Bool))
rightMedian)
      | Int -> Bool
forall a. Integral a => a -> Bool
even Int
l -- Debug.Trace.trace ("get lmod2"++ show (nodeLbls,ns1,(n, (leftMedian, rightMedian)))) $
        =
        (UINode, MYN) -> Maybe (UINode, MYN)
forall a. a -> Maybe a
Just (UINode
n, (Int, (UINode, Bool)) -> (Int, (UINode, Bool)) -> MYN
UpLowMedian (Int, (UINode, Bool))
leftMedian (Int, (UINode, Bool))
rightMedian) -- an even list has two medians
      | Bool
otherwise -- Debug.Trace.trace ("get other"++ show (nodeLbls,ns1,(n, (rightMedian, rightMedian)))) $
        =
        (UINode, MYN) -> Maybe (UINode, MYN)
forall a. a -> Maybe a
Just (UINode
n, (Int, (UINode, Bool)) -> MYN
Middle (Int, (UINode, Bool))
rightMedian) -- an odd list has only one median
      where
        leftMedian :: (Int, (UINode, Bool))
leftMedian =
          -- Debug.Trace.trace ("median "++ show (n,ns1,nodeLbls,sorted,l)) $
          (Int, UINode) -> (Int, (UINode, Bool))
addConnProp ([(Int, UINode)]
sorted [(Int, UINode)] -> Int -> (Int, UINode)
forall a. HasCallStack => [a] -> Int -> a
!! ((Int
l Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
        rightMedian :: (Int, (UINode, Bool))
rightMedian = (Int, UINode) -> (Int, (UINode, Bool))
addConnProp ([(Int, UINode)]
sorted [(Int, UINode)] -> Int -> (Int, UINode)
forall a. HasCallStack => [a] -> Int -> a
!! (Int
l Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2))
        l :: Int
l = [UINode] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [UINode]
ns1
        sorted :: [(Int, UINode)]
sorted = ((Int, UINode) -> Int) -> [(Int, UINode)] -> [(Int, UINode)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int, UINode) -> Int
forall a b. (a, b) -> a
fst [(Int, UINode)]
nodeLbls
        nodeLbls :: [(Int, UINode)]
nodeLbls = (UINode -> (Int, UINode)) -> [UINode] -> [(Int, UINode)]
forall a b. (a -> b) -> [a] -> [b]
map (\UINode
node -> (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (UINode -> Map UINode Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
node ([[UINode]] -> Map UINode Int
forall {a} {k}. (Num a, Enum a, Ord k) => [[k]] -> Map k a
yPos [[UINode]]
layers)), UINode
node)) [UINode]
ns1
        addConnProp :: (Int, UINode) -> (Int, (UINode, Bool))
addConnProp (Int
y, UINode
node) = (Int
y, (UINode
node, CGraph b e -> UINode -> Bool
forall e. EdgeClass e => CGraph b e -> UINode -> Bool
forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e -> UINode -> Bool
isConnNode CGraph b e
graph UINode
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 :: Map UINode (Int, Int)
-> Map UINode (Int, Int) -> Map UINode (Int, Int)
horizontalBalancing Map UINode (Int, Int)
alignUp Map UINode (Int, Int)
alignDown =
  -- Debug.Trace.trace ("horizontalBalancing "++ show (lu,ru)) --  ++"\n"++ show ld ++"\n"++ show average)
--  alignDown
  Map UINode (Int, Int)
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 (MYN -> MYN -> Bool
(MYN -> MYN -> Bool) -> (MYN -> MYN -> Bool) -> Eq MYN
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MYN -> MYN -> Bool
== :: MYN -> MYN -> Bool
$c/= :: MYN -> MYN -> Bool
/= :: MYN -> MYN -> Bool
Eq, Eq MYN
Eq MYN =>
(MYN -> MYN -> Ordering)
-> (MYN -> MYN -> Bool)
-> (MYN -> MYN -> Bool)
-> (MYN -> MYN -> Bool)
-> (MYN -> MYN -> Bool)
-> (MYN -> MYN -> MYN)
-> (MYN -> MYN -> MYN)
-> Ord MYN
MYN -> MYN -> Bool
MYN -> MYN -> Ordering
MYN -> MYN -> MYN
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: MYN -> MYN -> Ordering
compare :: MYN -> MYN -> Ordering
$c< :: MYN -> MYN -> Bool
< :: MYN -> MYN -> Bool
$c<= :: MYN -> MYN -> Bool
<= :: MYN -> MYN -> Bool
$c> :: MYN -> MYN -> Bool
> :: MYN -> MYN -> Bool
$c>= :: MYN -> MYN -> Bool
>= :: MYN -> MYN -> Bool
$cmax :: MYN -> MYN -> MYN
max :: MYN -> MYN -> MYN
$cmin :: MYN -> MYN -> MYN
min :: MYN -> MYN -> MYN
Ord, Int -> MYN -> ShowS
[MYN] -> ShowS
MYN -> [Char]
(Int -> MYN -> ShowS)
-> (MYN -> [Char]) -> ([MYN] -> ShowS) -> Show MYN
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MYN -> ShowS
showsPrec :: Int -> MYN -> ShowS
$cshow :: MYN -> [Char]
show :: MYN -> [Char]
$cshowList :: [MYN] -> ShowS
showList :: [MYN] -> ShowS
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 :: Bool
-> (MYN, MYN) -> ((Int, (UINode, Bool)), (Int, (UINode, Bool)))
toYN Bool
left (MYN
n0, MYN
n1) = (Bool -> MYN -> (Int, (UINode, Bool))
getYN Bool
left MYN
n0, Bool -> MYN -> (Int, (UINode, Bool))
getYN Bool
left MYN
n1)

getYN :: Bool -> MYN -> (Y, (UINode, Bool))
getYN :: Bool -> MYN -> (Int, (UINode, Bool))
getYN Bool
_ (Single (Int
y, (UINode
n, Bool
b))) = (Int
y, (UINode
n, Bool
b))
getYN Bool
_ (Middle (Int
y, (UINode
n, Bool
b))) = (Int
y, (UINode
n, Bool
b))
getYN Bool
left (UpLowMedian (Int
y0, (UINode
n0, Bool
b0)) (Int
y1, (UINode
n1, Bool
b1)))
  | Bool
left = (Int
y0, (UINode
n0, Bool
b0))
  | Bool
otherwise = (Int
y1, (UINode
n1, Bool
b1))

getY :: Bool -> MYN -> Y
getY :: Bool -> MYN -> Int
getY Bool
_ (Single (Int
y, (UINode, Bool)
_)) = Int
y
getY Bool
_ (Middle (Int
y, (UINode, Bool)
_)) = Int
y
getY Bool
left (UpLowMedian (Int
y0, (UINode
_n0, Bool
_b0)) (Int
y1, (UINode
_n1, Bool
_b1)))
  | Bool
left = Int
y0
  | Bool
otherwise = Int
y1

getN :: MYN -> [UINode]
getN :: MYN -> [UINode]
getN (Single (Int
_y, (UINode
n, Bool
_b))) = [UINode
n]
getN (Middle (Int
_y, (UINode
n, Bool
_b))) = [UINode
n]
getN (UpLowMedian (Int
_y0, (UINode
n0, Bool
_b0)) (Int
_y1, (UINode
n1, Bool
_b1))) = [UINode
n0, UINode
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 :: forall n e.
(NodeClass n, Show n, EdgeClass e, ExtractNodeType n, Show e,
 Enum n) =>
CGraph n e
-> Map UINode Int
-> (Median, Median)
-> [[(UINode, Bool)]]
-> (Bool, Bool)
-> Map UINode (Int, Int)
biasedAlignment CGraph n e
graph Map UINode Int
_ (Median, Median)
medians [[(UINode, Bool)]]
layers (Bool, Bool)
dir =
  -- Debug.Trace.trace ("\nbalign"++ show (layers, balign)) $ --edgesToKeep, map sweep2 (tuples layers)) ++
  --                                                                "\nunpositioned " ++ show (map removePositioned (map (map fst) layers))) $
  Map UINode (Int, Int)
balign
  where
    (Bool
left, Bool
_up) = (Bool, Bool)
dir
    positioned :: [UINode]
positioned = Map UINode (Int, Int) -> [UINode]
forall k a. Map k a -> [k]
Map.keys Map UINode (Int, Int)
balign
    _removePositioned :: [UINode] -> [UINode]
_removePositioned [UINode]
ns = [UINode]
ns [UINode] -> [UINode] -> [UINode]
forall a. Eq a => [a] -> [a] -> [a]
\\ [UINode]
positioned
    -- see with https://dreampuf.github.io/GraphvizOnline/
    balign :: Map UINode (Int, Int)
balign =
      -- Debug.Trace.trace ("\n\nedgesToKeep "++ show dir ++ "\ndigraph G {" ++
      --                   (concat $ map line edgesToKeep) ++"\n"++ placeNodes ++ "\n}") -- \n\nmedians "++ show medians) $
      CGraph n e
-> [[UINode]]
-> [(UINode, UINode)]
-> (Bool, Bool)
-> Map UINode (Int, Int)
forall e n.
(EdgeClass e, Show n, NodeClass n, ExtractNodeType n, Show e,
 Enum n) =>
CGraph n e
-> [[UINode]]
-> [(UINode, UINode)]
-> (Bool, Bool)
-> Map UINode (Int, Int)
align CGraph n e
graph (([(UINode, Bool)] -> [UINode]) -> [[(UINode, Bool)]] -> [[UINode]]
forall a b. (a -> b) -> [a] -> [b]
map (((UINode, Bool) -> UINode) -> [(UINode, Bool)] -> [UINode]
forall a b. (a -> b) -> [a] -> [b]
map (UINode, Bool) -> UINode
forall a b. (a, b) -> a
fst) [[(UINode, Bool)]]
layers) [(UINode, UINode)]
edgesToKeep (Bool, Bool)
dir
    edgesToKeep :: [(UINode, UINode)]
edgesToKeep = [(UINode, UINode)] -> [(UINode, UINode)]
forall a. Ord a => [a] -> [a]
rmdups ([(UINode, UINode)] -> [(UINode, UINode)])
-> [(UINode, UINode)] -> [(UINode, UINode)]
forall a b. (a -> b) -> a -> b
$ (([(UINode, Bool)], [(UINode, Bool)]) -> [(UINode, UINode)])
-> [([(UINode, Bool)], [(UINode, Bool)])] -> [(UINode, UINode)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([(MYN, MYN)] -> [(UINode, UINode)])
-> [[(MYN, MYN)]] -> [(UINode, UINode)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [(MYN, MYN)] -> [(UINode, UINode)]
resolve ([[(MYN, MYN)]] -> [(UINode, UINode)])
-> (([(UINode, Bool)], [(UINode, Bool)]) -> [[(MYN, MYN)]])
-> ([(UINode, Bool)], [(UINode, Bool)])
-> [(UINode, UINode)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Median, Median)
-> Bool -> ([(UINode, Bool)], [(UINode, Bool)]) -> [[(MYN, MYN)]]
sweep2 (Median, Median)
medians Bool
left) ([[(UINode, Bool)]] -> [([(UINode, Bool)], [(UINode, Bool)])]
forall a. [a] -> [(a, a)]
tuples [[(UINode, Bool)]]
layers)
    _line :: (a, a) -> [Char]
_line (a
from, a
to) = [Char]
"\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
from [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" -> " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
to
    _placeNodes :: [Char]
_placeNodes = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ ([(Int, (Int, (UINode, Bool)))] -> [[Char]])
-> [[(Int, (Int, (UINode, Bool)))]] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((Int, (Int, (UINode, Bool))) -> [Char])
-> [(Int, (Int, (UINode, Bool)))] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Int, (Int, (UINode, Bool))) -> [Char]
placeNode) ((Int -> [(Int, (UINode, Bool))] -> [(Int, (Int, (UINode, Bool)))])
-> [Int]
-> [[(Int, (UINode, Bool))]]
-> [[(Int, (Int, (UINode, Bool)))]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ([Int] -> [(Int, (UINode, Bool))] -> [(Int, (Int, (UINode, Bool)))]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Int]
 -> [(Int, (UINode, Bool))] -> [(Int, (Int, (UINode, Bool)))])
-> (Int -> [Int])
-> Int
-> [(Int, (UINode, Bool))]
-> [(Int, (Int, (UINode, Bool)))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Int]
forall a. a -> [a]
repeat) [Int
1 ..] (([(UINode, Bool)] -> [(Int, (UINode, Bool))])
-> [[(UINode, Bool)]] -> [[(Int, (UINode, Bool))]]
forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> [(UINode, Bool)] -> [(Int, (UINode, Bool))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..]) [[(UINode, Bool)]]
layers))
      where
        placeNode :: (X, (Y, (UINode, Bool))) -> String
        placeNode :: (Int, (Int, (UINode, Bool))) -> [Char]
placeNode (Int
x, (Int
y, (UINode
n, Bool
_b))) = UINode -> [Char]
forall a. Show a => a -> [Char]
show UINode
n [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" [pos=\"" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
x [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"," [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (-Int
y) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"!\"];\n"
    resolve :: [(MYN, MYN)] -> [(UINode, UINode)]
    resolve :: [(MYN, MYN)] -> [(UINode, UINode)]
resolve [(MYN, MYN)]
ts =
      -- Debug.Trace.trace ("\nresolve "++ show (ts, res))
      [(UINode, UINode)]
res
      where
        res :: [(UINode, UINode)]
res = [(UINode, UINode)] -> [(UINode, UINode)]
forall a. Ord a => [a] -> [a]
rmdups ([(UINode, UINode)] -> [(UINode, UINode)])
-> [(UINode, UINode)] -> [(UINode, UINode)]
forall a b. (a -> b) -> a -> b
$ (((Int, (UINode, Bool)), (Int, (UINode, Bool)))
 -> (UINode, UINode))
-> [((Int, (UINode, Bool)), (Int, (UINode, Bool)))]
-> [(UINode, UINode)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, (UINode, Bool)), (Int, (UINode, Bool))) -> (UINode, UINode)
forall a1 a2 b1 a3 b2 b3.
((a1, (a2, b1)), (a3, (b2, b3))) -> (a2, b2)
toNode ((Bool, Bool)
-> [(MYN, MYN)] -> [((Int, (UINode, Bool)), (Int, (UINode, Bool)))]
resolveConflicts (Bool, Bool)
dir [(MYN, MYN)]
ts)

    _sweep :: ([(UINode, Bool)], [(UINode, Bool)]) -> [[(MYN, MYN)]]
    _sweep :: ([(UINode, Bool)], [(UINode, Bool)]) -> [[(MYN, MYN)]]
_sweep ([(UINode, Bool)]
layer0, [(UINode, Bool)]
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) $
      [[(MYN, MYN)]]
sfiel
      where
        sfiel :: [[(MYN, MYN)]]
sfiel = CGraph n e
-> (Median, Median)
-> Set (UINode, UINode)
-> (Bool, Bool)
-> Insp
-> (Int, Int)
-> ([(UINode, Bool)], [(UINode, Bool)])
-> Set (MYN, MYN)
-> [[(MYN, MYN)]]
forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e
-> (Median, Median)
-> Set (UINode, UINode)
-> (Bool, Bool)
-> Insp
-> (Int, Int)
-> ([(UINode, Bool)], [(UINode, Bool)])
-> Set (MYN, MYN)
-> [[(MYN, MYN)]]
sweepForIndependentEdgeLists CGraph n e
graph (Median, Median)
medians Set (UINode, UINode)
allowedEdges (Bool, Bool)
dir (Map Int (MYN, MYN)
forall k a. Map k a
Map.empty, Map Int (MYN, MYN)
forall k a. Map k a
Map.empty) (Int
0, Int
0) ([(UINode, Bool)]
layer0, [(UINode, Bool)]
layer1) Set (MYN, MYN)
forall a. Set a
Set.empty
        allowedEdges :: Set.Set (UINode, UINode)
        allowedEdges :: Set (UINode, UINode)
allowedEdges = [(UINode, UINode)] -> Set (UINode, UINode)
forall a. Ord a => [a] -> Set a
Set.fromList (((UINode, Bool) -> Maybe (UINode, UINode))
-> [(UINode, Bool)] -> [(UINode, UINode)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (UINode, Bool) -> Maybe (UINode, UINode)
f [(UINode, Bool)]
layer0)
        --              f :: UINode -> (UINode, UINode)
        f :: (UINode, Bool) -> Maybe (UINode, UINode)
f (UINode
n, Bool
_b)
          | Maybe MYN -> Bool
forall a. Maybe a -> Bool
isJust Maybe MYN
lu = (UINode, UINode) -> Maybe (UINode, UINode)
forall a. a -> Maybe a
Just (UINode
n, UINode
dest)
          | Bool
otherwise = Maybe (UINode, UINode)
forall a. Maybe a
Nothing
          where
            dest :: UINode
dest = (UINode, Bool) -> UINode
forall a b. (a, b) -> a
fst ((UINode, Bool) -> UINode) -> (UINode, Bool) -> UINode
forall a b. (a -> b) -> a -> b
$ (Int, (UINode, Bool)) -> (UINode, Bool)
forall a b. (a, b) -> b
snd ((Int, (UINode, Bool)) -> (UINode, Bool))
-> (Int, (UINode, Bool)) -> (UINode, Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> MYN -> (Int, (UINode, Bool))
getYN ((Bool, Bool) -> Bool
forall a b. (a, b) -> a
fst (Bool, Bool)
dir) (Int -> Maybe MYN -> MYN
forall a. Int -> Maybe a -> a
myFromJust Int
500 Maybe MYN
lu)
            lu :: Maybe MYN
lu = UINode -> Median -> Maybe MYN
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n ((Median, Median) -> Median
forall a b. (a, b) -> b
snd (Median, Median)
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 :: (Median, Median)
-> Bool -> ([(UINode, Bool)], [(UINode, Bool)]) -> [[(MYN, MYN)]]
sweep2 (Median, Median)
medians Bool
left ([(UINode, Bool)]
layer0, [(UINode, Bool)]
_layer1) =
  -- Debug.Trace.trace ("sweep2 "++ show (layer0, layer1,es))
  [[(MYN, MYN)]]
es
  where
    es :: [[(MYN, MYN)]]
es = [[Maybe (MYN, MYN)] -> [(MYN, MYN)]
forall a. [Maybe a] -> [a]
catMaybes ((Int -> (UINode, Bool) -> Maybe (MYN, MYN))
-> [Int] -> [(UINode, Bool)] -> [Maybe (MYN, MYN)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> (UINode, Bool) -> Maybe (MYN, MYN)
f [Int
0 ..] [(UINode, Bool)]
layer0)]
    f :: Int -> (UINode, Bool) -> Maybe (MYN, MYN)
f Int
y (UINode
n, Bool
b)
      | Maybe MYN -> Bool
forall a. Maybe a -> Bool
isJust Maybe MYN
lu Bool -> Bool -> Bool
&& Bool
isValidEdge -- Debug.Trace.trace ("sweep2lu0 "++ show lu) $
        =
        (MYN, MYN) -> Maybe (MYN, MYN)
forall a. a -> Maybe a
Just ((Int, (UINode, Bool)) -> MYN
Single (Int
y, (UINode
n, Bool
b)), Int -> Maybe MYN -> MYN
forall a. Int -> Maybe a -> a
myFromJust Int
501 Maybe MYN
lu)
      | Bool
otherwise -- Debug.Trace.trace ("sweep2lu1 "++ show (n,lu))
        =
        Maybe (MYN, MYN)
forall a. Maybe a
Nothing
      where
        lu :: Maybe MYN
lu = UINode -> Median -> Maybe MYN
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n ((Median, Median) -> Median
forall a b. (a, b) -> b
snd (Median, Median)
medians)
        luBack :: Maybe MYN
luBack = UINode -> Median -> Maybe MYN
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ((UINode, Bool) -> UINode
forall a b. (a, b) -> a
fst ((UINode, Bool) -> UINode) -> (UINode, Bool) -> UINode
forall a b. (a -> b) -> a -> b
$ (Int, (UINode, Bool)) -> (UINode, Bool)
forall a b. (a, b) -> b
snd ((Int, (UINode, Bool)) -> (UINode, Bool))
-> (Int, (UINode, Bool)) -> (UINode, Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> MYN -> (Int, (UINode, Bool))
getYN Bool
left (MYN -> (Int, (UINode, Bool))) -> MYN -> (Int, (UINode, Bool))
forall a b. (a -> b) -> a -> b
$ Int -> Maybe MYN -> MYN
forall a. Int -> Maybe a -> a
myFromJust Int
502 Maybe MYN
lu) ((Median, Median) -> Median
forall a b. (a, b) -> a
fst (Median, Median)
medians)
        isValidEdge :: Bool
isValidEdge =
          -- Debug.Trace.trace ("n,lu,luBack "++ show (n,lu,luBack)) $
          Maybe MYN -> Bool
forall a. Maybe a -> Bool
isJust Maybe MYN
luBack Bool -> Bool -> Bool
&& UINode
n UINode -> UINode -> Bool
forall a. Eq a => a -> a -> Bool
== (UINode, Bool) -> UINode
forall a b. (a, b) -> a
fst ((Int, (UINode, Bool)) -> (UINode, Bool)
forall a b. (a, b) -> b
snd ((Int, (UINode, Bool)) -> (UINode, Bool))
-> (Int, (UINode, Bool)) -> (UINode, Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> MYN -> (Int, (UINode, Bool))
getYN Bool
left (MYN -> (Int, (UINode, Bool))) -> MYN -> (Int, (UINode, Bool))
forall a b. (a -> b) -> a -> b
$ Int -> Maybe MYN -> MYN
forall a. Int -> Maybe a -> a
myFromJust Int
503 Maybe MYN
luBack)

toNode :: ((a1, (a2, b1)), (a3, (b2, b3))) -> (a2, b2)
toNode :: forall a1 a2 b1 a3 b2 b3.
((a1, (a2, b1)), (a3, (b2, b3))) -> (a2, b2)
toNode ((a1
_, (a2
n0, b1
_)), (a3
_, (b2
n1, b3
_))) = (a2
n0, b2
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 :: forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e
-> (Median, Median)
-> Set (UINode, UINode)
-> (Bool, Bool)
-> Insp
-> (Int, Int)
-> ([(UINode, Bool)], [(UINode, Bool)])
-> Set (MYN, MYN)
-> [[(MYN, MYN)]]
sweepForIndependentEdgeLists CGraph n e
graph (Median, Median)
medians Set (UINode, UINode)
allowedEdges (Bool, Bool)
dir Insp
inspectionEdges (Int
y0, Int
y1) ([(UINode, Bool)]
layer0, [(UINode, Bool)]
layer1) Set (MYN, MYN)
missingEdges
  | [(UINode, Bool)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(UINode, Bool)]
layer0 Bool -> Bool -> Bool
&& [(UINode, Bool)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(UINode, Bool)]
layer1 = [Char] -> [[(MYN, MYN)]] -> [[(MYN, MYN)]]
forall a. [Char] -> a -> a
Debug.Trace.trace ([Char]
"nullnull " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ([(UINode, Bool)], [(UINode, Bool)]) -> [Char]
forall a. Show a => a -> [Char]
show ([(UINode, Bool)]
layer0, [(UINode, Bool)]
layer1)) []
  | Int
y0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
10 Bool -> Bool -> Bool
|| Int
y1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
10 = [Char] -> [[(MYN, MYN)]] -> [[(MYN, MYN)]]
forall a. [Char] -> a -> a
Debug.Trace.trace ([Char]
"1010 " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int, Int, [(UINode, Bool)], [(UINode, Bool)]) -> [Char]
forall a. Show a => a -> [Char]
show (Int
y0, Int
y1, [(UINode, Bool)]
layer0, [(UINode, Bool)]
layer1)) []
  | -- node at postion y1 is connected vertically with node at position y1+1
    ([(UINode, Bool)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(UINode, Bool)]
layer1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) Bool -> Bool -> Bool
&& Bool
verticalNode Bool -> Bool -> Bool
&& CGraph n e -> UINode -> Bool
forall e. EdgeClass e => CGraph n e -> UINode -> Bool
forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e -> UINode -> Bool
isFunction CGraph n e
graph UINode
hl1 =
    -- Debug.Trace.trace "sweep vert node" $
    CGraph n e
-> (Median, Median)
-> Set (UINode, UINode)
-> (Bool, Bool)
-> Insp
-> (Int, Int)
-> ([(UINode, Bool)], [(UINode, Bool)])
-> Set (MYN, MYN)
-> [[(MYN, MYN)]]
forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e
-> (Median, Median)
-> Set (UINode, UINode)
-> (Bool, Bool)
-> Insp
-> (Int, Int)
-> ([(UINode, Bool)], [(UINode, Bool)])
-> Set (MYN, MYN)
-> [[(MYN, MYN)]]
sweepForIndependentEdgeLists CGraph n e
graph (Median, Median)
medians Set (UINode, UINode)
allowedEdges (Bool, Bool)
dir Insp
sweepedOver (Int
y0, Int
y1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ([(UINode, Bool)]
layer0, [(UINode, Bool)]
tl1) Set (MYN, MYN)
forall a. Set a
Set.empty
  | Map Int (MYN, MYN) -> Bool
forall k a. Map k a -> Bool
Map.null Map Int (MYN, MYN)
sweepedOverFrom Bool -> Bool -> Bool
&& Map Int (MYN, MYN) -> Bool
forall k a. Map k a -> Bool
Map.null Map Int (MYN, MYN)
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") $
    [(MYN, MYN)]
resEdges [(MYN, MYN)] -> [[(MYN, MYN)]] -> [[(MYN, MYN)]]
forall a. a -> [a] -> [a]
: (CGraph n e
-> (Median, Median)
-> Set (UINode, UINode)
-> (Bool, Bool)
-> Insp
-> (Int, Int)
-> ([(UINode, Bool)], [(UINode, Bool)])
-> Set (MYN, MYN)
-> [[(MYN, MYN)]]
forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e
-> (Median, Median)
-> Set (UINode, UINode)
-> (Bool, Bool)
-> Insp
-> (Int, Int)
-> ([(UINode, Bool)], [(UINode, Bool)])
-> Set (MYN, MYN)
-> [[(MYN, MYN)]]
sweepForIndependentEdgeLists CGraph n e
graph (Median, Median)
medians Set (UINode, UINode)
allowedEdges (Bool, Bool)
dir Insp
sweepedOver (Int
y0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
y1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ([(UINode, Bool)]
tl0, [(UINode, Bool)]
tl1) Set (MYN, MYN)
forall a. Set a
Set.empty)
  | Map Int (MYN, MYN) -> Int
forall k a. Map k a -> Int
Map.size Map Int (MYN, MYN)
sweepedOverFrom Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Map Int (MYN, MYN) -> Int
forall k a. Map k a -> Int
Map.size Map Int (MYN, MYN)
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") $
    CGraph n e
-> (Median, Median)
-> Set (UINode, UINode)
-> (Bool, Bool)
-> Insp
-> (Int, Int)
-> ([(UINode, Bool)], [(UINode, Bool)])
-> Set (MYN, MYN)
-> [[(MYN, MYN)]]
forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e
-> (Median, Median)
-> Set (UINode, UINode)
-> (Bool, Bool)
-> Insp
-> (Int, Int)
-> ([(UINode, Bool)], [(UINode, Bool)])
-> Set (MYN, MYN)
-> [[(MYN, MYN)]]
sweepForIndependentEdgeLists
      CGraph n e
graph
      (Median, Median)
medians
      Set (UINode, UINode)
allowedEdges
      (Bool, Bool)
dir
      Insp
sweepedOver
      (Int
y0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
y1)
      ([(UINode, Bool)]
tl0, [(UINode, Bool)]
layer1)
      (Set (MYN, MYN) -> Set (MYN, MYN) -> Set (MYN, MYN)
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (MYN, MYN)
missingEdges Set (MYN, MYN)
newMissingEdges)
  | Bool
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") $
    =
    CGraph n e
-> (Median, Median)
-> Set (UINode, UINode)
-> (Bool, Bool)
-> Insp
-> (Int, Int)
-> ([(UINode, Bool)], [(UINode, Bool)])
-> Set (MYN, MYN)
-> [[(MYN, MYN)]]
forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e
-> (Median, Median)
-> Set (UINode, UINode)
-> (Bool, Bool)
-> Insp
-> (Int, Int)
-> ([(UINode, Bool)], [(UINode, Bool)])
-> Set (MYN, MYN)
-> [[(MYN, MYN)]]
sweepForIndependentEdgeLists
      CGraph n e
graph
      (Median, Median)
medians
      Set (UINode, UINode)
allowedEdges
      (Bool, Bool)
dir
      Insp
sweepedOver
      (Int
y0, Int
y1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      ([(UINode, Bool)]
layer0, [(UINode, Bool)]
tl1)
      (Set (MYN, MYN) -> Set (MYN, MYN) -> Set (MYN, MYN)
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (MYN, MYN)
missingEdges Set (MYN, MYN)
newMissingEdges)
  where
    (Map Int (MYN, MYN)
inspectEdgesFrom, Map Int (MYN, MYN)
inspectEdgesTo) = Insp
inspectionEdges
    (Median
lowerMedians, Median
upperMedians) = (Median, Median)
medians
    (Bool
left, Bool
_up) = (Bool, Bool)
dir
    (UINode
n0, Bool
b0) = Int -> [(UINode, Bool)] -> (UINode, Bool)
forall a. Int -> [a] -> a
myHead Int
60 [(UINode, Bool)]
layer0
    (UINode
n1, Bool
b1) = Int -> [(UINode, Bool)] -> (UINode, Bool)
forall a. Int -> [a] -> a
myHead Int
61 [(UINode, Bool)]
layer1
    tl0 :: [(UINode, Bool)]
tl0
      | [(UINode, Bool)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(UINode, Bool)]
layer0 = []
      | Bool
otherwise = [(UINode, Bool)] -> [(UINode, Bool)]
forall a. HasCallStack => [a] -> [a]
tail [(UINode, Bool)]
layer0
    tl1 :: [(UINode, Bool)]
tl1
      | [(UINode, Bool)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(UINode, Bool)]
layer1 = []
      | Bool
otherwise = [(UINode, Bool)] -> [(UINode, Bool)]
forall a. HasCallStack => [a] -> [a]
tail [(UINode, Bool)]
layer1
    hl1 :: UINode
hl1 = (UINode, Bool) -> UINode
forall a b. (a, b) -> a
fst (Int -> [(UINode, Bool)] -> (UINode, Bool)
forall a. Int -> [a] -> a
myHead Int
62 [(UINode, Bool)]
layer1)
    verticalNode :: Bool
verticalNode = UINode -> Vector UINode -> Bool
forall a. (Unbox a, Eq a) => a -> Vector a -> Bool
VU.elem ((UINode, Bool) -> UINode
forall a b. (a, b) -> a
fst (Int -> [(UINode, Bool)] -> (UINode, Bool)
forall a. Int -> [a] -> a
myHead Int
63 [(UINode, Bool)]
tl1)) (CGraph n e -> Bool -> UINode -> Edge8 -> Vector UINode
forall el nl.
EdgeAttribute el =>
Graph nl el -> Bool -> UINode -> Edge8 -> Vector UINode
Graph.adjacentNodesByAttr CGraph n e
graph Bool
True UINode
hl1 (Word8 -> Edge8
Graph.Edge8 Word8
Common.vertBit))
    resEdges :: [(MYN, MYN)]
resEdges = [(MYN, MYN)] -> [(MYN, MYN)]
forall a. Ord a => [a] -> [a]
myNub (Map Int (MYN, MYN) -> [(MYN, MYN)]
forall k a. Map k a -> [a]
Map.elems Map Int (MYN, MYN)
newInsFrom [(MYN, MYN)] -> [(MYN, MYN)] -> [(MYN, MYN)]
forall a. [a] -> [a] -> [a]
++ Map Int (MYN, MYN) -> [(MYN, MYN)]
forall k a. Map k a -> [a]
Map.elems Map Int (MYN, MYN)
newInsTo [(MYN, MYN)] -> [(MYN, MYN)] -> [(MYN, MYN)]
forall a. [a] -> [a] -> [a]
++ Set (MYN, MYN) -> [(MYN, MYN)]
forall a. Set a -> [a]
Set.toList Set (MYN, MYN)
missingEdges)

    edgeFrom :: Maybe MYN
    edgeFrom :: Maybe MYN
edgeFrom
      | [(UINode, Bool)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(UINode, Bool)]
layer0 = Maybe MYN
forall a. Maybe a
Nothing
      | Bool
otherwise -- Debug.Trace.trace ("up2 "++ show (n0, Map.lookup n0 upperMedians)) $
        =
        UINode -> Median -> Maybe MYN
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n0 Median
upperMedians
    edgeTo :: Maybe MYN
    edgeTo :: Maybe MYN
edgeTo
      | [(UINode, Bool)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(UINode, Bool)]
layer1 --  || (not (Set.member (n0,n1) allowedEdges))
        =
        Maybe MYN
forall a. Maybe a
Nothing
      | Bool
otherwise -- Debug.Trace.trace ("up4 "++ show (n1, Map.lookup n1 lowerMedians)) $
        =
        UINode -> Median -> Maybe MYN
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n1 Median
lowerMedians

    newInsFrom :: Map Int (MYN, MYN)
    newInsFrom :: Map Int (MYN, MYN)
newInsFrom
      | Maybe MYN -> Bool
forall a. Maybe a -> Bool
isJust Maybe MYN
edgeFrom Bool -> Bool -> Bool
&& Int
yy1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
y1 = Int -> (MYN, MYN) -> Map Int (MYN, MYN) -> Map Int (MYN, MYN)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
yy1 ((Int, (UINode, Bool)) -> MYN
Single (Int
y0, (UINode
n0, Bool
b0)), Int -> Maybe MYN -> MYN
forall a. Int -> Maybe a -> a
myFromJust Int
504 Maybe MYN
edgeFrom) Map Int (MYN, MYN)
inspectEdgesFrom
      | Bool
otherwise = Map Int (MYN, MYN)
inspectEdgesFrom
      where
        yy1 :: Int
yy1 = Bool -> MYN -> Int
getY Bool
left (Int -> Maybe MYN -> MYN
forall a. Int -> Maybe a -> a
myFromJust Int
505 Maybe MYN
edgeFrom)

    newInsTo :: Map Int (MYN, MYN)
    newInsTo :: Map Int (MYN, MYN)
newInsTo
      | Maybe MYN -> Bool
forall a. Maybe a -> Bool
isJust Maybe MYN
edgeTo Bool -> Bool -> Bool
&& Int
yy0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
y0 = Int -> (MYN, MYN) -> Map Int (MYN, MYN) -> Map Int (MYN, MYN)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
yy0 (Int -> Maybe MYN -> MYN
forall a. Int -> Maybe a -> a
myFromJust Int
506 Maybe MYN
edgeTo, (Int, (UINode, Bool)) -> MYN
Single (Int
y1, (UINode
n1, Bool
b1))) Map Int (MYN, MYN)
inspectEdgesTo
      | Bool
otherwise = Map Int (MYN, MYN)
inspectEdgesTo
      where
        yy0 :: Int
yy0 = Bool -> MYN -> Int
getY Bool
left (Int -> Maybe MYN -> MYN
forall a. Int -> Maybe a -> a
myFromJust Int
506 Maybe MYN
edgeTo)

    newMissingEdges :: Set.Set (MYN, MYN)
    newMissingEdges :: Set (MYN, MYN)
newMissingEdges
      | Maybe MYN -> Bool
forall a. Maybe a -> Bool
isJust Maybe MYN
edgeFrom Bool -> Bool -> Bool
&& Maybe MYN -> Bool
forall a. Maybe a -> Bool
isJust Maybe MYN
edgeTo =
        [(MYN, MYN)] -> Set (MYN, MYN)
forall a. Ord a => [a] -> Set a
Set.fromList
          [ ((Int, (UINode, Bool)) -> MYN
Single (Int
y0, (UINode
n0, Bool
b0)), Int -> Maybe MYN -> MYN
forall a. Int -> Maybe a -> a
myFromJust Int
507 Maybe MYN
edgeFrom),
            (Int -> Maybe MYN -> MYN
forall a. Int -> Maybe a -> a
myFromJust Int
508 Maybe MYN
edgeTo, (Int, (UINode, Bool)) -> MYN
Single (Int
y1, (UINode
n1, Bool
b1)))
          ]
      | Maybe MYN -> Bool
forall a. Maybe a -> Bool
isJust Maybe MYN
edgeFrom = (MYN, MYN) -> Set (MYN, MYN)
forall a. a -> Set a
Set.singleton ((Int, (UINode, Bool)) -> MYN
Single (Int
y0, (UINode
n0, Bool
b0)), Int -> Maybe MYN -> MYN
forall a. Int -> Maybe a -> a
myFromJust Int
509 Maybe MYN
edgeFrom)
      | Maybe MYN -> Bool
forall a. Maybe a -> Bool
isJust Maybe MYN
edgeTo = (MYN, MYN) -> Set (MYN, MYN)
forall a. a -> Set a
Set.singleton (Int -> Maybe MYN -> MYN
forall a. Int -> Maybe a -> a
myFromJust Int
510 Maybe MYN
edgeTo, (Int, (UINode, Bool)) -> MYN
Single (Int
y1, (UINode
n1, Bool
b1)))
      | Bool
otherwise = Set (MYN, MYN)
forall a. Set a
Set.empty

    sweepedOverFrom :: Map Int (MYN, MYN)
sweepedOverFrom = Int -> Map Int (MYN, MYN) -> Map Int (MYN, MYN)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Int
y1 Map Int (MYN, MYN)
newInsFrom
    sweepedOverTo :: Map Int (MYN, MYN)
sweepedOverTo = Int -> Map Int (MYN, MYN) -> Map Int (MYN, MYN)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Int
y0 Map Int (MYN, MYN)
newInsTo
    sweepedOver :: Insp
sweepedOver = (Map Int (MYN, MYN)
sweepedOverFrom, Map Int (MYN, MYN)
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 (EdgeTy a -> EdgeTy a -> Bool
(EdgeTy a -> EdgeTy a -> Bool)
-> (EdgeTy a -> EdgeTy a -> Bool) -> Eq (EdgeTy a)
forall a. Eq a => EdgeTy a -> EdgeTy a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => EdgeTy a -> EdgeTy a -> Bool
== :: EdgeTy a -> EdgeTy a -> Bool
$c/= :: forall a. Eq a => EdgeTy a -> EdgeTy a -> Bool
/= :: EdgeTy a -> EdgeTy a -> Bool
Eq, Int -> EdgeTy a -> ShowS
[EdgeTy a] -> ShowS
EdgeTy a -> [Char]
(Int -> EdgeTy a -> ShowS)
-> (EdgeTy a -> [Char]) -> ([EdgeTy a] -> ShowS) -> Show (EdgeTy a)
forall a. Show a => Int -> EdgeTy a -> ShowS
forall a. Show a => [EdgeTy a] -> ShowS
forall a. Show a => EdgeTy a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> EdgeTy a -> ShowS
showsPrec :: Int -> EdgeTy a -> ShowS
$cshow :: forall a. Show a => EdgeTy a -> [Char]
show :: EdgeTy a -> [Char]
$cshowList :: forall a. Show a => [EdgeTy a] -> ShowS
showList :: [EdgeTy a] -> ShowS
Show)

resolveConflicts :: (Bool, Bool) -> [(MYN, MYN)] -> [(YN, YN)]
resolveConflicts :: (Bool, Bool)
-> [(MYN, MYN)] -> [((Int, (UINode, Bool)), (Int, (UINode, Bool)))]
resolveConflicts (Bool
_, Bool
_) [] = []
resolveConflicts (Bool
left, Bool
_) [(MYN, MYN)
e] = [Bool
-> (MYN, MYN) -> ((Int, (UINode, Bool)), (Int, (UINode, Bool)))
toYN Bool
left (MYN, MYN)
e]
resolveConflicts (Bool
left, Bool
up) [(MYN, MYN)]
es =
  -- Debug.Trace.trace ("resolveConflicts"++ show (es, resolveConfs (left,up) es 0)) $
  ((MYN, MYN) -> ((Int, (UINode, Bool)), (Int, (UINode, Bool))))
-> [(MYN, MYN)] -> [((Int, (UINode, Bool)), (Int, (UINode, Bool)))]
forall a b. (a -> b) -> [a] -> [b]
map (Bool
-> (MYN, MYN) -> ((Int, (UINode, Bool)), (Int, (UINode, Bool)))
toYN Bool
left) ((Bool, Bool) -> [(MYN, MYN)] -> Int -> [(MYN, MYN)]
resolveConfs (Bool
left, Bool
up) [(MYN, MYN)]
es Int
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 :: (Bool, Bool) -> [(MYN, MYN)] -> Int -> [(MYN, MYN)]
resolveConfs (Bool
_, Bool
_) [] Int
_ =
  -- Debug.Trace.trace "ch0 "
  []
resolveConfs (Bool
left, Bool
up) ((MYN, MYN)
e0 : [(MYN, MYN)]
edges) Int
i
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
20 -- Debug.Trace.trace ("ch1 "++ show (e0:edges))
    =
    (MYN, MYN)
e0 (MYN, MYN) -> [(MYN, MYN)] -> [(MYN, MYN)]
forall a. a -> [a] -> [a]
: [(MYN, MYN)]
edges -- avoid endless loop
  | EdgeTy Bool -> Bool
checkE0 EdgeTy Bool
consistent -- Debug.Trace.trace ("checkE0 "++ show (map te (e0:edges)) ++"\n"++ show (map _toEdges2 conflictList) ++"\n") $
    =
    (MYN, MYN)
e0 (MYN, MYN) -> [(MYN, MYN)] -> [(MYN, MYN)]
forall a. a -> [a] -> [a]
: ((Bool, Bool) -> [(MYN, MYN)] -> Int -> [(MYN, MYN)]
resolveConfs (Bool
left, Bool
up) [(MYN, MYN)]
removeInferiorToE0 (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
  | EdgeTy Bool -> Bool
forall {a}. EdgeTy a -> Bool
checkNoIntersect EdgeTy Bool
consistent -- Debug.Trace.trace ("check noIntersect "++ show (map te (e0:edges)) ++"\n"++ show (conflictList, consistent, i) ++ "\n") $
    =
    if [EdgeTy (MYN, MYN)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EdgeTy (MYN, MYN)]
conflictList
      then (MYN, MYN)
e0 (MYN, MYN) -> [(MYN, MYN)] -> [(MYN, MYN)]
forall a. a -> [a] -> [a]
: [(MYN, MYN)]
edges
      else (MYN, MYN)
e0 (MYN, MYN) -> [(MYN, MYN)] -> [(MYN, MYN)]
forall a. a -> [a] -> [a]
: ((Bool, Bool) -> [(MYN, MYN)] -> Int -> [(MYN, MYN)]
resolveConfs (Bool
left, Bool
up) [(MYN, MYN)]
edges (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) -- concat (map toEdges conflictList)
  | Bool
otherwise -- Debug.Trace.trace ("checkE1 "++ show (map te (e0:edges)) ++"\n"++ show (conflictList, consistent, i, firstE1, edgesE1First) ++ "\n") $
    =
    (Bool, Bool) -> [(MYN, MYN)] -> Int -> [(MYN, MYN)]
resolveConfs (Bool
left, Bool
up) [(MYN, MYN)]
edgesE1First (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  where
    conflictList :: [EdgeTy (MYN, MYN)]
conflictList = ((MYN, MYN) -> EdgeTy (MYN, MYN))
-> [(MYN, MYN)] -> [EdgeTy (MYN, MYN)]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> (MYN, MYN) -> (MYN, MYN) -> EdgeTy (MYN, MYN)
conflict Bool
left (MYN, MYN)
e0) [(MYN, MYN)]
edges

    edgesE1First :: [(MYN, MYN)]
edgesE1First = (MYN, MYN)
e1 (MYN, MYN) -> [(MYN, MYN)] -> [(MYN, MYN)]
forall a. a -> [a] -> [a]
: (((MYN, MYN) -> Bool) -> [(MYN, MYN)] -> [(MYN, MYN)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(MYN, MYN)
e -> (MYN, MYN)
e (MYN, MYN) -> (MYN, MYN) -> Bool
forall a. Eq a => a -> a -> Bool
/= (MYN, MYN)
e0 Bool -> Bool -> Bool
&& (MYN, MYN)
e (MYN, MYN) -> (MYN, MYN) -> Bool
forall a. Eq a => a -> a -> Bool
/= (MYN, MYN)
e1) ((EdgeTy (MYN, MYN) -> [(MYN, MYN)])
-> [EdgeTy (MYN, MYN)] -> [(MYN, MYN)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap EdgeTy (MYN, MYN) -> [(MYN, MYN)]
forall {a}. EdgeTy a -> [a]
toEdges [EdgeTy (MYN, MYN)]
conflictList))
    e1 :: (MYN, MYN)
e1 = Int -> [(MYN, MYN)] -> (MYN, MYN)
forall a. Int -> [a] -> a
myHead Int
64 (EdgeTy (MYN, MYN) -> [(MYN, MYN)]
forall {a}. EdgeTy a -> [a]
toEdges EdgeTy (MYN, MYN)
firstE1)
    firstE1 :: EdgeTy (MYN, MYN)
firstE1 = Int -> Maybe (EdgeTy (MYN, MYN)) -> EdgeTy (MYN, MYN)
forall a. Int -> Maybe a -> a
myFromJust Int
511 ((EdgeTy (MYN, MYN) -> Bool)
-> [EdgeTy (MYN, MYN)] -> Maybe (EdgeTy (MYN, MYN))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find EdgeTy (MYN, MYN) -> Bool
forall {a}. EdgeTy a -> Bool
e1Prevails [EdgeTy (MYN, MYN)]
conflictList)

    consistent :: EdgeTy Bool
consistent = [EdgeTy (MYN, MYN)] -> EdgeTy Bool
isConsistent [EdgeTy (MYN, MYN)]
conflictList
    checkE0 :: EdgeTy Bool -> Bool
checkE0 (E0Prevails Bool
True) = Bool
True
    checkE0 EdgeTy Bool
_ = Bool
False
    _checkE1 :: EdgeTy Bool -> Bool
_checkE1 (E1Prevails Bool
True) = Bool
True
    _checkE1 EdgeTy Bool
_ = Bool
False
    checkNoIntersect :: EdgeTy a -> Bool
checkNoIntersect (NoIntersect (a, a)
_) = Bool
True
    checkNoIntersect EdgeTy a
_ = Bool
False
    removeInferiorToE0 :: [(MYN, MYN)]
removeInferiorToE0 = [(MYN, MYN)] -> [(MYN, MYN)]
forall a. Ord a => [a] -> [a]
rmdups ([(MYN, MYN)] -> [(MYN, MYN)]) -> [(MYN, MYN)] -> [(MYN, MYN)]
forall a b. (a -> b) -> a -> b
$ (EdgeTy (MYN, MYN) -> [(MYN, MYN)])
-> [EdgeTy (MYN, MYN)] -> [(MYN, MYN)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap EdgeTy (MYN, MYN) -> [(MYN, MYN)]
forall {a}. EdgeTy a -> [a]
toEdges ((EdgeTy (MYN, MYN) -> Bool)
-> [EdgeTy (MYN, MYN)] -> [EdgeTy (MYN, MYN)]
forall a. (a -> Bool) -> [a] -> [a]
filter EdgeTy (MYN, MYN) -> Bool
forall {a}. EdgeTy a -> Bool
isNoIntersect [EdgeTy (MYN, MYN)]
conflictList)
    isNoIntersect :: EdgeTy a -> Bool
isNoIntersect (NoIntersect (a, a)
_) = Bool
True
    isNoIntersect EdgeTy a
_ = Bool
False
    e1Prevails :: EdgeTy a -> Bool
e1Prevails (E1Prevails a
_) = Bool
True
    e1Prevails EdgeTy a
_ = Bool
False
    toEdges :: EdgeTy a -> [a]
toEdges (E0Prevails a
e) = [a
e]
    toEdges (E1Prevails a
e) = [a
e]
    toEdges (NoIntersect (a
edge0, a
edge1)) = [a
edge0, a
edge1]

    _toEdges2 :: EdgeTy (MYN, MYN) -> [([UINode], [UINode])]
_toEdges2 (E0Prevails (MYN
n0, MYN
n1)) = [(MYN, MYN) -> ([UINode], [UINode])
te1 (MYN
n0, MYN
n1)]
    _toEdges2 (E1Prevails (MYN
n0, MYN
n1)) = [(MYN, MYN) -> ([UINode], [UINode])
te1 (MYN
n0, MYN
n1)]
    _toEdges2 (NoIntersect ((MYN
n0, MYN
n1), (MYN
n2, MYN
n3))) = [(MYN, MYN) -> ([UINode], [UINode])
te1 (MYN
n0, MYN
n1), (MYN, MYN) -> ([UINode], [UINode])
te1 (MYN
n2, MYN
n3)]
    te1 :: (MYN, MYN) -> ([UINode], [UINode])
te1 (MYN
n0, MYN
n1) = (MYN -> [UINode]
getN MYN
n0, MYN -> [UINode]
getN MYN
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 :: [EdgeTy (MYN, MYN)] -> EdgeTy Bool
isConsistent (NoIntersect ((MYN, MYN), (MYN, MYN))
_ : [EdgeTy (MYN, MYN)]
es) = [EdgeTy (MYN, MYN)] -> EdgeTy Bool
isConsistent [EdgeTy (MYN, MYN)]
es
isConsistent [] = (Bool, Bool) -> EdgeTy Bool
forall a. (a, a) -> EdgeTy a
NoIntersect (Bool
True, Bool
True) -- will only be called if there is no E0Prevails or E1Prevails
isConsistent ((E0Prevails (MYN, MYN)
_) : [EdgeTy (MYN, MYN)]
es) = [EdgeTy (MYN, MYN)] -> EdgeTy Bool
forall {a}. [EdgeTy a] -> EdgeTy Bool
isAllE0OrNoIntersect [EdgeTy (MYN, MYN)]
es
  where
    isAllE0OrNoIntersect :: [EdgeTy a] -> EdgeTy Bool
isAllE0OrNoIntersect [] = Bool -> EdgeTy Bool
forall a. a -> EdgeTy a
E0Prevails Bool
True
    isAllE0OrNoIntersect ((E0Prevails a
_) : [EdgeTy a]
edges) = [EdgeTy a] -> EdgeTy Bool
isAllE0OrNoIntersect [EdgeTy a]
edges
    isAllE0OrNoIntersect ((NoIntersect (a, a)
_) : [EdgeTy a]
edges) = [EdgeTy a] -> EdgeTy Bool
isAllE0OrNoIntersect [EdgeTy a]
edges
    isAllE0OrNoIntersect (EdgeTy a
_ : [EdgeTy a]
_) = Bool -> EdgeTy Bool
forall a. a -> EdgeTy a
E0Prevails Bool
False -- not consistent
isConsistent ((E1Prevails (MYN, MYN)
_) : [EdgeTy (MYN, MYN)]
es) = [EdgeTy (MYN, MYN)] -> EdgeTy Bool
forall {a}. [EdgeTy a] -> EdgeTy Bool
isAllE1OrNoIntersect [EdgeTy (MYN, MYN)]
es
  where
    isAllE1OrNoIntersect :: [EdgeTy a] -> EdgeTy Bool
isAllE1OrNoIntersect [] = Bool -> EdgeTy Bool
forall a. a -> EdgeTy a
E1Prevails Bool
True
    isAllE1OrNoIntersect ((E1Prevails a
_) : [EdgeTy a]
edges) = [EdgeTy a] -> EdgeTy Bool
isAllE1OrNoIntersect [EdgeTy a]
edges
    isAllE1OrNoIntersect ((NoIntersect (a, a)
_) : [EdgeTy a]
edges) = [EdgeTy a] -> EdgeTy Bool
isAllE1OrNoIntersect [EdgeTy a]
edges
    isAllE1OrNoIntersect (EdgeTy a
_ : [EdgeTy a]
_) = Bool -> EdgeTy Bool
forall a. a -> EdgeTy a
E1Prevails Bool
False

conflict :: Bool -> (MYN, MYN) -> (MYN, MYN) -> EdgeTy (MYN, MYN)
conflict :: Bool -> (MYN, MYN) -> (MYN, MYN) -> EdgeTy (MYN, MYN)
conflict Bool
left (MYN
n0, MYN
n1) (MYN
n2, MYN
n3)
  | Bool
isIntersecting -- Debug.Trace.trace ("intersecting "++ show (n0,n1,n2,n3)) $
    =
    Bool -> (MYN, MYN) -> (MYN, MYN) -> EdgeTy (MYN, MYN)
cases Bool
left (MYN
n0, MYN
n1) (MYN
n2, MYN
n3)
  | Bool
otherwise = ((MYN, MYN), (MYN, MYN)) -> EdgeTy (MYN, MYN)
forall a. (a, a) -> EdgeTy a
NoIntersect ((MYN
n0, MYN
n1), (MYN
n2, MYN
n3))
  where
    isIntersecting :: Bool
isIntersecting -- two segments intersect
      =
      (Bool -> MYN -> Int
getY Bool
left MYN
n0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Bool -> MYN -> Int
getY Bool
left MYN
n2 Bool -> Bool -> Bool
&& Bool -> MYN -> Int
getY Bool
left MYN
n1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Bool -> MYN -> Int
getY Bool
left MYN
n3)
        Bool -> Bool -> Bool
|| (Bool -> MYN -> Int
getY Bool
left MYN
n0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Bool -> MYN -> Int
getY Bool
left MYN
n2 Bool -> Bool -> Bool
&& Bool -> MYN -> Int
getY Bool
left MYN
n1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Bool -> MYN -> Int
getY Bool
left MYN
n3)

-- | Given two edges that intersect or connect, which one will prevail?
cases :: Bool -> (MYN, MYN) -> (MYN, MYN) -> EdgeTy (MYN, MYN)
cases :: Bool -> (MYN, MYN) -> (MYN, MYN) -> EdgeTy (MYN, MYN)
cases Bool
left (MYN
n0, MYN
n1) (MYN
n2, MYN
n3)
  -- type 2 (one segment consists of two connection nodes and is preferred then)
  | MYN -> Bool
connNode MYN
n0 Bool -> Bool -> Bool
&& MYN -> Bool
connNode MYN
n1 -- Debug.Trace.trace ("type2 0 "++ show (n0,n1,n2,n3)) $
    =
    (MYN, MYN) -> EdgeTy (MYN, MYN)
forall a. a -> EdgeTy a
E0Prevails (MYN
n0, MYN
n1)
  | MYN -> Bool
connNode MYN
n2 Bool -> Bool -> Bool
&& MYN -> Bool
connNode MYN
n3 -- Debug.Trace.trace ("type2 1 "++ show (n0,n1,n2,n3)) $
    =
    (MYN, MYN) -> EdgeTy (MYN, MYN)
forall a. a -> EdgeTy a
E1Prevails (MYN
n2, MYN
n3)
  | (MYN -> Bool
connNode MYN
n0 Bool -> Bool -> Bool
|| MYN -> Bool
connNode MYN
n1)
      Bool -> Bool -> Bool
&& (MYN -> Bool
connNode MYN
n2 Bool -> Bool -> Bool
|| MYN -> Bool
connNode MYN
n3) -- one connection node (type 2)
    =
    if (MYN -> Bool
isMedian MYN
n0 Bool -> Bool -> Bool
|| MYN -> Bool
isMedian MYN
n1) Bool -> Bool -> Bool
&& MYN -> Bool
isSingle MYN
n2 Bool -> Bool -> Bool
&& MYN -> Bool
isSingle MYN
n3
      then -- Debug.Trace.trace ("type2 2 "++ show (n0,n1,n2,n3)) $
        (MYN, MYN) -> EdgeTy (MYN, MYN)
forall a. a -> EdgeTy a
E0Prevails (MYN
n0, MYN
n1)
      else (MYN, MYN) -> EdgeTy (MYN, MYN)
forall a. a -> EdgeTy a
E0Prevails (MYN
n2, MYN
n3)
  -- type 1 (non-inner segment crosses an inner segment)
  | (MYN -> Bool
connNode MYN
n0 Bool -> Bool -> Bool
|| MYN -> Bool
connNode MYN
n1)
      Bool -> Bool -> Bool
&& Bool -> Bool
not (MYN -> Bool
connNode MYN
n2)
      Bool -> Bool -> Bool
&& Bool -> Bool
not (MYN -> Bool
connNode MYN
n3) -- Debug.Trace.trace ("type1 0"++ show (n0,n1,n2,n3)) $
    =
    (MYN, MYN) -> EdgeTy (MYN, MYN)
forall a. a -> EdgeTy a
E0Prevails (MYN
n0, MYN
n1)
  | (MYN -> Bool
connNode MYN
n2 Bool -> Bool -> Bool
|| MYN -> Bool
connNode MYN
n3)
      Bool -> Bool -> Bool
&& Bool -> Bool
not (MYN -> Bool
connNode MYN
n0)
      Bool -> Bool -> Bool
&& Bool -> Bool
not (MYN -> Bool
connNode MYN
n1) -- Debug.Trace.trace ("type1 1"++ show (n0,n1,n2,n3)) $
    =
    (MYN, MYN) -> EdgeTy (MYN, MYN)
forall a. a -> EdgeTy a
E1Prevails (MYN
n2, MYN
n3)
  -- type 0 (a pair of non-inner segments)
  | Bool -> Bool
not (MYN -> Bool
connNode MYN
n0) Bool -> Bool -> Bool
&& Bool -> Bool
not (MYN -> Bool
connNode MYN
n1)
      Bool -> Bool -> Bool
&& Bool -> Bool
not (MYN -> Bool
connNode MYN
n2)
      Bool -> Bool -> Bool
&& Bool -> Bool
not (MYN -> Bool
connNode MYN
n3) -- Debug.Trace.trace ("type0 "++ show (preferE0,n0,n1,n2,n3)) $
    =
    if Bool
preferE0
      then (MYN, MYN) -> EdgeTy (MYN, MYN)
forall a. a -> EdgeTy a
E0Prevails (MYN
n0, MYN
n1)
      else (MYN, MYN) -> EdgeTy (MYN, MYN)
forall a. a -> EdgeTy a
E1Prevails (MYN
n2, MYN
n3)
  | Bool
otherwise = [Char] -> EdgeTy (MYN, MYN) -> EdgeTy (MYN, MYN)
forall a. [Char] -> a -> a
Debug.Trace.trace [Char]
"cases err" (EdgeTy (MYN, MYN) -> EdgeTy (MYN, MYN))
-> EdgeTy (MYN, MYN) -> EdgeTy (MYN, MYN)
forall a b. (a -> b) -> a -> b
$ (MYN, MYN) -> EdgeTy (MYN, MYN)
forall a. a -> EdgeTy a
E0Prevails (MYN
n0, MYN
n1) -- correct? just to fix a warning
  where
    connNode :: MYN -> Bool
connNode (Single (Int
_, (UINode
_, Bool
b))) = Bool
b
    connNode (Middle (Int
_, (UINode
_, Bool
b))) = Bool
b
    connNode (UpLowMedian (Int
_, (UINode
_, Bool
b0)) (Int
_, (UINode
_, Bool
b1)))
      | Bool
left = Bool
b0
      | Bool
otherwise = Bool
b1
    isMedian :: MYN -> Bool
isMedian (Single (Int, (UINode, Bool))
_) = Bool
False
    isMedian (Middle (Int, (UINode, Bool))
_) = Bool
True
    isMedian (UpLowMedian (Int, (UINode, Bool))
_n0 (Int, (UINode, Bool))
_n1) = Bool
True
    isSingle :: MYN -> Bool
isSingle (Single (Int, (UINode, Bool))
_) = Bool
True
    isSingle MYN
_ = Bool
False
    preferE0 :: Bool
preferE0
      | (MYN -> Bool
isMedian MYN
n0 Bool -> Bool -> Bool
|| MYN -> Bool
isMedian MYN
n1) Bool -> Bool -> Bool
&& Bool -> Bool
not (MYN -> Bool
isMedian MYN
n2) Bool -> Bool -> Bool
&& Bool -> Bool
not (MYN -> Bool
isMedian MYN
n3) -- Debug.Trace.trace "p0"
        =
        Bool
True
      | (MYN -> Bool
isMedian MYN
n2 Bool -> Bool -> Bool
|| MYN -> Bool
isMedian MYN
n3) Bool -> Bool -> Bool
&& Bool -> Bool
not (MYN -> Bool
isMedian MYN
n0) Bool -> Bool -> Bool
&& Bool -> Bool
not (MYN -> Bool
isMedian MYN
n1) -- Debug.Trace.trace "p1"
        =
        Bool
False
      | Int -> Int
forall a. Num a => a -> a
abs (Bool -> MYN -> Int
getY Bool
left MYN
n0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Bool -> MYN -> Int
getY Bool
left MYN
n1) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> Int
forall a. Num a => a -> a
abs (Bool -> MYN -> Int
getY Bool
left MYN
n2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Bool -> MYN -> Int
getY Bool
left MYN
n3) -- Debug.Trace.trace "p2"
        =
        Bool
True
      | Bool
otherwise -- Debug.Trace.trace "p3"
        =
        Bool
False


blockChildren :: Map UINode UINode -> (X, UINode) -> [(X, UINode)]
blockChildren :: Map UINode UINode -> (Int, UINode) -> [(Int, UINode)]
blockChildren Map UINode UINode
edgeMap (Int
x, UINode
n)
  | Maybe UINode -> Bool
forall a. Maybe a -> Bool
isJust Maybe UINode
lu = (Int
x, UINode
n) (Int, UINode) -> [(Int, UINode)] -> [(Int, UINode)]
forall a. a -> [a] -> [a]
: Map UINode UINode -> (Int, UINode) -> [(Int, UINode)]
blockChildren Map UINode UINode
edgeMap (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int -> Maybe UINode -> UINode
forall a. Int -> Maybe a -> a
myFromJust Int
513 Maybe UINode
lu)
  | Bool
otherwise = [(Int
x, UINode
n)]
    where lu :: Maybe UINode
lu = UINode -> Map UINode UINode -> Maybe UINode
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n Map UINode UINode
edgeMap

nodeWithoutParent :: [[UINode]] -> [(UINode, UINode)] -> (X, UINode) -> Maybe (X, UINode)
nodeWithoutParent :: [[UINode]]
-> [(UINode, UINode)] -> (Int, UINode) -> Maybe (Int, UINode)
nodeWithoutParent [[UINode]]
layers [(UINode, UINode)]
edges (Int
x, UINode
n)
  | Maybe UINode -> Bool
forall a. Maybe a -> Bool
isNothing (UINode -> Map UINode UINode -> Maybe UINode
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n Map UINode UINode
reverseBlocks)
      Bool -> Bool -> Bool
&& (Int, UINode) -> Bool
noParentInLayer (Int
x, UINode
n) -- no parent in block
    =
      --  Debug.Trace.trace ("nodeWoPar0 "++ show (n, Map.lookup n reverseBlocks, noParentInLayer (x,n))) $
      (Int, UINode) -> Maybe (Int, UINode)
forall a. a -> Maybe a
Just (Int
x, UINode
n)
  | Bool
otherwise =
    --  Debug.Trace.trace ("nodeWoPar1 "++ show (n, Map.lookup n reverseBlocks, noParentInLayer (x,n))) $
    Maybe (Int, UINode)
forall a. Maybe a
Nothing
      where
        noParentInLayer :: (Int, UINode) -> Bool
noParentInLayer (Int, UINode)
root =
          -- Debug.Trace.trace ("noParInLayer "++ show (root, blockChildren root,
          --                   map hasNoLayerParent (blockChildren root))) $
          ((Int, UINode) -> Bool) -> [(Int, UINode)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int, UINode) -> Bool
hasNoLayerParent (Map UINode UINode -> (Int, UINode) -> [(Int, UINode)]
blockChildren Map UINode UINode
edgeMap (Int, UINode)
root)

        hasNoLayerParent :: (Int, UINode) -> Bool
hasNoLayerParent (Int
_, UINode
_n) = Maybe UINode -> Bool
forall a. Maybe a -> Bool
isNothing (UINode -> Map UINode UINode -> Maybe UINode
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n Map UINode UINode
layerConnections)
        reverseBlocks :: Map UINode UINode
reverseBlocks = [(UINode, UINode)] -> Map UINode UINode
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (((UINode, UINode) -> (UINode, UINode))
-> [(UINode, UINode)] -> [(UINode, UINode)]
forall a b. (a -> b) -> [a] -> [b]
map (UINode, UINode) -> (UINode, UINode)
forall a b. (a, b) -> (b, a)
swap [(UINode, UINode)]
edges)
        edgeMap :: Map UINode UINode
edgeMap = [(UINode, UINode)] -> Map UINode UINode
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(UINode, UINode)]
edges
        layerConnections :: Map UINode UINode
layerConnections = [(UINode, UINode)] -> Map UINode UINode
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(UINode, UINode)] -> Map UINode UINode)
-> [(UINode, UINode)] -> Map UINode UINode
forall a b. (a -> b) -> a -> b
$ ([UINode] -> [(UINode, UINode)])
-> [[UINode]] -> [(UINode, UINode)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [UINode] -> [(UINode, UINode)]
forall a. [a] -> [(a, a)]
tuples [[UINode]]
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 :: forall e n.
(EdgeClass e, Show n, NodeClass n, ExtractNodeType n, Show e,
 Enum n) =>
CGraph n e
-> [[UINode]]
-> [(UINode, UINode)]
-> (Bool, Bool)
-> Map UINode (Int, Int)
align CGraph n e
graph [[UINode]]
layers [(UINode, UINode)]
edges (Bool
_alignLeft, Bool
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
--                    )
  Map UINode (Int, Int)
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 :: Map UINode (Int, Int)
mb2 =
          -- Debug.Trace.trace ("lp\n" ++ show lp ++ "\nmb\n" ++ show (moveBlocks (Map.fromList lp), moveBlocksAgain (Map.fromList lp)) ++ "\n") $
          Map UINode (Int, Int) -> Map UINode (Int, Int)
moveBlocksAgain ([(UINode, (Int, Int))] -> Map UINode (Int, Int)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(UINode, (Int, Int))]
lpAddY)
    lpAddY :: [(UINode, (Int, Int))]
lpAddY = [[(UINode, (Int, Int))]] -> [(UINode, (Int, Int))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((YBlocks -> [[(UINode, (Int, Int))]])
-> YBlockLines -> [[(UINode, (Int, Int))]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap YBlocks -> [[(UINode, (Int, Int))]]
forall {b} {a} {a}. (b, [[(a, a)]]) -> [[(a, (a, b))]]
addY (Bool -> YBlockLines
lp Bool
up))
    addY :: (b, [[(a, a)]]) -> [[(a, (a, b))]]
addY (b
y,[[(a, a)]]
ls) = ([(a, a)] -> [(a, (a, b))]) -> [[(a, a)]] -> [[(a, (a, b))]]
forall a b. (a -> b) -> [a] -> [b]
map (((a, a) -> (a, (a, b))) -> [(a, a)] -> [(a, (a, b))]
forall a b. (a -> b) -> [a] -> [b]
map (a, a) -> (a, (a, b))
ay) [[(a, a)]]
ls where ay :: (a, a) -> (a, (a, b))
ay (a
n,a
x) = (a
n,(a
x,b
y))
    lp :: Bool -> YBlockLines
lp Bool
up | Bool
up        = [[(Int, UINode)]]
-> [UINode]
-> Int
-> CGraph n e
-> [[UINode]]
-> [(UINode, UINode)]
-> Bool
-> YBlockLines
forall n e.
(NodeClass n, EdgeClass e, ShowGraph n e) =>
[[(Int, UINode)]]
-> [UINode]
-> Int
-> CGraph n e
-> [[UINode]]
-> [(UINode, UINode)]
-> Bool
-> YBlockLines
longestPath (((Int, UINode) -> [(Int, UINode)])
-> [(Int, UINode)] -> [[(Int, UINode)]]
forall a b. (a -> b) -> [a] -> [b]
map (Map UINode UINode -> (Int, UINode) -> [(Int, UINode)]
blockChildren Map UINode UINode
edgeMap)          [(Int, UINode)]
startNs)  [] Int
0 CGraph n e
graph [[UINode]]
layers [(UINode, UINode)]
edges Bool
up
          | Bool
otherwise = [[(Int, UINode)]]
-> [UINode]
-> Int
-> CGraph n e
-> [[UINode]]
-> [(UINode, UINode)]
-> Bool
-> YBlockLines
forall n e.
(NodeClass n, EdgeClass e, ShowGraph n e) =>
[[(Int, UINode)]]
-> [UINode]
-> Int
-> CGraph n e
-> [[UINode]]
-> [(UINode, UINode)]
-> Bool
-> YBlockLines
longestPath (((Int, UINode) -> [(Int, UINode)])
-> [(Int, UINode)] -> [[(Int, UINode)]]
forall a b. (a -> b) -> [a] -> [b]
map (Map UINode UINode -> (Int, UINode) -> [(Int, UINode)]
blockChildren Map UINode UINode
edgeMap) ([(Int, UINode)] -> [(Int, UINode)]
forall a. [a] -> [a]
reverse [(Int, UINode)]
startNs)) [] Int
0 CGraph n e
graph [[UINode]]
layers [(UINode, UINode)]
edges Bool
up
    --        globalYMin = minimum (map (snd . snd) lp)
    --        lpBackwards = longestPath (map (blockChildren edgeMap) startNsBackwards) [] 0 graph layers edges
    edgeMap :: Map UINode UINode
edgeMap = [(UINode, UINode)] -> Map UINode UINode
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(UINode, UINode)]
edges
    reverseBlocks :: Map UINode UINode
reverseBlocks = [(UINode, UINode)] -> Map UINode UINode
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (((UINode, UINode) -> (UINode, UINode))
-> [(UINode, UINode)] -> [(UINode, UINode)]
forall a b. (a -> b) -> [a] -> [b]
map (UINode, UINode) -> (UINode, UINode)
forall a b. (a, b) -> (b, a)
swap [(UINode, UINode)]
edges)
    _es :: [(UINode, UINode)]
_es = Map (UINode, UINode) [e] -> [(UINode, UINode)]
forall k a. Map k a -> [k]
Map.keys (CGraph n e -> Map (UINode, UINode) [e]
forall nl el. Graph nl el -> Map (UINode, UINode) el
Graph.edgeLabels CGraph n e
graph) [(UINode, UINode)] -> [(UINode, UINode)] -> [(UINode, UINode)]
forall a. Eq a => [a] -> [a] -> [a]
\\ [(UINode, UINode)]
edges

    startNs :: [(Int, UINode)]
startNs = ([(Int, UINode)] -> Maybe (Int, UINode))
-> [[(Int, UINode)]] -> [(Int, UINode)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([[UINode]]
-> [(UINode, UINode)] -> (Int, UINode) -> Maybe (Int, UINode)
nodeWithoutParent [[UINode]]
layers [(UINode, UINode)]
edges ((Int, UINode) -> Maybe (Int, UINode))
-> ([(Int, UINode)] -> (Int, UINode))
-> [(Int, UINode)]
-> Maybe (Int, UINode)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, UINode)] -> (Int, UINode)
forall a. HasCallStack => [a] -> a
last) ((Int -> [UINode] -> [(Int, UINode)])
-> [Int] -> [[UINode]] -> [[(Int, UINode)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> [UINode] -> [(Int, UINode)]
forall {t} {a}. t -> [a] -> [(t, a)]
f [Int
0 ..] [[UINode]]
layers)
    --        startNsBackwards = catMaybes $ map (nodeWithoutParent . head) (zipWith f [0..] layers)
    f :: t -> [a] -> [(t, a)]
f t
i [a]
ns = (a -> (t, a)) -> [a] -> [(t, a)]
forall a b. (a -> b) -> [a] -> [b]
map (t
i,) [a]
ns

    -- debugging with http://www.webgraphviz.com/
    graphviz :: (Show a1, Show a2) => String -> [(a1, a2)] -> String
    graphviz :: forall a1 a2. (Show a1, Show a2) => [Char] -> [(a1, a2)] -> [Char]
graphviz [Char]
col [(a1, a2)]
edges = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (((a1, a2) -> [Char]) -> [(a1, a2)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (a1, a2) -> [Char]
l [(a1, a2)]
edges) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
      where
        l :: (a1, a2) -> [Char]
l (a1
n0, a2
n1) = [Char]
"\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ a1 -> [Char]
forall a. Show a => a -> [Char]
show a1
n0 [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" -> " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ a2 -> [Char]
forall a. Show a => a -> [Char]
show a2
n1 [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
col

    ranksame :: [UINode] -> String
    ranksame :: [UINode] -> [Char]
ranksame [UINode]
ls = [Char]
"{ rank=same; " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
" " ((UINode -> [Char]) -> [UINode] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map UINode -> [Char]
forall a. Show a => a -> [Char]
show [UINode]
ls) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" }"

    blocks :: [[UINode]]
blocks = [[UINode]]
extr [[UINode]] -> [[UINode]] -> [[UINode]]
forall a. [a] -> [a] -> [a]
++ ((UINode -> [UINode]) -> [UINode] -> [[UINode]]
forall a b. (a -> b) -> [a] -> [b]
map (\UINode
x -> [UINode
x]) [UINode]
rest)
      where
        extr :: [[UINode]]
extr = Map UINode UINode -> [[UINode]]
extractBlocks Map UINode UINode
edgeMap
        rest :: [UINode]
rest = ([[UINode]] -> [UINode]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[UINode]]
layers [UINode] -> [UINode] -> [UINode]
forall a. Eq a => [a] -> [a] -> [a]
\\ [UINode]
allNodes) [UINode] -> [UINode] -> [UINode]
forall a. Eq a => [a] -> [a] -> [a]
\\ [[UINode]] -> [UINode]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[UINode]]
extr
        allNodes :: [UINode]
allNodes = Map UINode UINode -> [UINode]
forall k a. Map k a -> [k]
Map.keys Map UINode UINode
edgeMap [UINode] -> [UINode] -> [UINode]
forall a. [a] -> [a] -> [a]
++ Map UINode UINode -> [UINode]
forall k a. Map k a -> [a]
Map.elems Map UINode UINode
edgeMap

    extractBlocks :: Map UINode UINode -> [[UINode]]
    extractBlocks :: Map UINode UINode -> [[UINode]]
extractBlocks Map UINode UINode
m
      | Map UINode UINode -> Bool
forall k a. Map k a -> Bool
Map.null Map UINode UINode
m = []
      | Bool
otherwise = [[UINode]]
oneBlock [[UINode]] -> [[UINode]] -> [[UINode]]
forall a. [a] -> [a] -> [a]
++ Map UINode UINode -> [[UINode]]
extractBlocks Map UINode UINode
newEdgeMap -- extract one block and remove keys from the edge map
      where
        newEdgeMap :: Map UINode UINode
newEdgeMap =
          -- Debug.Trace.trace ("oneBlock " ++ show oneBlock) $
          (UINode -> Map UINode UINode -> Map UINode UINode)
-> Map UINode UINode -> [UINode] -> Map UINode UINode
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr UINode -> Map UINode UINode -> Map UINode UINode
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Map UINode UINode
m ([[UINode]] -> [UINode]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[UINode]]
oneBlock)
        oneBlock :: [[UINode]]
oneBlock =
          ([UINode] -> Bool) -> [[UINode]] -> [[UINode]]
forall a. (a -> Bool) -> [a] -> [a]
filter
            (Bool -> Bool
not (Bool -> Bool) -> ([UINode] -> Bool) -> [UINode] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UINode] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
            ( [[UINode]] -> [[UINode]]
forall {a}. [[a]] -> [[a]]
merge1 (((UINode, ([UINode], [UINode])) -> [UINode])
-> [(UINode, ([UINode], [UINode]))] -> [[UINode]]
forall a b. (a -> b) -> [a] -> [b]
map (([UINode], [UINode]) -> [UINode]
forall a b. (a, b) -> a
fst (([UINode], [UINode]) -> [UINode])
-> ((UINode, ([UINode], [UINode])) -> ([UINode], [UINode]))
-> (UINode, ([UINode], [UINode]))
-> [UINode]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UINode, ([UINode], [UINode])) -> ([UINode], [UINode])
forall a b. (a, b) -> b
snd) [(UINode, ([UINode], [UINode]))]
oneBlockWithVerts)
                [[UINode]] -> [[UINode]] -> [[UINode]]
forall a. [a] -> [a] -> [a]
++ [((UINode, ([UINode], [UINode])) -> UINode)
-> [(UINode, ([UINode], [UINode]))] -> [UINode]
forall a b. (a -> b) -> [a] -> [b]
map (UINode, ([UINode], [UINode])) -> UINode
forall a b. (a, b) -> a
fst [(UINode, ([UINode], [UINode]))]
oneBlockWithVerts]
                [[UINode]] -> [[UINode]] -> [[UINode]]
forall a. [a] -> [a] -> [a]
++ [[UINode]] -> [[UINode]]
forall {a}. [[a]] -> [[a]]
merge1 (((UINode, ([UINode], [UINode])) -> [UINode])
-> [(UINode, ([UINode], [UINode]))] -> [[UINode]]
forall a b. (a -> b) -> [a] -> [b]
map (([UINode], [UINode]) -> [UINode]
forall a b. (a, b) -> b
snd (([UINode], [UINode]) -> [UINode])
-> ((UINode, ([UINode], [UINode])) -> ([UINode], [UINode]))
-> (UINode, ([UINode], [UINode]))
-> [UINode]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UINode, ([UINode], [UINode])) -> ([UINode], [UINode])
forall a b. (a, b) -> b
snd) [(UINode, ([UINode], [UINode]))]
oneBlockWithVerts)
            )
        merge1 :: [[a]] -> [[a]]
merge1 [] = []
        merge1 [[a]]
xs = (([a] -> a) -> [[a]] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [a] -> a
forall a. Int -> [a] -> a
myHead Int
65) [[a]]
fil) [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: ([[a]] -> [[a]]
merge1 (([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> [a]
forall a. [a] -> [a]
myTail [[a]]
fil))
          where
            fil :: [[a]]
fil = ([a] -> Bool) -> [[a]] -> [[a]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[a]]
xs
        oneBlockWithVerts :: [(UINode, ([UINode], [UINode]))]
oneBlockWithVerts =
          [(UINode, ([UINode], [UINode]))]
-> [(UINode, ([UINode], [UINode]))]
forall a. [a] -> [a]
reverse (UINode -> [(UINode, ([UINode], [UINode]))]
blockNodesDown (Int -> [UINode] -> UINode
forall a. Int -> [a] -> a
myHead Int
66 [UINode]
ks))
            [(UINode, ([UINode], [UINode]))]
-> [(UINode, ([UINode], [UINode]))]
-> [(UINode, ([UINode], [UINode]))]
forall a. [a] -> [a] -> [a]
++ [(UINode, ([UINode], [UINode]))]
-> [(UINode, ([UINode], [UINode]))]
forall a. [a] -> [a]
myTail (UINode -> [(UINode, ([UINode], [UINode]))]
blockNodesUp (Int -> [UINode] -> UINode
forall a. Int -> [a] -> a
myHead Int
67 [UINode]
ks))

        ks :: [UINode]
ks = Map UINode UINode -> [UINode]
forall k a. Map k a -> [k]
Map.keys Map UINode UINode
m [UINode] -> [UINode] -> [UINode]
forall a. [a] -> [a] -> [a]
++ Map UINode UINode -> [UINode]
forall k a. Map k a -> [a]
Map.elems Map UINode UINode
m

        blockNodesDown :: UINode -> [(UINode, ([UINode], [UINode]))]
        blockNodesDown :: UINode -> [(UINode, ([UINode], [UINode]))]
blockNodesDown UINode
n
          | Maybe UINode -> Bool
forall a. Maybe a -> Bool
isJust Maybe UINode
lu = (UINode
n, ([UINode]
vertup, [UINode]
vertdown)) (UINode, ([UINode], [UINode]))
-> [(UINode, ([UINode], [UINode]))]
-> [(UINode, ([UINode], [UINode]))]
forall a. a -> [a] -> [a]
: (UINode -> [(UINode, ([UINode], [UINode]))]
blockNodesDown (Int -> Maybe UINode -> UINode
forall a. Int -> Maybe a -> a
myFromJust Int
513 Maybe UINode
lu))
          | Bool
otherwise = [(UINode
n, ([UINode]
vertup, [UINode]
vertdown))]
          where
            lu :: Maybe UINode
lu = UINode -> Map UINode UINode -> Maybe UINode
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n Map UINode UINode
edgeMap
            vertup :: [UINode]
vertup = Vector UINode -> [UINode]
forall a. Unbox a => Vector a -> [a]
VU.toList (CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
parentsVertical CGraph n e
graph UINode
n)
            vertdown :: [UINode]
vertdown = Vector UINode -> [UINode]
forall a. Unbox a => Vector a -> [a]
VU.toList (CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
childrenVertical CGraph n e
graph UINode
n)

        blockNodesUp :: UINode -> [(UINode, ([UINode], [UINode]))]
        blockNodesUp :: UINode -> [(UINode, ([UINode], [UINode]))]
blockNodesUp UINode
n
          | Maybe UINode -> Bool
forall a. Maybe a -> Bool
isJust Maybe UINode
lu = (UINode
n, ([UINode]
vertup, [UINode]
vertdown)) (UINode, ([UINode], [UINode]))
-> [(UINode, ([UINode], [UINode]))]
-> [(UINode, ([UINode], [UINode]))]
forall a. a -> [a] -> [a]
: (UINode -> [(UINode, ([UINode], [UINode]))]
blockNodesUp (Int -> Maybe UINode -> UINode
forall a. Int -> Maybe a -> a
myFromJust Int
513 Maybe UINode
lu))
          | Bool
otherwise = [(UINode
n, ([UINode]
vertup, [UINode]
vertdown))]
          where
            lu :: Maybe UINode
lu = UINode -> Map UINode UINode -> Maybe UINode
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n Map UINode UINode
reverseBlocks
            vertup :: [UINode]
vertup = Vector UINode -> [UINode]
forall a. Unbox a => Vector a -> [a]
VU.toList (CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
parentsVertical CGraph n e
graph UINode
n)
            vertdown :: [UINode]
vertdown = Vector UINode -> [UINode]
forall a. Unbox a => Vector a -> [a]
VU.toList (CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
childrenVertical CGraph n e
graph UINode
n)

    moveBlocks :: Map UINode (Int, Int) -> Map UINode (Int, Int)
moveBlocks Map UINode (Int, Int)
m =
      -- Debug.Trace.trace ("blocks" ++ show blocks ++ "\nm\n" ++ show (foldr moveToShortestConnection m (reverse blocks)))
      ([UINode] -> Map UINode (Int, Int) -> Map UINode (Int, Int))
-> Map UINode (Int, Int) -> [[UINode]] -> Map UINode (Int, Int)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [UINode] -> Map UINode (Int, Int) -> Map UINode (Int, Int)
moveToShortestConnection Map UINode (Int, Int)
m ([[UINode]] -> [[UINode]]
forall a. [a] -> [a]
reverse [[UINode]]
blocks)
    moveBlocksAgain :: Map UINode (X, Y) -> Map UINode (X, Y)
    moveBlocksAgain :: Map UINode (Int, Int) -> Map UINode (Int, Int)
moveBlocksAgain Map UINode (Int, Int)
m =
      -- Debug.Trace.trace ("blocks" ++ show blocks ++ "\nm\n" ++ show (foldr moveToShortestConnection m (reverse blocks)))
      ([UINode] -> Map UINode (Int, Int) -> Map UINode (Int, Int))
-> Map UINode (Int, Int) -> [[UINode]] -> Map UINode (Int, Int)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [UINode] -> Map UINode (Int, Int) -> Map UINode (Int, Int)
moveToShortestConnection (Map UINode (Int, Int) -> Map UINode (Int, Int)
moveBlocks Map UINode (Int, Int)
m) ([[UINode]] -> [[UINode]]
forall a. [a] -> [a]
reverse [[UINode]]
blocks)

    moveToShortestConnection :: [UINode] -> Map UINode (Int, Int) -> Map UINode (Int, Int)
moveToShortestConnection [UINode]
block Map UINode (Int, Int)
m
      | [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
bs = Map UINode (Int, Int)
m
      | Bool
otherwise = -- Debug.Trace.trace ("\nblock " ++ show block ++
      --       "\nbounds " ++ show bounds ++
      --       "\nnewY " ++ show newY ++
      --       "\nadjustY block newY m\n" ++ show (adjustY block newY m))
        [UINode] -> Int -> Map UINode (Int, Int) -> Map UINode (Int, Int)
forall {a} {t :: * -> *} {b} {a}.
(Ord a, Foldable t) =>
t a -> b -> Map a (a, b) -> Map a (a, b)
adjustY [UINode]
block Int
newY Map UINode (Int, Int)
m
      where
        -- newY = ( (fromJust (fst (head bounds))) + (fromJust (snd (head bounds))) ) `div` 2
        bs :: [Int]
bs = ((Maybe Int, Maybe Int) -> Maybe Int)
-> [(Maybe Int, Maybe Int)] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Maybe Int, Maybe Int) -> Maybe Int
forall a b. (a, b) -> a
fst [(Maybe Int, Maybe Int)]
bounds
        newY :: Int
newY = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 -- TODO look at block connections
        bounds :: [(Maybe Int, Maybe Int)]
bounds = (UINode -> (Maybe Int, Maybe Int))
-> [UINode] -> [(Maybe Int, Maybe Int)]
forall a b. (a -> b) -> [a] -> [b]
map UINode -> (Maybe Int, Maybe Int)
blockBound [UINode]
block
        blockBound :: UINode -> (Maybe Int, Maybe Int)
blockBound UINode
b =
          -- Debug.Trace.trace ("blockBound " ++ show (b,n,(yTop,yBottom),m))
          (Maybe Int
yTop, Maybe Int
yBottom)
          where
            -- yTop = fmap snd (maybe (Just (0,globalYMin)) (\node -> Map.lookup node m) n)
            yTop :: Maybe Int
yTop = ((Int, Int) -> Int) -> Maybe (Int, Int) -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Int) -> Int
forall a b. (a, b) -> b
snd (Maybe (Int, Int)
-> (UINode -> Maybe (Int, Int)) -> Maybe UINode -> Maybe (Int, Int)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe (Int, Int)
forall a. Maybe a
Nothing (UINode -> Map UINode (Int, Int) -> Maybe (Int, Int)
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map UINode (Int, Int)
m) Maybe UINode
n)
            yBottom :: Maybe Int
yBottom = ((Int, Int) -> Int) -> Maybe (Int, Int) -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Int) -> Int
forall a b. (a, b) -> b
snd (UINode -> Map UINode (Int, Int) -> Maybe (Int, Int)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
b Map UINode (Int, Int)
m)
            n :: Maybe UINode
n = UINode -> Map UINode UINode -> Maybe UINode
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
b Map UINode UINode
nextInLayerMap

    nextInLayerMap :: Map UINode UINode
nextInLayerMap = ([UINode] -> Map UINode UINode -> Map UINode UINode)
-> Map UINode UINode -> [[UINode]] -> Map UINode UINode
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [UINode] -> Map UINode UINode -> Map UINode UINode
forall {k}. Ord k => [k] -> Map k k -> Map k k
addLayerEdges Map UINode UINode
forall k a. Map k a
Map.empty [[UINode]]
layers
      where
        addLayerEdges :: [k] -> Map k k -> Map k k
addLayerEdges [k]
layer Map k k
m = ((k, k) -> Map k k -> Map k k) -> Map k k -> [(k, k)] -> Map k k
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (k, k) -> Map k k -> Map k k
forall {k} {a}. Ord k => (a, k) -> Map k a -> Map k a
addEdge Map k k
m ([k] -> [(k, k)]
forall a. [a] -> [(a, a)]
tuples [k]
layer)
        addEdge :: (a, k) -> Map k a -> Map k a
addEdge (a
from, k
to) Map k a
m = k -> a -> Map k a -> Map k a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
to a
from Map k a
m

    adjustY :: t a -> b -> Map a (a, b) -> Map a (a, b)
adjustY t a
block b
newY Map a (a, b)
m = (a -> Map a (a, b) -> Map a (a, b))
-> Map a (a, b) -> t a -> Map a (a, b)
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> Map a (a, b) -> Map a (a, b)
adj Map a (a, b)
m t a
block
      where
        adj :: a -> Map a (a, b) -> Map a (a, b)
adj a
b Map a (a, b)
mp = ((a, b) -> (a, b)) -> a -> Map a (a, b) -> Map a (a, b)
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (\(a
x, b
_y) -> (a
x, b
newY)) a
b Map a (a, 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 :: forall n e.
(NodeClass n, EdgeClass e, ShowGraph n e) =>
[[(Int, UINode)]]
-> [UINode]
-> Int
-> CGraph n e
-> [[UINode]]
-> [(UINode, UINode)]
-> Bool
-> YBlockLines
longestPath [] [UINode]
_ Int
_ CGraph n e
_ [[UINode]]
_ [(UINode, UINode)]
_ Bool
_ =
  -- Debug.Trace.trace "finish"
  []
longestPath [[(Int, UINode)]]
blockNodes [UINode]
used Int
i CGraph n e
graph [[UINode]]
layers [(UINode, UINode)]
edges Bool
up
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
100 = [] -- Debug.Trace.trace ("reverseBlocks " ++ show (edges, reverseBlocks)) $
  | Bool
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
--                        ) $
    YBlocks
newLayer YBlocks -> YBlockLines -> YBlockLines
forall a. a -> [a] -> [a]
: ([[(Int, UINode)]]
-> [UINode]
-> Int
-> CGraph n e
-> [[UINode]]
-> [(UINode, UINode)]
-> Bool
-> YBlockLines
forall n e.
(NodeClass n, EdgeClass e, ShowGraph n e) =>
[[(Int, UINode)]]
-> [UINode]
-> Int
-> CGraph n e
-> [[UINode]]
-> [(UINode, UINode)]
-> Bool
-> YBlockLines
longestPath [[(Int, UINode)]]
blocksWithOnlyUsedParents [UINode]
newUsed (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) CGraph n e
graph [[UINode]]
layers [(UINode, UINode)]
edges Bool
up)
  where
    newLayer :: YBlocks
newLayer = (-Int
i, ([(Int, UINode)] -> [(UINode, Int)])
-> [[(Int, UINode)]] -> [[(UINode, Int)]]
forall a b. (a -> b) -> [a] -> [b]
map [(Int, UINode)] -> [(UINode, Int)]
oneLayer [[(Int, UINode)]]
blockNodes)

    oneLayer :: [(X, UINode)] -> [(UINode, X)]
    oneLayer :: [(Int, UINode)] -> [(UINode, Int)]
oneLayer [(Int, UINode)]
ns = ((Int, UINode) -> (UINode, Int))
-> [(Int, UINode)] -> [(UINode, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
x, UINode
n) -> (UINode
n, Int
x)) [(Int, UINode)]
ns

    nextPossibleLayerNodes :: [(Int, UINode)]
nextPossibleLayerNodes | Bool
up = ((Int, UINode) -> Maybe (Int, UINode))
-> [(Int, UINode)] -> [(Int, UINode)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Int, UINode) -> Maybe (Int, UINode)
layerChild ([[(Int, UINode)]] -> [(Int, UINode)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Int, UINode)]]
blockNodes)
                           | Bool
otherwise = ((Int, UINode) -> Maybe (Int, UINode))
-> [(Int, UINode)] -> [(Int, UINode)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Int, UINode) -> Maybe (Int, UINode)
forall {a}. (a, UINode) -> Maybe (a, UINode)
layerParent ([[(Int, UINode)]] -> [(Int, UINode)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Int, UINode)]]
blockNodes)
    --                nextPossibleLayerNodesBackwards = catMaybes (map layerParent (concat blockNodes))

    nextLayerRoots :: [(Int, UINode)]
nextLayerRoots = [(Int, UINode)] -> [(Int, UINode)]
myNub2 (((Int, UINode) -> (Int, UINode))
-> [(Int, UINode)] -> [(Int, UINode)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, UINode) -> (Int, UINode)
findRoot [(Int, UINode)]
nextPossibleLayerNodes)
    --                nextLayerRootsBackwards = myNub2 (map findRoot nextPossibleLayerNodesBackwards)

    findRoot :: (X, UINode) -> (X, UINode)
    findRoot :: (Int, UINode) -> (Int, UINode)
findRoot (Int
x, UINode
n)
      | Maybe UINode -> Bool
forall a. Maybe a -> Bool
isJust Maybe UINode
lu Bool -> Bool -> Bool
&& Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 -- Debug.Trace.trace ("findRoot " ++ show (x,n)) $
        =
        (Int, UINode) -> (Int, UINode)
findRoot (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int -> Maybe UINode -> UINode
forall a. Int -> Maybe a -> a
myFromJust Int
515 Maybe UINode
lu)
      | Bool
otherwise = (Int
x, UINode
n)
      where
        lu :: Maybe UINode
lu = UINode -> Map UINode UINode -> Maybe UINode
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n Map UINode UINode
reverseBlocks

    getBoxId :: UINode -> Maybe UINode
getBoxId UINode
n = Maybe UINode
-> (LayerFeatures -> Maybe UINode)
-> Maybe LayerFeatures
-> Maybe UINode
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe UINode
forall a. Maybe a
Nothing LayerFeatures -> Maybe UINode
Common.boxId Maybe LayerFeatures
nest
      where nest :: Maybe LayerFeatures
nest = Maybe LayerFeatures
-> (n -> Maybe LayerFeatures) -> Maybe n -> Maybe LayerFeatures
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe LayerFeatures
forall a. Maybe a
Nothing n -> Maybe LayerFeatures
forall n. NodeClass n => n -> Maybe LayerFeatures
Common.nestingFeatures Maybe n
lu
            lu :: Maybe n
lu = UINode -> CGraph n e -> Maybe n
forall nl el.
(Show nl, EdgeAttribute el) =>
UINode -> Graph nl el -> Maybe nl
Graph.lookupNode UINode
n CGraph n e
graph

    reverseBlocks :: Map UINode UINode
reverseBlocks = [(UINode, UINode)] -> Map UINode UINode
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (((UINode, UINode) -> (UINode, UINode))
-> [(UINode, UINode)] -> [(UINode, UINode)]
forall a b. (a -> b) -> [a] -> [b]
map (UINode, UINode) -> (UINode, UINode)
forall a b. (a, b) -> (b, a)
swap [(UINode, UINode)]
edges)

    layerConnections :: Map UINode UINode
    layerConnections :: Map UINode UINode
layerConnections =        [(UINode, UINode)] -> Map UINode UINode
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(UINode, UINode)] -> Map UINode UINode)
-> [(UINode, UINode)] -> Map UINode UINode
forall a b. (a -> b) -> a -> b
$ ([UINode] -> [(UINode, UINode)])
-> [[UINode]] -> [(UINode, UINode)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [UINode] -> [(UINode, UINode)]
forall a. [a] -> [(a, a)]
tuples [[UINode]]
layers
    reverseLayerConnections :: Map UINode UINode
reverseLayerConnections = [(UINode, UINode)] -> Map UINode UINode
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(UINode, UINode)] -> Map UINode UINode)
-> [(UINode, UINode)] -> Map UINode UINode
forall a b. (a -> b) -> a -> b
$ ([UINode] -> [(UINode, UINode)])
-> [[UINode]] -> [(UINode, UINode)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([UINode] -> [(UINode, UINode)]
forall a. [a] -> [(a, a)]
tuples ([UINode] -> [(UINode, UINode)])
-> ([UINode] -> [UINode]) -> [UINode] -> [(UINode, UINode)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UINode] -> [UINode]
forall a. [a] -> [a]
reverse) [[UINode]]
layers

    bcs :: [[(X, UINode)]]
    bcs :: [[(Int, UINode)]]
bcs = -- Debug.Trace.trace ("bcs " ++ show (nextLayerRoots, map (blockChildren edgeMap) nextLayerRoots)) $
          ((Int, UINode) -> [(Int, UINode)])
-> [(Int, UINode)] -> [[(Int, UINode)]]
forall a b. (a -> b) -> [a] -> [b]
map (Map UINode UINode -> (Int, UINode) -> [(Int, UINode)]
blockChildren Map UINode UINode
edgeMap) [(Int, UINode)]
nextLayerRoots
    edgeMap :: Map UINode UINode
edgeMap = [(UINode, UINode)] -> Map UINode UINode
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(UINode, UINode)]
edges

    blocksWithOnlyUsedParents :: [[(Int, UINode)]]
blocksWithOnlyUsedParents | Bool
up        = [[(Int, UINode)]] -> [[(Int, UINode)]]
forall a. Ord a => [a] -> [a]
rmdups ([[(Int, UINode)]] -> [[(Int, UINode)]])
-> [[(Int, UINode)]] -> [[(Int, UINode)]]
forall a b. (a -> b) -> a -> b
$ ([(Int, UINode)] -> Bool) -> [[(Int, UINode)]] -> [[(Int, UINode)]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Map UINode UINode -> [(Int, UINode)] -> Bool
noParentOrUsed Map UINode UINode
layerConnections) [[(Int, UINode)]]
bcs
                              | Bool
otherwise = [[(Int, UINode)]] -> [[(Int, UINode)]]
forall a. Ord a => [a] -> [a]
rmdups ([[(Int, UINode)]] -> [[(Int, UINode)]])
-> [[(Int, UINode)]] -> [[(Int, UINode)]]
forall a b. (a -> b) -> a -> b
$ ([(Int, UINode)] -> Bool) -> [[(Int, UINode)]] -> [[(Int, UINode)]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Map UINode UINode -> [(Int, UINode)] -> Bool
noParentOrUsed Map UINode UINode
reverseLayerConnections) [[(Int, UINode)]]
bcs
 
    layerChild :: (Int, UINode) -> Maybe (Int, UINode)
layerChild (Int
x, UINode
n) = Maybe (Int, UINode)
-> (UINode -> Maybe (Int, UINode))
-> Maybe UINode
-> Maybe (Int, UINode)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe (Int, UINode)
forall a. Maybe a
Nothing (\UINode
node -> (Int, UINode) -> Maybe (Int, UINode)
forall a. a -> Maybe a
Just (Int
x, UINode
node)) (UINode -> Map UINode UINode -> Maybe UINode
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n Map UINode UINode
reverseLayerConnections)
    layerParent :: (a, UINode) -> Maybe (a, UINode)
layerParent (a
x,UINode
n) = Maybe (a, UINode)
-> (UINode -> Maybe (a, UINode))
-> Maybe UINode
-> Maybe (a, UINode)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe (a, UINode)
forall a. Maybe a
Nothing (\UINode
node -> (a, UINode) -> Maybe (a, UINode)
forall a. a -> Maybe a
Just (a
x,UINode
node)) (UINode -> Map UINode UINode -> Maybe UINode
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n Map UINode UINode
layerConnections)
    newUsed :: [UINode]
newUsed = [UINode]
used [UINode] -> [UINode] -> [UINode]
forall a. [a] -> [a] -> [a]
++ [UINode]
blns
    blns :: [UINode]
blns = ((Int, UINode) -> UINode) -> [(Int, UINode)] -> [UINode]
forall a b. (a -> b) -> [a] -> [b]
map (Int, UINode) -> UINode
forall a b. (a, b) -> b
snd ([[(Int, UINode)]] -> [(Int, UINode)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Int, UINode)]]
blockNodes)
    noParentOrUsed :: Map UINode UINode -> [(X, UINode)] -> Bool
    noParentOrUsed :: Map UINode UINode -> [(Int, UINode)] -> Bool
noParentOrUsed Map UINode UINode
layerCs [(Int, UINode)]
block =
      if ((Int, UINode) -> Bool) -> [(Int, UINode)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Map UINode UINode -> (Int, UINode) -> Bool
noParOrUsed Map UINode UINode
layerCs) [(Int, UINode)]
block Bool -> Bool -> Bool
&& Bool -> Bool
not ([(Int, UINode)] -> Bool
sameBoxId [(Int, UINode)]
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)
            --                  ) $
           ((Int, UINode) -> Bool) -> [(Int, UINode)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Map UINode UINode -> (Int, UINode) -> Bool
noParOrUsed Map UINode UINode
layerCs) [(Int, UINode)]
block -- && (sameBoxId block || (not hasBlockWithSameBoxId && not (sameBoxId block)))
      else ((Int, UINode) -> Bool) -> [(Int, UINode)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Map UINode UINode -> (Int, UINode) -> Bool
noParOrUsed Map UINode UINode
layerCs) [(Int, UINode)]
block
        where hasBlockWithSameBoxId :: Bool
hasBlockWithSameBoxId = Bool -> Bool
not ([[(Int, UINode)]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (([(Int, UINode)] -> Bool) -> [[(Int, UINode)]] -> [[(Int, UINode)]]
forall a. (a -> Bool) -> [a] -> [a]
filter [(Int, UINode)] -> Bool
f [[(Int, UINode)]]
blocksWithSameBoxId)) --(blocksWithSameBoxId \\ block))
              f :: [(Int, UINode)] -> Bool
f [(Int, UINode)]
bs = Bool -> Bool
not (((Int, UINode) -> UINode
forall a b. (a, b) -> b
snd ([(Int, UINode)] -> (Int, UINode)
forall a. HasCallStack => [a] -> a
head [(Int, UINode)]
block)) UINode -> [UINode] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (((Int, UINode) -> UINode) -> [(Int, UINode)] -> [UINode]
forall a b. (a -> b) -> [a] -> [b]
map (Int, UINode) -> UINode
forall a b. (a, b) -> b
snd [(Int, UINode)]
bs))
                  
              blocksWithSameBoxId :: [[(X, UINode)]]
              blocksWithSameBoxId :: [[(Int, UINode)]]
blocksWithSameBoxId = ([(Int, UINode)] -> Bool) -> [[(Int, UINode)]] -> [[(Int, UINode)]]
forall a. (a -> Bool) -> [a] -> [a]
filter [(Int, UINode)] -> Bool
sameBoxId2 [[(Int, UINode)]]
bcs
              sameBoxId2 :: [(Int, UINode)] -> Bool
sameBoxId2 [(Int, UINode)]
b0 | Maybe UINode -> Bool
forall a. Maybe a -> Bool
isNothing Maybe UINode
lu = Bool
True
                            | Bool
otherwise = UINode -> Maybe UINode
getBoxId ((Int, UINode) -> UINode
forall a b. (a, b) -> b
snd ([(Int, UINode)] -> (Int, UINode)
forall a. HasCallStack => [a] -> a
head [(Int, UINode)]
b0)) Maybe UINode -> Maybe UINode -> Bool
forall a. Eq a => a -> a -> Bool
== UINode -> Maybe UINode
getBoxId (Maybe UINode -> UINode
forall a. HasCallStack => Maybe a -> a
fromJust Maybe UINode
lu)
                where lu :: Maybe UINode
lu = UINode -> Map UINode UINode -> Maybe UINode
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ((Int, UINode) -> UINode
forall a b. (a, b) -> b
snd ([(Int, UINode)] -> (Int, UINode)
forall a. HasCallStack => [a] -> a
head [(Int, UINode)]
block)) Map UINode UINode
layerCs
              block2 :: [(Int, UINode)]
block2 = [[(Int, UINode)]] -> [(Int, UINode)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Int, UINode)]]
blockNodes
              sameBoxId :: [(Int, UINode)] -> Bool
sameBoxId [(Int, UINode)]
b0 | Maybe UINode -> Bool
forall a. Maybe a -> Bool
isNothing Maybe UINode
lu = Bool
True
                           | Bool
otherwise = UINode -> Maybe UINode
getBoxId ((Int, UINode) -> UINode
forall a b. (a, b) -> b
snd ([(Int, UINode)] -> (Int, UINode)
forall a. HasCallStack => [a] -> a
head [(Int, UINode)]
b0)) Maybe UINode -> Maybe UINode -> Bool
forall a. Eq a => a -> a -> Bool
== UINode -> Maybe UINode
getBoxId (Maybe UINode -> UINode
forall a. HasCallStack => Maybe a -> a
fromJust Maybe UINode
lu)
                where lu :: Maybe UINode
lu = UINode -> Map UINode UINode -> Maybe UINode
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ((Int, UINode) -> UINode
forall a b. (a, b) -> b
snd ([(Int, UINode)] -> (Int, UINode)
forall a. HasCallStack => [a] -> a
head [(Int, UINode)]
b0)) Map UINode UINode
layerCs
--              curBoxId = getBoxId (snd (head block))
    noParOrUsed :: Map UINode UINode -> (Int, UINode) -> Bool
noParOrUsed Map UINode UINode
layerCs (Int
_, UINode
n) =
      -- Debug.Trace.trace ("noParOrUsed "++ show (n,lu)) $
      (Maybe UINode -> Bool
forall a. Maybe a -> Bool
isNothing Maybe UINode
lu Bool -> Bool -> Bool
|| (Maybe UINode -> Bool
forall a. Maybe a -> Bool
isJust Maybe UINode
lu Bool -> Bool -> Bool
&& UINode -> [UINode] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (Int -> Maybe UINode -> UINode
forall a. Int -> Maybe a -> a
myFromJust Int
514 Maybe UINode
lu) [UINode]
newUsed))
      where
        lu :: Maybe UINode
lu = UINode -> Map UINode UINode -> Maybe UINode
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n Map UINode UINode
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 :: forall n e.
(NodeClass n, EdgeClass e, ShowGraph n e) =>
CGraph n e -> (CGraph n e, [[UINode]])
longestPathAlgo CGraph n e
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)
                    (CGraph n e
g, [[UINode]] -> [[UINode]]
moveFinalNodesLeftToVert (([UINode] -> [UINode]) -> [[UINode]] -> [[UINode]]
forall a b. (a -> b) -> [a] -> [b]
map [UINode] -> [UINode]
forall a. Ord a => [a] -> [a]
rmdups [[UINode]]
newLayers))
  where
    moveFinalNodesLeftToVert :: [[UINode]] -> [[UINode]]
    moveFinalNodesLeftToVert :: [[UINode]] -> [[UINode]]
moveFinalNodesLeftToVert [[UINode]]
ls | [[UINode]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[UINode]]
ls = [[UINode]]
ls -- Debug.Trace.trace ("nodesToMove "++ show (nodesToMove, nodesAndPrevious)) $
                                | Bool
otherwise = ((Int -> [[UINode]] -> [UINode]
forall a. Int -> [a] -> a
myHead Int
71 [[UINode]]
ls) [UINode] -> [UINode] -> [UINode]
forall a. Eq a => [a] -> [a] -> [a]
\\ [UINode]
nodesToMove) [UINode] -> [[UINode]] -> [[UINode]]
forall a. a -> [a] -> [a]
: (((UINode, UINode) -> [[UINode]] -> [[UINode]])
-> [[UINode]] -> [(UINode, UINode)] -> [[UINode]]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (UINode, UINode) -> [[UINode]] -> [[UINode]]
forall {a}. Eq a => (a, a) -> [[a]] -> [[a]]
insert ([[UINode]] -> [[UINode]]
forall a. HasCallStack => [a] -> [a]
tail [[UINode]]
ls) [(UINode, UINode)]
nodesAndPrevious)
      where nodesToMove :: [UINode]
nodesToMove | ([[UINode]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[UINode]]
ls) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 = []
                        | Bool
otherwise = (UINode -> Bool) -> [UINode] -> [UINode]
forall a. (a -> Bool) -> [a] -> [a]
filter ([UINode] -> Bool
notEl ([UINode] -> Bool) -> (UINode -> [UINode]) -> UINode -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector UINode -> [UINode]
forall a. Unbox a => Vector a -> [a]
VU.toList (Vector UINode -> [UINode])
-> (UINode -> Vector UINode) -> UINode -> [UINode]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
parentsNoVertical CGraph n e
g)) (Int -> [[UINode]] -> [UINode]
forall a. Int -> [a] -> a
myHead Int
72 [[UINode]]
ls)
            notEl :: [UINode] -> Bool
notEl [UINode
n] = Bool -> Bool
not (UINode -> [UINode] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem UINode
n (Int -> [[UINode]] -> [UINode]
forall a. Int -> [a] -> a
myHead Int
73 ([[UINode]] -> [[UINode]]
forall a. HasCallStack => [a] -> [a]
tail [[UINode]]
ls)))
            notEl [UINode]
_ = Bool
False
            insert :: (a, a) -> [[a]] -> [[a]]
insert (a
n,a
p) [[a]]
lays | [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
fpl  = [[a]]
lays -- Debug.Trace.trace ("insert "++ show lays ++"\n\n"++ show (add lays (find p lays) n)) $
                              | Bool
otherwise = [[a]] -> Int -> a -> [[a]]
forall {a}. [[a]] -> Int -> a -> [[a]]
add [[a]]
lays ([Int] -> Int
forall a. HasCallStack => [a] -> a
head [Int]
fpl) a
n
              where fpl :: [Int]
fpl = a -> [[a]] -> [Int]
forall {a} {t :: * -> *} {a}.
(Num a, Enum a, Foldable t, Eq a) =>
a -> [t a] -> [a]
find a
p [[a]]
lays
            nodesAndPrevious :: [(UINode, UINode)]
nodesAndPrevious = [UINode] -> [UINode] -> [(UINode, UINode)]
forall a b. [a] -> [b] -> [(a, b)]
zip [UINode]
nodesToMove ((UINode -> UINode) -> [UINode] -> [UINode]
forall a b. (a -> b) -> [a] -> [b]
map (Vector UINode -> UINode
forall {a}. Unbox a => Vector a -> a
vHead (Vector UINode -> UINode)
-> (UINode -> Vector UINode) -> UINode -> UINode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
parentsNoVertical CGraph n e
g)) [UINode]
nodesToMove)
            add :: [[a]] -> Int -> a -> [[a]]
add [[a]]
list Int
pos a
n = (Int -> [[a]] -> [[a]]
forall a. Int -> [a] -> [a]
take (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [[a]]
list) [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++ (([[a]]
list [[a]] -> Int -> [a]
forall a. HasCallStack => [a] -> Int -> a
!! (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
n]) [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: (Int -> [[a]] -> [[a]]
forall a. Int -> [a] -> [a]
drop Int
pos [[a]]
list)
            find :: a -> [t a] -> [a]
find a
p [t a]
l = [ (a, t a) -> a
forall a b. (a, b) -> a
fst (a, t a)
il | (a, t a)
il <- ([a] -> [t a] -> [(a, t a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a
0..] [t a]
l), a -> t a -> Bool
forall a. Eq a => a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem a
p ((a, t a) -> t a
forall a b. (a, b) -> b
snd (a, t a)
il) ]

    startNode :: [UINode]
startNode = [UINode] -> [UINode]
forall a. Ord a => [a] -> [a]
rmdups ([UINode] -> [UINode]) -> [UINode] -> [UINode]
forall a b. (a -> b) -> a -> b
$ Vector UINode -> [UINode]
forall a. Unbox a => Vector a -> [a]
VU.toList (CGraph n e -> Vector UINode
forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e -> Vector UINode
nodesWithoutChildrenVertLayer CGraph n e
g)
    newLayers :: [[UINode]]
newLayers = [UINode] -> [([UINode], [UINode], Bool)] -> [UINode] -> [[UINode]]
layersrec [UINode]
startNode [([UINode], [UINode], Bool)]
fil [] -- (newActiveSubgraphs startNode)
    fil :: [([UINode], [UINode], Bool)]
fil = (([UINode], [UINode], Bool) -> Bool)
-> [([UINode], [UINode], Bool)] -> [([UINode], [UINode], Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (([UINode], [UINode], Bool) -> Bool)
-> ([UINode], [UINode], Bool)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UINode] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([UINode] -> Bool)
-> (([UINode], [UINode], Bool) -> [UINode])
-> ([UINode], [UINode], Bool)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([UINode], [UINode], Bool) -> [UINode]
forall {a} {b} {c}. (a, b, c) -> b
sel2) (CGraph n e -> [([UINode], [UINode], Bool)]
forall {e} {n}.
EdgeClass e =>
Graph n [e] -> [([UINode], [UINode], Bool)]
verticalLayers CGraph n e
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 :: [UINode] -> [([UINode], [UINode], Bool)] -> [UINode] -> [[UINode]]
layersrec [UINode]
curLayer [([UINode], [UINode], Bool)]
vertLayers [UINode]
usedNodes -- activeSubgraphLayers
      | [UINode] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UINode]
curLayer = -- Debug.Trace.trace "\n§§1 "
                        []
      | ([UINode] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [UINode]
usedNodes) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ([UINode] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [UINode]
curLayer) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> ([Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (CGraph n e -> [Int]
forall {a} {el}. Graph a el -> [Int]
nodes CGraph n e
g)) =
                        -- Debug.Trace.trace ("\n§§2 "++ show (curLayer,length usedNodes,usedNodes,length curLayer,length (nodes g)))
                        [[UINode]
curLayer] -- should not happen
      | Bool
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)
                    [UINode]
curLayer [UINode] -> [[UINode]] -> [[UINode]]
forall a. a -> [a] -> [a]
: ([UINode] -> [([UINode], [UINode], Bool)] -> [UINode] -> [[UINode]]
layersrec [UINode]
newCurLayerOrVert [([UINode], [UINode], Bool)]
fil ([UINode]
usedNodes [UINode] -> [UINode] -> [UINode]
forall a. [a] -> [a] -> [a]
++ [UINode]
curLayer)) -- ((map myTail activeSubgraphLayers) ++ (newActiveSubgraphs curLayer)))
      where
        newVertLayers :: [([UINode], [UINode], Bool)]
newVertLayers = (([UINode], [UINode], Bool) -> ([UINode], [UINode], Bool))
-> [([UINode], [UINode], Bool)] -> [([UINode], [UINode], Bool)]
forall a b. (a -> b) -> [a] -> [b]
map ([UINode], [UINode], Bool) -> ([UINode], [UINode], Bool)
adjustConnected [([UINode], [UINode], Bool)]
vertLayers
        adjustConnected :: ([UINode], [UINode], Bool) -> ([UINode], [UINode], Bool)
adjustConnected ([UINode]
someLayer, [UINode]
unconnectedChildren, Bool
_) = -- Debug.Trace.trace ("adjustConnected " ++ show (someLayer, unconnectedChildren, newun, map (isNotMainFunctionArg g) someLayer)) $
                        ([UINode]
someLayer, [UINode]
newun, [UINode] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UINode]
newun Bool -> Bool -> Bool
&& (UINode -> Bool) -> [UINode] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (CGraph n e -> UINode -> Bool
forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e -> UINode -> Bool
isNotMainFunctionArg CGraph n e
g) [UINode]
someLayer)
          where newun :: [UINode]
newun = [UINode]
unconnectedChildren [UINode] -> [UINode] -> [UINode]
forall a. Eq a => [a] -> [a] -> [a]
\\ [UINode]
curLayer

        isNotMainFunctionArg :: (NodeClass n, EdgeClass e) => CGraph n e -> UINode -> Bool
        isNotMainFunctionArg :: forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e -> UINode -> Bool
isNotMainFunctionArg CGraph n e
g UINode
node = -- not (maybe False isMainArg (Graph.lookupNode node g))
                                      Bool -> Bool
not (CGraph n e -> UINode -> Bool
forall e. EdgeClass e => CGraph n e -> UINode -> Bool
forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e -> UINode -> Bool
isMainArg CGraph n e
g UINode
node)

        fil :: [([UINode], [UINode], Bool)]
fil | Bool -> Bool
not ([UINode] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UINode]
newCurLayer) = -- Debug.Trace.trace ("fil0 "++ show (newVertLayers)) $
                                       (([UINode], [UINode], Bool) -> Bool)
-> [([UINode], [UINode], Bool)] -> [([UINode], [UINode], Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (([UINode], [UINode], Bool) -> Bool)
-> ([UINode], [UINode], Bool)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([UINode], [UINode], Bool) -> Bool
forall {a} {b} {c}. (a, b, c) -> c
changed) [([UINode], [UINode], Bool)]
newVertLayers
            | Bool -> Bool
not ([UINode] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UINode]
fullyConnectedVertNodes) = -- Debug.Trace.trace ("fil1 "++ show (filter (not . isFullyConnected) newVertLayers)) $
                                                    (([UINode], [UINode], Bool) -> Bool)
-> [([UINode], [UINode], Bool)] -> [([UINode], [UINode], Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (([UINode], [UINode], Bool) -> Bool)
-> ([UINode], [UINode], Bool)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([UINode], [UINode], Bool) -> Bool
forall {t :: * -> *} {a} {a} {c}. Foldable t => (a, t a, c) -> Bool
isFullyConnected) [([UINode], [UINode], Bool)]
newVertLayers --remove fully connected vertical layers
            | Bool
otherwise = -- Debug.Trace.trace ("fil2 "++ show (filter (not . isFullyConnected) newVertLayers)) $
                                                    (([UINode], [UINode], Bool) -> Bool)
-> [([UINode], [UINode], Bool)] -> [([UINode], [UINode], Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (([UINode], [UINode], Bool) -> Bool)
-> ([UINode], [UINode], Bool)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([UINode], [UINode], Bool) -> Bool
forall {t :: * -> *} {a} {a} {c}. Foldable t => (a, t a, c) -> Bool
isFullyConnected) [([UINode], [UINode], Bool)]
newVertLayers --remove fully connected vertical layers
--        fullyConnectedVertNodes = concat (map fst (filter isFullyConnectedAndNotArg newVertLayers))
        fullyConnectedVertNodes :: [UINode]
fullyConnectedVertNodes = (([UINode], [UINode], Bool) -> [UINode])
-> [([UINode], [UINode], Bool)] -> [UINode]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([UINode], [UINode], Bool) -> [UINode]
forall {a} {b} {c}. (a, b, c) -> a
sel1 ((([UINode], [UINode], Bool) -> Bool)
-> [([UINode], [UINode], Bool)] -> [([UINode], [UINode], Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter ([UINode], [UINode], Bool) -> Bool
forall {t :: * -> *} {a} {a} {c}. Foldable t => (a, t a, c) -> Bool
isFullyConnected [([UINode], [UINode], Bool)]
newVertLayers)
--        isFullyConnectedAndNotArg (someLayer,unconnectedChildren) = Debug.Trace.trace ("isfully "++ show (null unconnectedChildren, map (isMainFunctionArg g) someLayer)) $
--                                                                    null unconnectedChildren &&
--                                                                    not (or (map (isMainFunctionArg g) someLayer))

        isFullyConnected :: (a, t a, c) -> Bool
isFullyConnected (a
someLayer,t a
unconnectedChildren,c
_) = t a -> Bool
forall a. t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
unconnectedChildren

        newCurLayer :: [UINode]
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))) $
                      ([UINode] -> [UINode]
forall a. Ord a => [a] -> [a]
myNub ((UINode -> Bool) -> [UINode] -> [UINode]
forall a. (a -> Bool) -> [a] -> [a]
filter UINode -> Bool
shouldNodeBeAdded ([UINode] -> [UINode]
layerParents [UINode]
curLayer))) [UINode] -> [UINode] -> [UINode]
forall a. [a] -> [a] -> [a]
++
                      ((([UINode], [UINode], Bool) -> [UINode])
-> [([UINode], [UINode], Bool)] -> [UINode]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([UINode], [UINode], Bool) -> [UINode]
forall {a} {b} {c}. (a, b, c) -> a
sel1 ((([UINode], [UINode], Bool) -> Bool)
-> [([UINode], [UINode], Bool)] -> [([UINode], [UINode], Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter ([UINode], [UINode], Bool) -> Bool
forall {a} {b} {c}. (a, b, c) -> c
changed [([UINode], [UINode], Bool)]
newVertLayers)) -- ++
                      -- (concatMap pickFirstLayer activeSubgraphLayers)

--        pickFirstLayer :: [[UINode]] -> [UINode]
--        pickFirstLayer graphLayers = map head (filter (not . null) graphLayers)
        changed :: (a, b, c) -> c
changed (a
_,b
_,c
b) = c
b
        layerParents :: [UINode] -> [UINode]
layerParents [UINode]
l = Vector UINode -> [UINode]
forall a. Unbox a => Vector a -> [a]
VU.toList ((UINode -> Vector UINode) -> Vector UINode -> Vector UINode
forall a b.
(Unbox a, Unbox b) =>
(a -> Vector b) -> Vector a -> Vector b
VU.concatMap (CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
parentsNoVertical CGraph n e
g) ([UINode] -> Vector UINode
forall a. Unbox a => [a] -> Vector a
VU.fromList [UINode]
l))
        newCurLayerOrVert :: [UINode]
newCurLayerOrVert
            | Bool -> Bool
not ([UINode] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UINode]
newCurLayer) = -- Debug.Trace.trace ("not (null newCurLayer)" ++ show newCurLayer) $ --prefer normal nodes to vertical nodes
                                       [UINode] -> [UINode]
forall a. Ord a => [a] -> [a]
myNub [UINode]
newCurLayer
            | Bool -> Bool
not ([UINode] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UINode]
fullyConnectedVertNodes) = -- Debug.Trace.trace ("not (null fullyConnectedVertNodes2)"++ show fullyConnectedVertNodes) $ --if no normal nodes are left
                                                   [UINode] -> [UINode]
forall a. Ord a => [a] -> [a]
myNub [UINode]
fullyConnectedVertNodes
            | Bool
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 :: UINode -> Bool
shouldNodeBeAdded UINode
node | Vector UINode -> Bool
forall a. Unbox a => Vector a -> Bool
VU.null Vector UINode
chs = -- Debug.Trace.trace ("should0 "++ show (node, chs, VU.map isChildUsed chs)) $
                                               Bool
False
                               | Bool
otherwise = -- Debug.Trace.trace ("should1 "++ show (node, chs, VU.map isChildUsed chs, isInVertLayer node)) $
                                             Vector Bool -> Bool
VU.and ((UINode -> Bool) -> Vector UINode -> Vector Bool
forall a b. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
VU.map UINode -> Bool
isChildUsed Vector UINode
chs) Bool -> Bool -> Bool
&&
                                             (Bool -> Bool
not (UINode -> Bool
isInVertLayer UINode
node))
          where chs :: Vector UINode
chs = CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
childrenNoVertical CGraph n e
g UINode
node
                isChildUsed :: UINode -> Bool
                isChildUsed :: UINode -> Bool
isChildUsed UINode
child = UINode -> [UINode] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem UINode
child ([UINode]
usedNodes [UINode] -> [UINode] -> [UINode]
forall a. [a] -> [a] -> [a]
++ [UINode]
curLayer)
                isInVertLayer :: UINode -> Bool
                isInVertLayer :: UINode -> Bool
isInVertLayer UINode
n = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ((([UINode], [UINode], Bool) -> Bool)
-> [([UINode], [UINode], Bool)] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map ((UINode -> [UINode] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem UINode
n)([UINode] -> Bool)
-> (([UINode], [UINode], Bool) -> [UINode])
-> ([UINode], [UINode], Bool)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([UINode], [UINode], Bool) -> [UINode]
forall {a} {b} {c}. (a, b, c) -> a
sel1) [([UINode], [UINode], Bool)]
vertLayers)

        myTail :: [a] -> [a]
myTail [a]
ls | [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
ls = []
                  | Bool
otherwise = [a] -> [a]
forall a. HasCallStack => [a] -> [a]
tail [a]
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 :: Graph n [e] -> [([UINode], [UINode], Bool)]
verticalLayers Graph n [e]
g = -- Debug.Trace.trace (show ("verticalLayers", VU.toList optionNodes, vLayers (VU.toList optionNodes))) $
                   [UINode] -> [([UINode], [UINode], Bool)]
vLayers (Vector UINode -> [UINode]
forall a. Unbox a => Vector a -> [a]
VU.toList Vector UINode
optionNodes)
  where (Vector UINode
_, Vector UINode
optionNodes) = Graph n [e] -> Vector UINode -> (Vector UINode, Vector UINode)
forall e n.
EdgeClass e =>
CGraph n e -> Vector UINode -> (Vector UINode, Vector UINode)
partitionNodes Graph n [e]
g Vector UINode
ns -- nonOptionNodes
        ns :: Vector UINode
ns = (Int -> UINode) -> Vector Int -> Vector UINode
forall a b. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
VU.map Int -> UINode
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Int] -> Vector Int
forall a. Unbox a => [a] -> Vector a
VU.fromList (Graph n [e] -> [Int]
forall {a} {el}. Graph a el -> [Int]
nodes Graph n [e]
g))
        vLayers :: [UINode] -> [([UINode], [UINode], Bool)]
vLayers [] = []
        vLayers (UINode
n:[UINode]
ns1) = -- Debug.Trace.trace (show ("vLayers", n, newLayer, addUnconnectedChildren newLayer)) $
                          ([UINode] -> ([UINode], [UINode], Bool)
addUnconnectedChildren [UINode]
newLayer)([UINode], [UINode], Bool)
-> [([UINode], [UINode], Bool)] -> [([UINode], [UINode], Bool)]
forall a. a -> [a] -> [a]
: ([UINode] -> [([UINode], [UINode], Bool)]
vLayers ([UINode]
ns1 [UINode] -> [UINode] -> [UINode]
forall a. Eq a => [a] -> [a] -> [a]
\\ [UINode]
newLayer))
          where newLayer :: [UINode]
newLayer = [UINode] -> [UINode]
forall a. Ord a => [a] -> [a]
sort ([UINode] -> [UINode]) -> [UINode] -> [UINode]
forall a b. (a -> b) -> a -> b
$ Graph n [e] -> UINode -> [UINode]
forall e n. EdgeClass e => CGraph n e -> UINode -> [UINode]
verticallyConnectedNodes Graph n [e]
g UINode
n
                addUnconnectedChildren :: [UINode] -> ([UINode],UnconnectedChildren,Bool)
                addUnconnectedChildren :: [UINode] -> ([UINode], [UINode], Bool)
addUnconnectedChildren [UINode]
layer1 = ([UINode]
layer1, [UINode] -> [UINode]
forall a. Ord a => [a] -> [a]
myNub ([UINode] -> [UINode]) -> [UINode] -> [UINode]
forall a b. (a -> b) -> a -> b
$ Vector UINode -> [UINode]
forall a. Unbox a => Vector a -> [a]
VU.toList ([Vector UINode] -> Vector UINode
forall a. Unbox a => [Vector a] -> Vector a
VU.concat ((UINode -> Vector UINode) -> [UINode] -> [Vector UINode]
forall a b. (a -> b) -> [a] -> [b]
map UINode -> Vector UINode
nonVertChildren [UINode]
layer1)), Bool
False)
                nonVertChildren :: UINode -> Vector UINode
nonVertChildren UINode
node = Graph n [e] -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
childrenNoVertical Graph n [e]
g UINode
node


nodesWithoutChildrenVertLayer :: (NodeClass n, EdgeClass e) => CGraph n e -> VU.Vector UINode
nodesWithoutChildrenVertLayer :: forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e -> Vector UINode
nodesWithoutChildrenVertLayer CGraph n e
g = -- Debug.Trace.trace ("nwcvl "++ show (nodesWithoutChildren, nwcvl))
                                  Vector UINode
nwcvl
  where nwcvl :: Vector UINode
nwcvl = (UINode -> Vector UINode) -> Vector UINode -> Vector UINode
forall a b.
(Unbox a, Unbox b) =>
(a -> Vector b) -> Vector a -> Vector b
VU.concatMap ([[UINode]] -> UINode -> Vector UINode
findLayers ((([UINode], [UINode], Bool) -> [UINode])
-> [([UINode], [UINode], Bool)] -> [[UINode]]
forall a b. (a -> b) -> [a] -> [b]
map ([UINode], [UINode], Bool) -> [UINode]
forall {a} {b} {c}. (a, b, c) -> a
sel1 (CGraph n e -> [([UINode], [UINode], Bool)]
forall {e} {n}.
EdgeClass e =>
Graph n [e] -> [([UINode], [UINode], Bool)]
verticalLayers CGraph n e
g))) Vector UINode
nodesWithoutChildren
        nodesWithoutChildren :: Vector UINode
nodesWithoutChildren = (UINode -> Bool) -> Vector UINode -> Vector UINode
forall a. Unbox a => (a -> Bool) -> Vector a -> Vector a
VU.filter (\UINode
n -> Bool -> Bool
not (CGraph n e -> UINode -> Bool
forall e. EdgeClass e => CGraph n e -> UINode -> Bool
forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e -> UINode -> Bool
isDummy CGraph n e
g UINode
n) Bool -> Bool -> Bool
&& Vector UINode -> Bool
forall a. Unbox a => Vector a -> Bool
VU.null (UINode -> Vector UINode
cs UINode
n)) Vector UINode
ns
        cs :: UINode -> Vector UINode
cs UINode
node = CGraph n e -> UINode -> [e] -> Vector UINode
forall el nl.
EdgeAttribute el =>
Graph nl el -> UINode -> el -> Vector UINode
Graph.children CGraph n e
g UINode
node [Maybe Int -> Int -> e
forall e. EdgeClass e => Maybe Int -> Int -> e
dummyEdge Maybe Int
forall a. Maybe a
Nothing Int
0]
        ns :: Vector UINode
ns = (Int -> UINode) -> Vector Int -> Vector UINode
forall a b. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
VU.map Int -> UINode
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Int] -> Vector Int
forall a. Unbox a => [a] -> Vector a
VU.fromList (CGraph n e -> [Int]
forall {a} {el}. Graph a el -> [Int]
nodes CGraph n e
g))
        (Vector UINode
_, Vector UINode
optionNodes) = CGraph n e -> Vector UINode -> (Vector UINode, Vector UINode)
forall e n.
EdgeClass e =>
CGraph n e -> Vector UINode -> (Vector UINode, Vector UINode)
partitionNodes CGraph n e
g Vector UINode
ns
        findLayers :: [[UINode]] -> UINode -> VU.Vector UINode
        findLayers :: [[UINode]] -> UINode -> Vector UINode
findLayers [[UINode]]
ls UINode
n | [[UINode]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[UINode]]
ls = UINode -> Vector UINode
forall a. Unbox a => a -> Vector a
VU.singleton UINode
n
                        | Bool
otherwise = [UINode] -> Vector UINode
forall a. Unbox a => [a] -> Vector a
VU.fromList ([[UINode]] -> [UINode]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (([UINode] -> [UINode]) -> [[UINode]] -> [[UINode]]
forall a b. (a -> b) -> [a] -> [b]
map [UINode] -> [UINode]
findL [[UINode]]
ls))
          where findL :: [UINode] -> [UINode]
findL [UINode]
l | UINode -> [UINode] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem UINode
n [UINode]
l = [UINode]
l
                        | Bool
otherwise = [UINode
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 :: forall e n.
EdgeClass e =>
CGraph n e -> Vector UINode -> (Vector UINode, Vector UINode)
partitionNodes CGraph n e
g =
  (UINode -> Bool) -> Vector UINode -> (Vector UINode, Vector UINode)
forall a.
Unbox a =>
(a -> Bool) -> Vector a -> (Vector a, Vector a)
VU.partition
    ( \UINode
n ->
        Vector UINode -> Bool
forall a. Unbox a => Vector a -> Bool
VU.null (CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
parentsVertical CGraph n e
g UINode
n)
          Bool -> Bool -> Bool
&& Vector UINode -> Bool
forall a. Unbox a => Vector a -> Bool
VU.null (CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
childrenVertical CGraph n e
g UINode
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 :: forall n e.
(NodeClass n, Show n, Show e, EdgeClass e) =>
CGraph n e -> CGraph n e
addMissingInputNodes CGraph n e
graph =
  -- Debug.Trace.trace ("\naddConnectionNodes"++ show (foldl addConnNode graph (map fromIntegral (nodes graph)))) $
  (CGraph n e -> UINode -> CGraph n e)
-> CGraph n e -> [UINode] -> CGraph n e
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl CGraph n e -> UINode -> CGraph n e
forall n e.
(NodeClass n, Show n, EdgeClass e) =>
CGraph n e -> UINode -> CGraph n e
addConnNode CGraph n e
graph ((Int -> UINode) -> [Int] -> [UINode]
forall a b. (a -> b) -> [a] -> [b]
map Int -> UINode
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CGraph n e -> [Int]
forall {a} {el}. Graph a el -> [Int]
nodes CGraph n e
graph))
  where
    addConnNode :: (NodeClass n, Show n, EdgeClass e) => CGraph n e -> UINode -> CGraph n e
    addConnNode :: forall n e.
(NodeClass n, Show n, EdgeClass e) =>
CGraph n e -> UINode -> CGraph n e
addConnNode CGraph n e
g UINode
n
      | Vector UINode -> Bool
forall a. Unbox a => Vector a -> Bool
VU.null Vector UINode
ps = CGraph n e
g
      | CGraph n e -> UINode -> Bool
forall e. EdgeClass e => CGraph n e -> UINode -> Bool
forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e -> UINode -> Bool
isFunction CGraph n e
graph UINode
n Bool -> Bool -> Bool
&& CGraph n e -> UINode -> Bool
forall e. EdgeClass e => CGraph n e -> UINode -> Bool
forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e -> UINode -> Bool
isCase CGraph n e
graph (Vector UINode -> UINode
forall {a}. Unbox a => Vector a -> a
vHead Vector UINode
ps) = -- Debug.Trace.trace ("caseconn"++ show (n, vHead 1 ps)) $
        CGraph n e
-> UINode
-> UINode
-> Maybe Int
-> Int
-> (Maybe UINode, Int)
-> CGraph n e
forall n e.
(NodeClass n, Show n, EdgeClass e) =>
CGraph n e
-> UINode
-> UINode
-> Maybe Int
-> Int
-> (Maybe UINode, Int)
-> CGraph n e
insertConnNode CGraph n e
g UINode
n (Vector UINode -> UINode
forall {a}. Unbox a => Vector a -> a
vHead Vector UINode
ps) Maybe Int
forall a. Maybe a
Nothing Int
0 (Maybe UINode
forall a. Maybe a
Nothing,Int
0)
      | Bool
otherwise = CGraph n e
g
      where
        ps :: Vector UINode
ps = CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
parentsNoVertical CGraph n e
graph UINode
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 :: forall n e.
(NodeClass n, Show n, EdgeClass e, Show e) =>
(CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])
arrangeMetaNodes (CGraph n e
graph, [[UINode]]
layers) =
  -- Debug.Trace.trace ("arrangeMetaNodes"++ show layers ++ "\n" ++ show newLayers ++ "\n" ++ show graph)
                                   (CGraph n e
graph, [[UINode]]
newLayers)
  where
    newLayers :: [[UINode]]
newLayers = ([UINode] -> [UINode]) -> [[UINode]] -> [[UINode]]
forall a b. (a -> b) -> [a] -> [b]
map [UINode] -> [UINode]
oneLayer [[UINode]]
layers
    oneLayer :: [UINode] -> [UINode]
    oneLayer :: [UINode] -> [UINode]
oneLayer [UINode]
ls | [UINode] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UINode]
metaNodes = [UINode]
ls
                | Bool
otherwise = ([UINode]
ls [UINode] -> [UINode] -> [UINode]
forall a. Eq a => [a] -> [a] -> [a]
\\ [UINode]
metaNodes) [UINode] -> [UINode] -> [UINode]
forall a. [a] -> [a] -> [a]
++ [UINode]
metaNodes
      where metaNodes :: [UINode]
metaNodes = (UINode -> Bool) -> [UINode] -> [UINode]
forall a. (a -> Bool) -> [a] -> [a]
filter (\UINode
n -> CGraph n e -> UINode -> Bool
forall n e.
(NodeClass n, EdgeClass e, Show n) =>
CGraph n e -> UINode -> Bool
isMetaNode CGraph n e
graph UINode
n) [UINode]
ls

    isMetaNode :: (NodeClass n, EdgeClass e, Show n) => CGraph n e -> UINode -> Bool
    isMetaNode :: forall n e.
(NodeClass n, EdgeClass e, Show n) =>
CGraph n e -> UINode -> Bool
isMetaNode CGraph n e
g UINode
node = Bool -> (n -> Bool) -> Maybe n -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False n -> Bool
forall {p}. p -> Bool
isMetaLabel (UINode -> CGraph n e -> Maybe n
forall nl el.
(Show nl, EdgeAttribute el) =>
UINode -> Graph nl el -> Maybe nl
Graph.lookupNode UINode
node CGraph n e
g)

    isMetaLabel :: p -> Bool
isMetaLabel p
_ = Bool
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 :: forall n e.
(NodeClass n, Show n, ExtractNodeType n, Enum n, EdgeClass e,
 Show e) =>
(CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])
addConnectionNodes (CGraph n e
g, [[UINode]]
ls) = (CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])
forall n e.
(NodeClass n, Show n, EdgeClass e, Show e) =>
(CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])
addConnectionNs (CGraph n e
g, [[UINode]]
ls)

addConnectionNs :: (NodeClass n, Show n, EdgeClass e, Show e) => (CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])
addConnectionNs :: forall n e.
(NodeClass n, Show n, EdgeClass e, Show e) =>
(CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])
addConnectionNs (CGraph n e
graph, []) = (CGraph n e
graph, [])
addConnectionNs (CGraph n e
graph, [[UINode]
l0]) = (CGraph n e
graph, [[UINode]
l0])
addConnectionNs (CGraph n e
graph, [UINode]
l0 : [UINode]
l1 : [[UINode]]
layers) = ((CGraph n e, [[UINode]]) -> CGraph n e
forall a b. (a, b) -> a
fst (CGraph n e, [[UINode]])
adv, [UINode]
l0 [UINode] -> [[UINode]] -> [[UINode]]
forall a. a -> [a] -> [a]
: ((CGraph n e, [[UINode]]) -> [[UINode]]
forall a b. (a, b) -> b
snd (CGraph n e, [[UINode]])
adv))
  where
    adv :: (CGraph n e, [[UINode]])
adv = (CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])
forall n e.
(NodeClass n, Show n, EdgeClass e, Show e) =>
(CGraph n e, [[UINode]]) -> (CGraph n e, [[UINode]])
addConnectionNs (CGraph n e
newGraph, ([UINode]
newLayer [UINode] -> [[UINode]] -> [[UINode]]
forall a. a -> [a] -> [a]
: [[UINode]]
layers))

    (CGraph n e
newGraph, [UINode]
newLayer) = ((CGraph n e, [UINode])
 -> (UINode,
     (UINode, UINode, (Maybe Int, Int), (Maybe UINode, Int)))
 -> (CGraph n e, [UINode]))
-> (CGraph n e, [UINode])
-> [(UINode,
     (UINode, UINode, (Maybe Int, Int), (Maybe UINode, Int)))]
-> (CGraph n e, [UINode])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (CGraph n e, [UINode])
-> (UINode,
    (UINode, UINode, (Maybe Int, Int), (Maybe UINode, Int)))
-> (CGraph n e, [UINode])
forall n e.
(NodeClass n, Show n, EdgeClass e) =>
(CGraph n e, [UINode])
-> (UINode,
    (UINode, UINode, (Maybe Int, Int), (Maybe UINode, Int)))
-> (CGraph n e, [UINode])
dummyNodeEdge (CGraph n e
graph, [UINode]
l1) ([UINode]
-> [(UINode, UINode, (Maybe Int, Int), (Maybe UINode, Int))]
-> [(UINode,
     (UINode, UINode, (Maybe Int, Int), (Maybe UINode, Int)))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int -> UINode
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) ..] [(UINode, UINode, (Maybe Int, Int), (Maybe UINode, Int))]
innerSs)
    m :: Int
m = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (CGraph n e -> [Int]
forall {a} {el}. Graph a el -> [Int]
nodes CGraph n e
graph)

    innerSs :: [(UINode, UINode, (Maybe Int, Int), (Maybe UINode, Int))]
innerSs = (UINode
 -> [(UINode, UINode, (Maybe Int, Int), (Maybe UINode, Int))])
-> [UINode]
-> [(UINode, UINode, (Maybe Int, Int), (Maybe UINode, Int))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UINode -> [(UINode, UINode, (Maybe Int, Int), (Maybe UINode, Int))]
innerSegments [UINode]
l0
    innerSegments :: UINode -> [(UINode, UINode, (Maybe Int, Int), (Maybe UINode, Int))]
innerSegments UINode
n =
      [UINode]
-> [UINode]
-> [(Maybe Int, Int)]
-> [(Maybe UINode, Int)]
-> [(UINode, UINode, (Maybe Int, Int), (Maybe UINode, Int))]
forall a b c d. [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
zip4 (UINode -> [UINode]
forall a. a -> [a]
repeat UINode
n) [UINode]
notInLayerL1Parents [(Maybe Int, Int)]
chans ((Maybe UINode, Int) -> [(Maybe UINode, Int)]
forall a. a -> [a]
repeat (Maybe UINode
bid,Int
lay))
      where
        ps :: Vector UINode
ps = CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
parentsNoVertical CGraph n e
graph UINode
n
        isNotInLayerL1 :: UINode -> Bool
isNotInLayerL1 = Bool -> Bool
not (Bool -> Bool) -> (UINode -> Bool) -> UINode -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UINode -> [UINode] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UINode]
l1)
        notInLayerL1Parents :: [UINode]
notInLayerL1Parents = Vector UINode -> [UINode]
forall a. Unbox a => Vector a -> [a]
VU.toList ((UINode -> Bool) -> Vector UINode -> Vector UINode
forall a. Unbox a => (a -> Bool) -> Vector a -> Vector a
VU.filter UINode -> Bool
isNotInLayerL1 Vector UINode
ps)
        chans :: [(Maybe Int, Int)]
chans = (Maybe [e] -> (Maybe Int, Int))
-> [Maybe [e]] -> [(Maybe Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\Maybe [e]
e -> (Maybe Int, Int)
-> ([e] -> (Maybe Int, Int)) -> Maybe [e] -> (Maybe Int, Int)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Int
forall a. Maybe a
Nothing, Int
0) [e] -> (Maybe Int, Int)
forall {e}. EdgeClass e => [e] -> (Maybe Int, Int)
f Maybe [e]
e) [Maybe [e]]
edges
        f :: [e] -> (Maybe Int, Int)
f [e]
x = (e -> Maybe Int
forall e. EdgeClass e => e -> Maybe Int
channelNrIn (Int -> [e] -> e
forall a. Int -> [a] -> a
myHead Int
74 [e]
x), e -> Int
forall e. EdgeClass e => e -> Int
channelNrOut (Int -> [e] -> e
forall a. Int -> [a] -> a
myHead Int
75 [e]
x))
        edges :: [Maybe [e]]
edges = (UINode -> Maybe [e]) -> [UINode] -> [Maybe [e]]
forall a b. (a -> b) -> [a] -> [b]
map (UINode -> UINode -> Maybe [e]
`lue` UINode
n) [UINode]
notInLayerL1Parents
        lue :: UINode -> UINode -> Maybe [e]
lue UINode
x UINode
y = (UINode, UINode) -> CGraph n e -> Maybe [e]
forall el nl.
(EdgeAttribute el, Show el) =>
(UINode, UINode) -> Graph nl el -> Maybe el
Graph.lookupEdge (UINode
x, UINode
y) CGraph n e
graph
        nest :: Maybe LayerFeatures
nest | Maybe n -> Bool
forall a. Maybe a -> Bool
isJust Maybe n
lu = n -> Maybe LayerFeatures
forall n. NodeClass n => n -> Maybe LayerFeatures
Common.nestingFeatures (Int -> Maybe n -> n
forall a. Int -> Maybe a -> a
myFromJust Int
516 Maybe n
lu)
             | Bool
otherwise = Maybe LayerFeatures
forall a. Maybe a
Nothing
        lu :: Maybe n
lu = UINode -> CGraph n e -> Maybe n
forall nl el.
(Show nl, EdgeAttribute el) =>
UINode -> Graph nl el -> Maybe nl
Graph.lookupNode UINode
n CGraph n e
graph
        bid :: Maybe UINode
bid = Maybe UINode
-> (LayerFeatures -> Maybe UINode)
-> Maybe LayerFeatures
-> Maybe UINode
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe UINode
forall a. Maybe a
Nothing LayerFeatures -> Maybe UINode
Common.boxId Maybe LayerFeatures
nest
        lay :: Int
lay = Int -> (LayerFeatures -> Int) -> Maybe LayerFeatures -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
1 LayerFeatures -> Int
Common.layer Maybe LayerFeatures
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 :: forall n e.
(NodeClass n, Show n, EdgeClass e) =>
(CGraph n e, [UINode])
-> (UINode,
    (UINode, UINode, (Maybe Int, Int), (Maybe UINode, Int)))
-> (CGraph n e, [UINode])
dummyNodeEdge (CGraph n e
g, [UINode]
l) (UINode
v, (UINode
from, UINode
to, (Maybe Int
chanIn, Int
chanOut), (Maybe UINode, Int)
boxId)) =
      (CGraph n e
-> UINode
-> UINode
-> Maybe Int
-> Int
-> (Maybe UINode, Int)
-> CGraph n e
forall n e.
(NodeClass n, Show n, EdgeClass e) =>
CGraph n e
-> UINode
-> UINode
-> Maybe Int
-> Int
-> (Maybe UINode, Int)
-> CGraph n e
insertConnNode CGraph n e
g UINode
from UINode
to Maybe Int
chanIn Int
chanOut (Maybe UINode, Int)
boxId, UINode
v UINode -> [UINode] -> [UINode]
forall a. a -> [a] -> [a]
: [UINode]
l)

insertConnNode :: (NodeClass n, Show n, EdgeClass e) => CGraph n e -> UINode -> UINode -> Maybe Channel -> Channel -> (Maybe BoxId, Nesting) -> CGraph n e
insertConnNode :: forall n e.
(NodeClass n, Show n, EdgeClass e) =>
CGraph n e
-> UINode
-> UINode
-> Maybe Int
-> Int
-> (Maybe UINode, Int)
-> CGraph n e
insertConnNode CGraph n e
graph UINode
from UINode
to Maybe Int
chanIn Int
chanOut (Maybe UINode
boxId, Int
nest) =
  Maybe Bool -> (UINode, UINode) -> CGraph n e -> CGraph n e
forall el nl.
EdgeAttribute el =>
Maybe Bool -> (UINode, UINode) -> Graph nl el -> Graph nl el
Graph.deleteEdge (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) (UINode
to, UINode
from) (CGraph n e -> CGraph n e) -> CGraph n e -> CGraph n e
forall a b. (a -> b) -> a -> b
$
    Maybe Bool -> (UINode, UINode) -> [e] -> CGraph n e -> CGraph n e
forall el nl.
EdgeAttribute el =>
Maybe Bool -> (UINode, UINode) -> el -> Graph nl el -> Graph nl el
Graph.insertEdge (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) (UINode
to, Int -> UINode
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) [Maybe Int -> Int -> e
forall e. EdgeClass e => Maybe Int -> Int -> e
dummyEdge Maybe Int
chanIn Int
0] (CGraph n e -> CGraph n e) -> CGraph n e -> CGraph n e
forall a b. (a -> b) -> a -> b
$
      Maybe Bool -> (UINode, UINode) -> [e] -> CGraph n e -> CGraph n e
forall el nl.
EdgeAttribute el =>
Maybe Bool -> (UINode, UINode) -> el -> Graph nl el -> Graph nl el
Graph.insertEdge
        (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)
        (Int -> UINode
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1), UINode
from)
        [Maybe Int -> Int -> e
forall e. EdgeClass e => Maybe Int -> Int -> e
dummyEdge Maybe Int
forall a. Maybe a
Nothing Int
chanOut]
        (UINode -> n -> CGraph n e -> CGraph n e
forall el nl.
EdgeAttribute el =>
UINode -> nl -> Graph nl el -> Graph nl el
Graph.insertNode (Int -> UINode
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) (Maybe LayerFeatures -> n -> n
forall n. NodeClass n => Maybe LayerFeatures -> n -> n
updateLayer (LayerFeatures -> Maybe LayerFeatures
forall a. a -> Maybe a
Just (Int -> Maybe UINode -> Maybe Border -> LayerFeatures
LayerFeatures Int
nest Maybe UINode
boxId Maybe Border
forall a. Maybe a
Nothing)) n
forall n. NodeClass n => n
connectionNode) CGraph n e
graph)
  where
    m :: Int
m = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (CGraph n e -> [Int]
forall {a} {el}. Graph a el -> [Int]
nodes CGraph n e
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 :: forall n e.
(NodeClass n, Show n, EdgeClass e, Show e, ExtractNodeType n,
 Enum n) =>
Int
-> Bool
-> (NestMap, [UINode], ParentGraphOf)
-> (CGraph n e, [[(UINode, Maybe UINode)]])
-> (CGraph n e, [[UINode]])
crossingReduction Int
i Bool
longestP (NestMap
nestedGraphs, [UINode]
boxIds, ParentGraphOf
parentGraphOf) (CGraph n e
graph, [[(UINode, Maybe UINode)]]
layers) =
    -- Debug.Trace.trace ("parentGraphOf " ++ show (parentGraphOf)) $
    (CGraph n e
newGraph, ([(UINode, Maybe UINode)] -> [UINode])
-> [[(UINode, Maybe UINode)]] -> [[UINode]]
forall a b. (a -> b) -> [a] -> [b]
map (((UINode, Maybe UINode) -> UINode)
-> [(UINode, Maybe UINode)] -> [UINode]
forall a b. (a -> b) -> [a] -> [b]
map (UINode, Maybe UINode) -> UINode
forall a b. (a, b) -> a
fst) [[(UINode, Maybe UINode)]]
newLayers)
  where (CGraph n e
newGraph, [[(UINode, Maybe UINode)]]
newLayers) = Int
-> Bool
-> (NestMap, [UINode], ParentGraphOf)
-> (CGraph n e, [[(UINode, Maybe UINode)]])
-> (CGraph n e, [[(UINode, Maybe UINode)]])
forall n e.
(NodeClass n, Show n, EdgeClass e, Show e, ExtractNodeType n,
 Enum n) =>
Int
-> Bool
-> (NestMap, [UINode], ParentGraphOf)
-> (CGraph n e, [[(UINode, Maybe UINode)]])
-> (CGraph n e, [[(UINode, Maybe UINode)]])
crossingRed Int
i Bool
longestP (NestMap
nestedGraphs, [UINode]
boxIds, ParentGraphOf
parentGraphOf) (CGraph n e
graph, [[(UINode, Maybe UINode)]]
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 :: forall n e.
(NodeClass n, Show n, EdgeClass e, Show e, ExtractNodeType n,
 Enum n) =>
Int
-> Bool
-> (NestMap, [UINode], ParentGraphOf)
-> (CGraph n e, [[(UINode, Maybe UINode)]])
-> (CGraph n e, [[(UINode, Maybe UINode)]])
crossingRed Int
i Bool
longestP (NestMap
nestedGraphs, [UINode]
boxIds, ParentGraphOf
parentGraphOf) (CGraph n e
graph, [[(UINode, Maybe UINode)]]
layers)
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 =
--      Debug.Trace.trace ( -- "crossingReduction\nlayers    " ++ listShow layers ++
--                         "\nc         "++ listShow c ++
--                         "\nnewlayers "++ listShow newLayers) $
    Int
-> Bool
-> (NestMap, [UINode], ParentGraphOf)
-> (CGraph n e, [[(UINode, Maybe UINode)]])
-> (CGraph n e, [[(UINode, Maybe UINode)]])
forall n e.
(NodeClass n, Show n, EdgeClass e, Show e, ExtractNodeType n,
 Enum n) =>
Int
-> Bool
-> (NestMap, [UINode], ParentGraphOf)
-> (CGraph n e, [[(UINode, Maybe UINode)]])
-> (CGraph n e, [[(UINode, Maybe UINode)]])
crossingRed (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Bool
longestP (NestMap
nestedGraphs, [UINode]
boxIds, ParentGraphOf
parentGraphOf) (CGraph n e
graph, [[(UINode, Maybe UINode)]]
newLayers)
  | Bool
otherwise = (CGraph n e
graph, [[(UINode, Maybe UINode)]]
layers)
  where
    -- nodes that are at the center of attention
    priorityNodes :: [Int]
priorityNodes = Vector Int -> [Int]
forall a. Unbox a => Vector a -> [a]
VU.toList (Vector Int -> [Int]) -> Vector Int -> [Int]
forall a b. (a -> b) -> a -> b
$ CGraph n e -> [[UINode]] -> Vector Int
forall e n.
(EdgeClass e, NodeClass n) =>
CGraph n e -> [[UINode]] -> Vector Int
longestinfrequentPaths CGraph n e
graph [[UINode]]
revLayers
    revLayers :: [[UINode]]
revLayers = [[UINode]] -> [[UINode]]
forall a. [a] -> [a]
reverse (([(UINode, Maybe UINode)] -> [UINode])
-> [[(UINode, Maybe UINode)]] -> [[UINode]]
forall a b. (a -> b) -> [a] -> [b]
map (((UINode, Maybe UINode) -> UINode)
-> [(UINode, Maybe UINode)] -> [UINode]
forall a b. (a -> b) -> [a] -> [b]
map (UINode, Maybe UINode) -> UINode
forall a b1 b2. (Integral a, Num b1) => (a, b2) -> b1
first) [[(UINode, Maybe UINode)]]
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 :: [[(Int, Maybe UINode)]]
c = -- Debug.Trace.trace ("|l " ++ show subgraphLayers) $ -- ++ show (layers, priorityNodes))
        [[(Int, Maybe UINode)]] -> [[(Int, Maybe UINode)]]
forall a. [a] -> [a]
reverse (CGraph n e
-> Dir
-> [[(Int, Maybe UINode)]]
-> [Int]
-> Bool
-> ParentGraphOf
-> [[(Int, Maybe UINode)]]
forall n e.
(NodeClass n, Show n, EdgeClass e, Show e) =>
CGraph n e
-> Dir
-> [[(Int, Maybe UINode)]]
-> [Int]
-> Bool
-> ParentGraphOf
-> [[(Int, Maybe UINode)]]
crossR CGraph n e
graph Dir
RightToLeft ([[(Int, Maybe UINode)]] -> [[(Int, Maybe UINode)]]
forall a. [a] -> [a]
reverse (([(UINode, Maybe UINode)] -> [(Int, Maybe UINode)])
-> [[(UINode, Maybe UINode)]] -> [[(Int, Maybe UINode)]]
forall a b. (a -> b) -> [a] -> [b]
map (((UINode, Maybe UINode) -> (Int, Maybe UINode))
-> [(UINode, Maybe UINode)] -> [(Int, Maybe UINode)]
forall a b. (a -> b) -> [a] -> [b]
map (UINode, Maybe UINode) -> (Int, Maybe UINode)
forall a1 a2 b. (Integral a1, Num a2) => (a1, b) -> (a2, b)
fi) [[(UINode, Maybe UINode)]]
layers)) ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
priorityNodes) Bool
longestP ParentGraphOf
parentGraphOf)

    newLayers :: [[(UINode, Maybe UINode)]]
newLayers =
      -- Debug.Trace.trace ("|r " ++ show subgraphLayers) $ -- ++ show (layers, priorityNodes))
      ([(Int, Maybe UINode)] -> [(UINode, Maybe UINode)])
-> [[(Int, Maybe UINode)]] -> [[(UINode, Maybe UINode)]]
forall a b. (a -> b) -> [a] -> [b]
map
        (((Int, Maybe UINode) -> (UINode, Maybe UINode))
-> [(Int, Maybe UINode)] -> [(UINode, Maybe UINode)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Maybe UINode) -> (UINode, Maybe UINode)
forall a1 a2 b. (Integral a1, Num a2) => (a1, b) -> (a2, b)
fi)
        (CGraph n e
-> Dir
-> [[(Int, Maybe UINode)]]
-> [Int]
-> Bool
-> ParentGraphOf
-> [[(Int, Maybe UINode)]]
forall n e.
(NodeClass n, Show n, EdgeClass e, Show e) =>
CGraph n e
-> Dir
-> [[(Int, Maybe UINode)]]
-> [Int]
-> Bool
-> ParentGraphOf
-> [[(Int, Maybe UINode)]]
crossR CGraph n e
graph Dir
LeftToRight [[(Int, Maybe UINode)]]
c [Int]
priorityNodes Bool
longestP ParentGraphOf
parentGraphOf)

first :: (Integral a, Num b1) => (a, b2) -> b1
first :: forall a b1 b2. (Integral a, Num b1) => (a, b2) -> b1
first (a
n,b2
b) = a -> b1
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n
fi :: (Integral a1, Num a2) => (a1, b) -> (a2, b)
fi :: forall a1 a2 b. (Integral a1, Num a2) => (a1, b) -> (a2, b)
fi (a1
n,b
b) = (a1 -> a2
forall a b. (Integral a, Num b) => a -> b
fromIntegral a1
n, b
b)

data Dir = LeftToRight | RightToLeft deriving (Int -> Dir -> ShowS
[Dir] -> ShowS
Dir -> [Char]
(Int -> Dir -> ShowS)
-> (Dir -> [Char]) -> ([Dir] -> ShowS) -> Show Dir
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Dir -> ShowS
showsPrec :: Int -> Dir -> ShowS
$cshow :: Dir -> [Char]
show :: Dir -> [Char]
$cshowList :: [Dir] -> ShowS
showList :: [Dir] -> ShowS
Show)

leftToRight :: Dir -> Bool
leftToRight :: Dir -> Bool
leftToRight Dir
LeftToRight = Bool
True
leftToRight Dir
RightToLeft = Bool
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 :: forall n e.
(NodeClass n, Show n, EdgeClass e, Show e) =>
CGraph n e
-> Dir
-> [[(Int, Maybe UINode)]]
-> [Int]
-> Bool
-> ParentGraphOf
-> [[(Int, Maybe UINode)]]
crossR CGraph n e
_ Dir
_ [] [Int]
_ Bool
_ ParentGraphOf
_ = []
crossR CGraph n e
g Dir
dir ([(Int, Maybe UINode)]
l0 : [(Int, Maybe UINode)]
l1 : [[(Int, Maybe UINode)]]
layers) (Int
n0 : Int
n1 : [Int]
ns) Bool
longestP ParentGraphOf
parentGraphOf
  | IntMap UINode -> IntMap UINode -> Int
crossings IntMap UINode
l0Enum IntMap UINode
bEnum Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= IntMap UINode -> IntMap UINode -> Int
crossings IntMap UINode
l0Enum IntMap UINode
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)) $
    [(Int, Maybe UINode)]
l0p [(Int, Maybe UINode)]
-> [[(Int, Maybe UINode)]] -> [[(Int, Maybe UINode)]]
forall a. a -> [a] -> [a]
: (CGraph n e
-> Dir
-> [[(Int, Maybe UINode)]]
-> [Int]
-> Bool
-> ParentGraphOf
-> [[(Int, Maybe UINode)]]
forall n e.
(NodeClass n, Show n, EdgeClass e, Show e) =>
CGraph n e
-> Dir
-> [[(Int, Maybe UINode)]]
-> [Int]
-> Bool
-> ParentGraphOf
-> [[(Int, Maybe UINode)]]
crossR CGraph n e
g Dir
dir ([(Int, Maybe UINode)]
bv [(Int, Maybe UINode)]
-> [[(Int, Maybe UINode)]] -> [[(Int, Maybe UINode)]]
forall a. a -> [a] -> [a]
: [[(Int, Maybe UINode)]]
layers) (Int
n1 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
ns) Bool
longestP ParentGraphOf
parentGraphOf)
  | Bool
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)) $
    =
    [(Int, Maybe UINode)]
l0p [(Int, Maybe UINode)]
-> [[(Int, Maybe UINode)]] -> [[(Int, Maybe UINode)]]
forall a. a -> [a] -> [a]
: (CGraph n e
-> Dir
-> [[(Int, Maybe UINode)]]
-> [Int]
-> Bool
-> ParentGraphOf
-> [[(Int, Maybe UINode)]]
forall n e.
(NodeClass n, Show n, EdgeClass e, Show e) =>
CGraph n e
-> Dir
-> [[(Int, Maybe UINode)]]
-> [Int]
-> Bool
-> ParentGraphOf
-> [[(Int, Maybe UINode)]]
crossR CGraph n e
g Dir
dir ([(Int, Maybe UINode)]
l1p [(Int, Maybe UINode)]
-> [[(Int, Maybe UINode)]] -> [[(Int, Maybe UINode)]]
forall a. a -> [a] -> [a]
: [[(Int, Maybe UINode)]]
layers) (Int
n1 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
ns) Bool
longestP ParentGraphOf
parentGraphOf)
  where
    nl0 :: [(Int, Maybe UINode)]
nl0 = (((Int, Maybe UINode), Bool) -> (Int, Maybe UINode))
-> [((Int, Maybe UINode), Bool)] -> [(Int, Maybe UINode)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, Maybe UINode), Bool) -> (Int, Maybe UINode)
forall a b. (a, b) -> a
fst (CGraph n e
-> [(Int, Maybe UINode)] -> [((Int, Maybe UINode), Bool)]
forall e n.
(EdgeClass e, Show n, NodeClass n) =>
CGraph n e
-> [(Int, Maybe UINode)] -> [((Int, Maybe UINode), Bool)]
lv CGraph n e
g [(Int, Maybe UINode)]
l0)
    nl1 :: [(Int, Maybe UINode)]
nl1 = (((Int, Maybe UINode), Bool) -> (Int, Maybe UINode))
-> [((Int, Maybe UINode), Bool)] -> [(Int, Maybe UINode)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, Maybe UINode), Bool) -> (Int, Maybe UINode)
forall a b. (a, b) -> a
fst (CGraph n e
-> [(Int, Maybe UINode)] -> [((Int, Maybe UINode), Bool)]
forall e n.
(EdgeClass e, Show n, NodeClass n) =>
CGraph n e
-> [(Int, Maybe UINode)] -> [((Int, Maybe UINode), Bool)]
lv CGraph n e
g [(Int, Maybe UINode)]
l1)
    --    isNoVert0 = not (or (map snd (lv g l0)))
    --    isNoVert1 = not (or (map snd (lv g l1)))
    b :: [(Int, Maybe UINode)]
b = CGraph n e
-> Dir
-> [(Int, Maybe UINode)]
-> [(Int, Maybe UINode)]
-> ParentGraphOf
-> Int
-> [(Int, Maybe UINode)]
forall n e.
(NodeClass n, Show n, EdgeClass e, Show e) =>
CGraph n e
-> Dir
-> [(Int, Maybe UINode)]
-> [(Int, Maybe UINode)]
-> ParentGraphOf
-> Int
-> [(Int, Maybe UINode)]
barycenter CGraph n e
g Dir
dir [(Int, Maybe UINode)]
l0 [(Int, Maybe UINode)]
l1 ParentGraphOf
parentGraphOf Int
n1
    bv :: [(Int, Maybe UINode)]
bv = (((Int, Maybe UINode), Bool) -> (Int, Maybe UINode))
-> [((Int, Maybe UINode), Bool)] -> [(Int, Maybe UINode)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, Maybe UINode), Bool) -> (Int, Maybe UINode)
forall a b. (a, b) -> a
fst (CGraph n e
-> [(Int, Maybe UINode)] -> [((Int, Maybe UINode), Bool)]
forall e n.
(EdgeClass e, Show n, NodeClass n) =>
CGraph n e
-> [(Int, Maybe UINode)] -> [((Int, Maybe UINode), Bool)]
lv CGraph n e
g [(Int, Maybe UINode)]
b)
    --    m = median     g nl0 nl1
    l0p :: [(Int, Maybe UINode)]
l0p
      | Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (Int -> Maybe Int
vertNum Int
n0) Bool -> Bool -> Bool
|| Bool
longestP = [(Int, Maybe UINode)]
nl0
      | Bool
otherwise = [(Int, Maybe UINode)]
nl0 -- n0 : (delete n0 nl0)
    l1p :: [(Int, Maybe UINode)]
l1p
      | Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (Int -> Maybe Int
vertNum Int
n1) Bool -> Bool -> Bool
|| Bool
longestP = [(Int, Maybe UINode)]
nl1
      | Bool
otherwise = [(Int, Maybe UINode)]
nl1 -- n1 : (delete n1 nl1)
    getY1 :: ((a, b, c, d), (a, a, c, d)) -> a
getY1 ((a
_, b
_, c
_, d
_), (a
y1, a
chan, c
_, d
_)) = (a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
y1) a -> a -> a
forall a. Num a => a -> a -> a
* a
10 a -> a -> a
forall a. Num a => a -> a -> a
+ a
chan
    crossings :: IntMap UINode -> IntMap UINode -> Int
crossings IntMap UINode
en0 IntMap UINode
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 "") $
      Vector Int -> Int
primitiveInversionCount (((YNode, YNode) -> Int) -> Vector (YNode, YNode) -> Vector Int
forall a b. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
VU.map (YNode, YNode) -> Int
forall {a} {a} {a} {b} {c} {d} {c} {d}.
(Integral a, Num a) =>
((a, b, c, d), (a, a, c, d)) -> a
getY1 (Vector (YNode, YNode) -> Vector Int)
-> Vector (YNode, YNode) -> Vector Int
forall a b. (a -> b) -> a -> b
$ Vector (YNode, YNode) -> Vector (YNode, YNode)
lexicographicSort Vector (YNode, YNode)
ee)
      where
        ee :: Vector (YNode, YNode)
ee = [(YNode, YNode)] -> Vector (YNode, YNode)
forall a. Unbox a => [a] -> Vector a
VU.fromList (IntMap UINode
-> IntMap UINode
-> CGraph n e
-> Dir
-> [UINode]
-> [(YNode, YNode)]
forall n e.
(NodeClass n, EdgeClass e, Show e) =>
IntMap UINode
-> IntMap UINode
-> CGraph n e
-> Dir
-> [UINode]
-> [(YNode, YNode)]
edgesEnum IntMap UINode
en0 IntMap UINode
en1 CGraph n e
g Dir
dir (((Int, Maybe UINode) -> UINode)
-> [(Int, Maybe UINode)] -> [UINode]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Maybe UINode) -> UINode
forall a b1 b2. (Integral a, Num b1) => (a, b2) -> b1
first [(Int, Maybe UINode)]
nl0))
    l0Enum :: IntMap UINode
l0Enum = [(Int, UINode)] -> IntMap UINode
forall a. [(Int, a)] -> IntMap a
IM.fromList ([Int] -> [UINode] -> [(Int, UINode)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Int, Maybe UINode) -> Int) -> [(Int, Maybe UINode)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Maybe UINode) -> Int
forall a b. (a, b) -> a
fst [(Int, Maybe UINode)]
nl0) [UINode
0 ..])
    l1Enum :: IntMap UINode
l1Enum = [(Int, UINode)] -> IntMap UINode
forall a. [(Int, a)] -> IntMap a
IM.fromList ([Int] -> [UINode] -> [(Int, UINode)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Int, Maybe UINode) -> Int) -> [(Int, Maybe UINode)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Maybe UINode) -> Int
forall a b. (a, b) -> a
fst [(Int, Maybe UINode)]
nl1) [UINode
0 ..])
    bEnum :: IntMap UINode
bEnum = [(Int, UINode)] -> IntMap UINode
forall a. [(Int, a)] -> IntMap a
IM.fromList ([Int] -> [UINode] -> [(Int, UINode)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Int, Maybe UINode) -> Int) -> [(Int, Maybe UINode)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Maybe UINode) -> Int
forall a b. (a, b) -> a
fst [(Int, Maybe UINode)]
b) [UINode
0 ..])
    --    mEnum  = IM.fromList (zip m  [0..])

    lu :: Int -> Maybe n
lu Int
n = UINode -> CGraph n e -> Maybe n
forall nl el.
(Show nl, EdgeAttribute el) =>
UINode -> Graph nl el -> Maybe nl
Graph.lookupNode (Int -> UINode
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) CGraph n e
g
    vertNum :: Int -> Maybe Int
vertNum Int
n = Maybe Int -> (n -> Maybe Int) -> Maybe n -> Maybe Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe Int
forall a. Maybe a
Nothing n -> Maybe Int
forall n. NodeClass n => n -> Maybe Int
Common.verticalNumber (Int -> Maybe n
lu Int
n)
crossR CGraph n e
_ Dir
_ [[(Int, Maybe UINode)]]
ls [Int]
ns Bool
_ ParentGraphOf
_ = [[(Int, Maybe UINode)]]
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 :: forall e n.
(EdgeClass e, Show n, NodeClass n) =>
CGraph n e
-> [(Int, Maybe UINode)] -> [((Int, Maybe UINode), Bool)]
lv CGraph n e
_ [] = []
lv CGraph n e
g ((Int, Maybe UINode)
l : [(Int, Maybe UINode)]
ls) =
  -- Debug.Trace.trace ("vertConnected "++ show ((l,ls,ls \\ vertConnected),(goUp ps),l,(goDown cs))) $
  [((Int, Maybe UINode), Bool)]
vertConnected [((Int, Maybe UINode), Bool)]
-> [((Int, Maybe UINode), Bool)] -> [((Int, Maybe UINode), Bool)]
forall a. [a] -> [a] -> [a]
++ (CGraph n e
-> [(Int, Maybe UINode)] -> [((Int, Maybe UINode), Bool)]
forall e n.
(EdgeClass e, Show n, NodeClass n) =>
CGraph n e
-> [(Int, Maybe UINode)] -> [((Int, Maybe UINode), Bool)]
lv CGraph n e
g ([(Int, Maybe UINode)]
ls [(Int, Maybe UINode)]
-> [(Int, Maybe UINode)] -> [(Int, Maybe UINode)]
forall a. Eq a => [a] -> [a] -> [a]
\\ ((((Int, Maybe UINode), Bool) -> (Int, Maybe UINode))
-> [((Int, Maybe UINode), Bool)] -> [(Int, Maybe UINode)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, Maybe UINode), Bool) -> (Int, Maybe UINode)
forall a b. (a, b) -> a
fst [((Int, Maybe UINode), Bool)]
vertConnected)))
  where
    vertConnected :: [((Int, Maybe BoxId), Bool)]
    vertConnected :: [((Int, Maybe UINode), Bool)]
vertConnected
      | [(Int, Maybe UINode)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Maybe UINode)]
up Bool -> Bool -> Bool
&& [(Int, Maybe UINode)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Maybe UINode)]
down = [((Int, Maybe UINode)
l, Bool
False)]
      | Bool
otherwise = ((Int, Maybe UINode) -> ((Int, Maybe UINode), Bool))
-> [(Int, Maybe UINode)] -> [((Int, Maybe UINode), Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Maybe UINode) -> ((Int, Maybe UINode), Bool)
forall {a}. a -> (a, Bool)
tr ([(Int, Maybe UINode)]
up [(Int, Maybe UINode)]
-> [(Int, Maybe UINode)] -> [(Int, Maybe UINode)]
forall a. [a] -> [a] -> [a]
++ [(Int, Maybe UINode)
l] [(Int, Maybe UINode)]
-> [(Int, Maybe UINode)] -> [(Int, Maybe UINode)]
forall a. [a] -> [a] -> [a]
++ [(Int, Maybe UINode)]
down)
    tr :: a -> (a, Bool)
tr a
ll = (a
ll, Bool
True)
    up :: [(Int, Maybe UINode)]
up = [(Int, Maybe UINode)] -> [(Int, Maybe UINode)]
goUp [(Int, Maybe UINode)]
ps
    down :: [(Int, Maybe UINode)]
down = [(Int, Maybe UINode)] -> [(Int, Maybe UINode)]
goDown [(Int, Maybe UINode)]
cs
    ps :: [(Int, Maybe UINode)]
ps = (UINode -> (Int, Maybe UINode))
-> [UINode] -> [(Int, Maybe UINode)]
forall a b. (a -> b) -> [a] -> [b]
map UINode -> (Int, Maybe UINode)
addBid ([UINode] -> [(Int, Maybe UINode)])
-> [UINode] -> [(Int, Maybe UINode)]
forall a b. (a -> b) -> a -> b
$ Vector UINode -> [UINode]
forall a. Unbox a => Vector a -> [a]
VU.toList (Vector UINode -> [UINode]) -> Vector UINode -> [UINode]
forall a b. (a -> b) -> a -> b
$ CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
parentsVertical CGraph n e
g (Int -> UINode
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Int, Maybe UINode) -> Int
forall a b. (a, b) -> a
fst (Int, Maybe UINode)
l))
    goUp :: [(Int, Maybe BoxId)] -> [(Int, Maybe BoxId)]
    goUp :: [(Int, Maybe UINode)] -> [(Int, Maybe UINode)]
goUp [(Int, Maybe UINode)]
n
      | [(Int, Maybe UINode)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Maybe UINode)]
n = []
      | Bool
otherwise = [(Int, Maybe UINode)] -> [(Int, Maybe UINode)]
goUp ((UINode -> (Int, Maybe UINode))
-> [UINode] -> [(Int, Maybe UINode)]
forall a b. (a -> b) -> [a] -> [b]
map UINode -> (Int, Maybe UINode)
addBid ([UINode] -> [(Int, Maybe UINode)])
-> [UINode] -> [(Int, Maybe UINode)]
forall a b. (a -> b) -> a -> b
$ Vector UINode -> [UINode]
forall a. Unbox a => Vector a -> [a]
VU.toList (Vector UINode -> [UINode]) -> Vector UINode -> [UINode]
forall a b. (a -> b) -> a -> b
$ CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
parentsVertical CGraph n e
g (Int -> UINode
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Int, Maybe UINode) -> Int
forall a b. (a, b) -> a
fst ([(Int, Maybe UINode)] -> (Int, Maybe UINode)
forall a. HasCallStack => [a] -> a
head [(Int, Maybe UINode)]
n))))
                     [(Int, Maybe UINode)]
-> [(Int, Maybe UINode)] -> [(Int, Maybe UINode)]
forall a. [a] -> [a] -> [a]
++ [(Int, Maybe UINode) -> (Int, Maybe UINode)
forall a1 a2 b. (Integral a1, Num a2) => (a1, b) -> (a2, b)
fi ([(Int, Maybe UINode)] -> (Int, Maybe UINode)
forall a. HasCallStack => [a] -> a
head [(Int, Maybe UINode)]
n)]

    cs :: [(Int, Maybe UINode)]
cs = (UINode -> (Int, Maybe UINode))
-> [UINode] -> [(Int, Maybe UINode)]
forall a b. (a -> b) -> [a] -> [b]
map UINode -> (Int, Maybe UINode)
addBid ([UINode] -> [(Int, Maybe UINode)])
-> [UINode] -> [(Int, Maybe UINode)]
forall a b. (a -> b) -> a -> b
$ Vector UINode -> [UINode]
forall a. Unbox a => Vector a -> [a]
VU.toList (Vector UINode -> [UINode]) -> Vector UINode -> [UINode]
forall a b. (a -> b) -> a -> b
$ CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
childrenVertical CGraph n e
g (Int -> UINode
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Int, Maybe UINode) -> Int
forall a b. (a, b) -> a
fst (Int, Maybe UINode)
l))
    goDown :: [(Int, Maybe BoxId)] -> [(Int, Maybe BoxId)]
    goDown :: [(Int, Maybe UINode)] -> [(Int, Maybe UINode)]
goDown [(Int, Maybe UINode)]
n
      | [(Int, Maybe UINode)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Maybe UINode)]
n = []
      | Bool
otherwise = ((Int, Maybe UINode) -> (Int, Maybe UINode)
forall a1 a2 b. (Integral a1, Num a2) => (a1, b) -> (a2, b)
fi ([(Int, Maybe UINode)] -> (Int, Maybe UINode)
forall a. HasCallStack => [a] -> a
head [(Int, Maybe UINode)]
n)) (Int, Maybe UINode)
-> [(Int, Maybe UINode)] -> [(Int, Maybe UINode)]
forall a. a -> [a] -> [a]
: ([(Int, Maybe UINode)] -> [(Int, Maybe UINode)]
goDown ((UINode -> (Int, Maybe UINode))
-> [UINode] -> [(Int, Maybe UINode)]
forall a b. (a -> b) -> [a] -> [b]
map UINode -> (Int, Maybe UINode)
addBid ([UINode] -> [(Int, Maybe UINode)])
-> [UINode] -> [(Int, Maybe UINode)]
forall a b. (a -> b) -> a -> b
$ Vector UINode -> [UINode]
forall a. Unbox a => Vector a -> [a]
VU.toList (Vector UINode -> [UINode]) -> Vector UINode -> [UINode]
forall a b. (a -> b) -> a -> b
$ CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
childrenVertical CGraph n e
g (Int -> UINode
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Int, Maybe UINode) -> Int
forall a b. (a, b) -> a
fst ([(Int, Maybe UINode)] -> (Int, Maybe UINode)
forall a. HasCallStack => [a] -> a
head [(Int, Maybe UINode)]
n)))))
    addBid :: UINode -> (Int, Maybe UINode)
addBid UINode
i = CGraph n e -> Int -> (Int, Maybe UINode)
forall {a} {el} {a}.
(Show a, EdgeAttribute el, Integral a, NodeClass a) =>
Graph a el -> a -> (a, Maybe UINode)
addBoxId CGraph n e
g (UINode -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UINode
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 :: forall n e.
(NodeClass n, EdgeClass e, Show e) =>
IntMap UINode
-> IntMap UINode
-> CGraph n e
-> Dir
-> [UINode]
-> [(YNode, YNode)]
edgesEnum IntMap UINode
en0 IntMap UINode
en1 CGraph n e
gr Dir
dir [UINode]
l0 = [Maybe (YNode, YNode)] -> [(YNode, YNode)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (YNode, YNode)]
edges
  where
    edges :: [Maybe (YNode, YNode)]
    edges :: [Maybe (YNode, YNode)]
edges = ((UINode, UINode) -> Maybe (YNode, YNode))
-> [(UINode, UINode)] -> [Maybe (YNode, YNode)]
forall a b. (a -> b) -> [a] -> [b]
map (IntMap UINode
-> IntMap UINode -> (UINode, UINode) -> Maybe (YNode, YNode)
edge IntMap UINode
en0 IntMap UINode
en1) (CGraph n e -> [UINode] -> [(UINode, UINode)]
forall e n.
EdgeClass e =>
CGraph n e -> [UINode] -> [(UINode, UINode)]
edgesOfLayer CGraph n e
gr [UINode]
l0)
    edge :: IM.IntMap UINode -> IM.IntMap UINode -> (UINode, UINode) -> Maybe (YNode, YNode)
    edge :: IntMap UINode
-> IntMap UINode -> (UINode, UINode) -> Maybe (YNode, YNode)
edge IntMap UINode
e0 IntMap UINode
e1 (UINode
src, UINode
tgt)
      | Maybe UINode -> Bool
forall a. Maybe a -> Bool
isNothing Maybe UINode
s Bool -> Bool -> Bool
|| Maybe UINode -> Bool
forall a. Maybe a -> Bool
isNothing Maybe UINode
t = Maybe (YNode, YNode)
forall a. Maybe a
Nothing
      | Bool
otherwise =
        (YNode, YNode) -> Maybe (YNode, YNode)
forall a. a -> Maybe a
Just
          ( (Int -> Maybe UINode -> UINode
forall a. Int -> Maybe a -> a
myFromJust Int
517 Maybe UINode
s, Int
chanNr, UINode
src, CGraph n e -> UINode -> Bool
forall e. EdgeClass e => CGraph n e -> UINode -> Bool
forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e -> UINode -> Bool
isDummy CGraph n e
gr UINode
src),
            (Int -> Maybe UINode -> UINode
forall a. Int -> Maybe a -> a
myFromJust Int
518 Maybe UINode
t, Int
0, UINode
tgt, CGraph n e -> UINode -> Bool
forall e. EdgeClass e => CGraph n e -> UINode -> Bool
forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e -> UINode -> Bool
isDummy CGraph n e
gr UINode
tgt)
          )
      where
        s :: Maybe UINode
s = Int -> IntMap UINode -> Maybe UINode
forall a. Int -> IntMap a -> Maybe a
IM.lookup (UINode -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UINode
src) IntMap UINode
e0
        t :: Maybe UINode
t = Int -> IntMap UINode -> Maybe UINode
forall a. Int -> IntMap a -> Maybe a
IM.lookup (UINode -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UINode
tgt) IntMap UINode
e1
        chanNr :: Int
chanNr
          | Maybe [e] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [e]
lu Bool -> Bool -> Bool
&& [e] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Int -> Maybe [e] -> [e]
forall a. Int -> Maybe a -> a
myFromJust Int
519 Maybe [e]
lu) = Int
0
          | Maybe [e] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [e]
lu = e -> Int
forall e. EdgeClass e => e -> Int
channelNrOut (Int -> [e] -> e
forall a. Int -> [a] -> a
myHead Int
77 (Int -> Maybe [e] -> [e]
forall a. Int -> Maybe a -> a
myFromJust Int
520 Maybe [e]
lu))
          | Bool
otherwise = Int
0
        lu :: Maybe [e]
lu = (UINode, UINode) -> CGraph n e -> Maybe [e]
forall el nl.
(EdgeAttribute el, Show el) =>
(UINode, UINode) -> Graph nl el -> Maybe el
Graph.lookupEdge (UINode
tgt, UINode
src) CGraph n e
gr

    edgesOfLayer :: EdgeClass e => CGraph n e -> [UINode] -> [(UINode, UINode)]
    edgesOfLayer :: forall e n.
EdgeClass e =>
CGraph n e -> [UINode] -> [(UINode, UINode)]
edgesOfLayer CGraph n e
g [UINode]
l = (UINode -> [(UINode, UINode)]) -> [UINode] -> [(UINode, UINode)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (CGraph n e -> UINode -> [(UINode, UINode)]
forall e n.
EdgeClass e =>
CGraph n e -> UINode -> [(UINode, UINode)]
adjEdges CGraph n e
g) [UINode]
l
    adjEdges :: EdgeClass e => CGraph n e -> Word32 -> [(UINode, UINode)]
    adjEdges :: forall e n.
EdgeClass e =>
CGraph n e -> UINode -> [(UINode, UINode)]
adjEdges CGraph n e
g UINode
n
      | Dir -> Bool
leftToRight Dir
dir = (UINode -> (UINode, UINode)) -> [UINode] -> [(UINode, UINode)]
forall a b. (a -> b) -> [a] -> [b]
map (UINode
n,) (Vector UINode -> [UINode]
forall a. Unbox a => Vector a -> [a]
VU.toList (CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
parentsNoVertical CGraph n e
g UINode
n))
      | Bool
otherwise = (UINode -> (UINode, UINode)) -> [UINode] -> [(UINode, UINode)]
forall a b. (a -> b) -> [a] -> [b]
map (UINode
n,) (Vector UINode -> [UINode]
forall a. Unbox a => Vector a -> [a]
VU.toList (CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
childrenNoVertical CGraph n e
g UINode
n))


data BaryNode = BarySingle (Int, Maybe BoxId)
              | BaryGroup [BaryNode]
instance Show BaryNode
  where show :: BaryNode -> [Char]
show (BarySingle (Int
i,Maybe UINode
_)) = [Char]
"s " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i
        show (BaryGroup [BaryNode]
is) = [Char]
"g " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [BaryNode] -> [Char]
forall a. Show a => a -> [Char]
show [BaryNode]
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 :: forall n e.
(NodeClass n, Show n, EdgeClass e, Show e) =>
CGraph n e
-> Dir
-> [(Int, Maybe UINode)]
-> [(Int, Maybe UINode)]
-> ParentGraphOf
-> Int
-> [(Int, Maybe UINode)]
barycenter CGraph n e
g Dir
dir [(Int, Maybe UINode)]
l0 [(Int, Maybe UINode)]
l1 ParentGraphOf
parentGraphOf Int
_ =
    -- Debug.Trace.trace ("bary " ++ show (dir, l1, tree, flatten tree, integrate start)) $
    [BaryNode] -> [(Int, Maybe UINode)]
flatten [BaryNode]
tree
--    map fst (sortOn snd (zip l1 (map (bc . fst) l1))) -- use this, if there subgraph layouting makes problems
  where
    tree :: [BaryNode]
tree = ((BaryNode, Double) -> BaryNode)
-> [(BaryNode, Double)] -> [BaryNode]
forall a b. (a -> b) -> [a] -> [b]
map (BaryNode, Double) -> BaryNode
forall a b. (a, b) -> a
fst (Maybe UINode -> [(BaryNode, Double)]
integrate Maybe UINode
start)
    start :: Maybe UINode
start = Maybe UINode
forall a. Maybe a
Nothing :: Maybe BoxId

    integrate :: Maybe BoxId -> [(BaryNode, Double)]
    integrate :: Maybe UINode -> [(BaryNode, Double)]
integrate Maybe UINode
currentBlock = -- Debug.Trace.trace ("integrate " ++ show (currentBlock, nbs, singleNodes, newBaryNodes)) $
                             ((BaryNode, Double) -> Double)
-> [(BaryNode, Double)] -> [(BaryNode, Double)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (BaryNode, Double) -> Double
forall a b. (a, b) -> b
snd (((Int, Maybe UINode) -> (BaryNode, Double))
-> [(Int, Maybe UINode)] -> [(BaryNode, Double)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Maybe UINode) -> (BaryNode, Double)
bcSingle [(Int, Maybe UINode)]
singleNodes)
                             [(BaryNode, Double)]
-> [(BaryNode, Double)] -> [(BaryNode, Double)]
forall a. [a] -> [a] -> [a]
++ ([(BaryNode, Double)] -> (BaryNode, Double))
-> [[(BaryNode, Double)]] -> [(BaryNode, Double)]
forall a b. (a -> b) -> [a] -> [b]
map ([(BaryNode, Double)] -> (BaryNode, Double)
forall {b}. Fractional b => [(BaryNode, b)] -> (BaryNode, b)
bcGroup ([(BaryNode, Double)] -> (BaryNode, Double))
-> ([(BaryNode, Double)] -> [(BaryNode, Double)])
-> [(BaryNode, Double)]
-> (BaryNode, Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((BaryNode, Double) -> Double)
-> [(BaryNode, Double)] -> [(BaryNode, Double)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (BaryNode, Double) -> Double
forall a b. (a, b) -> b
snd) [[(BaryNode, Double)]]
newBaryNodes
      where singleNodes :: [(Int, Maybe UINode)]
singleNodes = ((Int, Maybe UINode) -> Bool)
-> [(Int, Maybe UINode)] -> [(Int, Maybe UINode)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int, Maybe UINode) -> Bool
upperBlockNode [(Int, Maybe UINode)]
l1
            upperBlockNode :: (Int, Maybe UINode) -> Bool
upperBlockNode (Int
n, Maybe UINode
mbid) = Maybe UINode
mbid Maybe UINode -> Maybe UINode -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe UINode
currentBlock
            bcSingle :: (Int, Maybe UINode) -> (BaryNode, Double)
bcSingle (Int, Maybe UINode)
i = ((Int, Maybe UINode) -> BaryNode
BarySingle (Int, Maybe UINode)
i, Int -> Double
bc ((Int, Maybe UINode) -> Int
forall a b. (a, b) -> a
fst (Int, Maybe UINode)
i)) -- a single node gets a barycenter weight

            nbs :: [Maybe UINode]
nbs = Maybe UINode -> [Maybe UINode]
nextBlocks Maybe UINode
currentBlock
            newBaryNodes :: [[(BaryNode, Double)]]
            newBaryNodes :: [[(BaryNode, Double)]]
newBaryNodes = (Maybe UINode -> [(BaryNode, Double)])
-> [Maybe UINode] -> [[(BaryNode, Double)]]
forall a b. (a -> b) -> [a] -> [b]
map Maybe UINode -> [(BaryNode, Double)]
integrate [Maybe UINode]
nbs
            bcGroup :: [(BaryNode, b)] -> (BaryNode, b)
bcGroup [(BaryNode, b)]
ns = ([BaryNode] -> BaryNode
BaryGroup (((BaryNode, b) -> BaryNode) -> [(BaryNode, b)] -> [BaryNode]
forall a b. (a -> b) -> [a] -> [b]
map (BaryNode, b) -> BaryNode
forall a b. (a, b) -> a
fst [(BaryNode, b)]
ns), [b] -> b
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (((BaryNode, b) -> b) -> [(BaryNode, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (BaryNode, b) -> b
forall a b. (a, b) -> b
snd [(BaryNode, b)]
ns) b -> b -> b
forall a. Fractional a => a -> a -> a
/ Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([(BaryNode, b)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(BaryNode, b)]
ns)) -- a group of nodes from a subgraph gets an average barycenter weight

    nextBlocks :: Maybe BoxId -> [Maybe BoxId]
    nextBlocks :: Maybe UINode -> [Maybe UINode]
nextBlocks Maybe UINode
startBlock = [Maybe UINode]
-> (Set UINode -> [Maybe UINode])
-> Maybe (Set UINode)
-> [Maybe UINode]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((UINode -> Maybe UINode) -> [UINode] -> [Maybe UINode]
forall a b. (a -> b) -> [a] -> [b]
map UINode -> Maybe UINode
forall a. a -> Maybe a
Just ([UINode] -> [Maybe UINode])
-> (Set UINode -> [UINode]) -> Set UINode -> [Maybe UINode]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set UINode -> [UINode]
forall a. Set a -> [a]
Set.toList) (Maybe UINode -> ParentGraphOf -> Maybe (Set UINode)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Maybe UINode
startBlock ParentGraphOf
parentGraphOf)

    flatten :: [BaryNode] -> [(Int, Maybe BoxId)]
    flatten :: [BaryNode] -> [(Int, Maybe UINode)]
flatten [BaryNode]
bs = (BaryNode -> [(Int, Maybe UINode)])
-> [BaryNode] -> [(Int, Maybe UINode)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap BaryNode -> [(Int, Maybe UINode)]
f [BaryNode]
bs
      where f :: BaryNode -> [(Int, Maybe UINode)]
f (BarySingle (Int, Maybe UINode)
i) = [(Int, Maybe UINode)
i]
            f (BaryGroup [BaryNode]
is) = [BaryNode] -> [(Int, Maybe UINode)]
flatten [BaryNode]
is

    bc :: Int -> Double
    bc :: Int -> Double
bc Int
node =
      -- Debug.Trace.trace ("bc" ++ show (dir, node, ps, cs, l0, l1, nodeWeight dir))
        Dir -> Double
nodeWeight Dir
dir
      where
        lenCs :: Double
lenCs = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Vector Int -> Int
forall a. Unbox a => Vector a -> Int
VU.length Vector Int
cs)
        lenPs :: Double
lenPs = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Vector Int -> Int
forall a. Unbox a => Vector a -> Int
VU.length Vector Int
ps)
        startCs :: Vector Int
        startCs :: Vector Int
startCs = (UINode -> Int) -> Vector UINode -> Vector Int
forall a b. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
VU.map UINode -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
childrenNoVertical CGraph n e
g (Int -> UINode
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
node))
        startPs :: Vector Int
        startPs :: Vector Int
startPs = (UINode -> Int) -> Vector UINode -> Vector Int
forall a b. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
VU.map UINode -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
parentsNoVertical CGraph n e
g (Int -> UINode
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
node))
        verts :: [UINode]
verts = CGraph n e -> UINode -> [UINode]
forall e n. EdgeClass e => CGraph n e -> UINode -> [UINode]
verticallyConnectedNodes CGraph n e
g (Int -> UINode
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
node)
        connectedNode :: UINode
        connectedNode :: UINode
connectedNode | Vector Int -> Bool
forall a. Unbox a => Vector a -> Bool
VU.null Vector Int
startCs Bool -> Bool -> Bool
&& Vector Int -> Bool
forall a. Unbox a => Vector a -> Bool
VU.null Vector Int
startPs =
                        UINode -> Maybe UINode -> UINode
forall a. a -> Maybe a -> a
fromMaybe (Int -> UINode
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
node) ((UINode -> Bool) -> [UINode] -> Maybe UINode
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find UINode -> Bool
isConnected [UINode]
verts) -- This is necessary for lambda functions where two nodes 
                      | Bool
otherwise = Int -> UINode
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
node
        isConnected :: UINode -> Bool
        isConnected :: UINode -> Bool
isConnected UINode
n = Bool -> Bool
not (Vector UINode -> Bool
forall a. Unbox a => Vector a -> Bool
VU.null (CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
childrenNoVertical CGraph n e
g UINode
n) Bool -> Bool -> Bool
&& Vector UINode -> Bool
forall a. Unbox a => Vector a -> Bool
VU.null (CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
parentsNoVertical CGraph n e
g UINode
n))

        cs :: Vector Int
cs = (UINode -> Int) -> Vector UINode -> Vector Int
forall a b. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
VU.map UINode -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
childrenNoVertical CGraph n e
g UINode
connectedNode)
        ps :: Vector Int
ps = (UINode -> Int) -> Vector UINode -> Vector Int
forall a b. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
VU.map UINode -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
parentsNoVertical CGraph n e
g UINode
connectedNode)
        size :: Double
        size :: Double
size = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (CGraph n e -> [Int]
forall {a} {el}. Graph a el -> [Int]
Graph.nodes CGraph n e
g))

        nodeWeight :: Dir -> Double
        nodeWeight :: Dir -> Double
nodeWeight Dir
LeftToRight
          | Double
lenCs Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0 = -- Debug.Trace.trace ("b lr " ++ show (node, sumPs + subPos ps + vertFrac, sumPs, subPos ps, vertFrac)) $
                         Double
sumPs Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Vector Int -> Double
subPos Vector Int
ps Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
vertFrac
          | Bool
otherwise = -- Debug.Trace.trace ("b lr other "++ show (node, sumCs + subPos cs + vertFrac, sumCs, subPos cs, vertFrac )) $
                        Double
sumCs Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Vector Int -> Double
subPos Vector Int
cs Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
vertFrac
        nodeWeight Dir
RightToLeft
          | Double
lenPs Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0 = -- Debug.Trace.trace ("b#rl " ++ show (node, sumCs + subPos cs + vertFrac, sumCs, subPos cs, vertFrac))$
                         Double
sumCs Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Vector Int -> Double
subPos Vector Int
cs Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
vertFrac
          | Bool
otherwise = -- Debug.Trace.trace ("b#rl other "++ show (node, sumPs + subPos ps + vertFrac, sumPs, subPos ps, vertFrac)) $
                        Double
sumPs Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Vector Int -> Double
subPos Vector Int
ps Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
vertFrac

        sumCs :: Double
sumCs = Vector Double -> Double
forall a. (Unbox a, Num a) => Vector a -> a
VU.sum ((Int -> Double) -> Vector Int -> Vector Double
forall a b. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
VU.map Int -> Double
xpos Vector Int
cs) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
lenCs
        sumPs :: Double
sumPs = Vector Double -> Double
forall a. (Unbox a, Num a) => Vector a -> a
VU.sum ((Int -> Double) -> Vector Int -> Vector Double
forall a b. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
VU.map Int -> Double
xpos Vector Int
ps) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
lenPs
        lu :: Maybe n
lu = UINode -> CGraph n e -> Maybe n
forall nl el.
(Show nl, EdgeAttribute el) =>
UINode -> Graph nl el -> Maybe nl
Graph.lookupNode UINode
connectedNode CGraph n e
g
        vertFrac :: Double
        vertFrac :: Double
vertFrac = (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> (n -> Maybe Int) -> Maybe n -> Maybe Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe Int
forall a. Maybe a
Nothing n -> Maybe Int
forall n. NodeClass n => n -> Maybe Int
Common.verticalNumber Maybe n
lu))) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
size Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
64)
        xpos :: Int -> Double
        xpos :: Int -> Double
xpos Int
c =
          -- Debug.Trace.trace (show (c, l0,maybe 0 fromIntegral (elemIndex c l0), subPos c)) $
                 (Double -> (Int -> Double) -> Maybe Int -> Double
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Double
0 Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> [Int] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Int
c (((Int, Maybe UINode) -> Int) -> [(Int, Maybe UINode)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Maybe UINode) -> Int
forall a b. (a, b) -> a
fst [(Int, Maybe UINode)]
l0)))

        subPos :: VU.Vector Int -> Double
        subPos :: Vector Int -> Double
subPos Vector Int
cs | Vector Int -> Bool
forall a. Unbox a => Vector a -> Bool
VU.null Vector Int
cs = Double
0
                  | Bool
otherwise = -- Debug.Trace.trace (show channel ++ " : " ++ show channels) $
                                (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
channel) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ ((Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
channels) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2)
          where
            channel :: Int
channel = Int -> (e -> Int) -> Maybe e -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 e -> Int
forall e. EdgeClass e => e -> Int
channelNrOut Maybe e
edgeLabel
            channels :: Int
channels = Int -> (n -> Int) -> Maybe n -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
1 n -> Int
forall {n}. NodeClass n => n -> Int
nrTypes (UINode -> CGraph n e -> Maybe n
forall nl el.
(Show nl, EdgeAttribute el) =>
UINode -> Graph nl el -> Maybe nl
Graph.lookupNode (Int -> UINode
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Vector Int -> Int
forall {a}. Unbox a => Vector a -> a
vHead Vector Int
cs)) CGraph n e
g)
            nrTypes :: n -> Int
nrTypes n
x
              | n -> Bool
forall n. NodeClass n => n -> Bool
isSubLabel n
x = n -> Int
forall {n}. NodeClass n => n -> Int
subLabels n
x
              | Bool
otherwise = Int
1
            edgeLabel :: Maybe e
edgeLabel
              | Maybe [e] -> Bool
forall a. Maybe a -> Bool
isNothing ((UINode, UINode) -> CGraph n e -> Maybe [e]
forall el nl.
(EdgeAttribute el, Show el) =>
(UINode, UINode) -> Graph nl el -> Maybe el
Graph.lookupEdge (UINode, UINode)
dEdge CGraph n e
g) = Maybe e
forall a. Maybe a
Nothing
              | [e] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Int -> Maybe [e] -> [e]
forall a. Int -> Maybe a -> a
myFromJust Int
523 ((UINode, UINode) -> CGraph n e -> Maybe [e]
forall el nl.
(EdgeAttribute el, Show el) =>
(UINode, UINode) -> Graph nl el -> Maybe el
Graph.lookupEdge (UINode, UINode)
dEdge CGraph n e
g)) = Maybe e
forall a. Maybe a
Nothing
              | Bool
otherwise = ([e] -> e) -> Maybe [e] -> Maybe e
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> [e] -> e
forall a. Int -> [a] -> a
myHead Int
80) ((UINode, UINode) -> CGraph n e -> Maybe [e]
forall el nl.
(EdgeAttribute el, Show el) =>
(UINode, UINode) -> Graph nl el -> Maybe el
Graph.lookupEdge (UINode, UINode)
dEdge CGraph n e
g)
            dEdge :: (UINode, UINode)
dEdge = (UINode -> UINode
forall a b. (Integral a, Num b) => a -> b
fromIntegral UINode
connectedNode, Int -> UINode
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Vector Int -> Int
forall {a}. Unbox a => Vector a -> a
vHead Vector Int
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 :: forall e n. EdgeClass e => CGraph n e -> [Int] -> [Int] -> [Int]
median CGraph n e
g [Int]
l0 [Int]
l1 = ((Int, Int) -> Int) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Int
forall a b. (a, b) -> a
fst ([(Int, Int)] -> [Int]) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> Int) -> [(Int, Int)] -> [(Int, Int)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int, Int) -> Int
forall a b. (a, b) -> b
snd ([(Int, Int)] -> [(Int, Int)]) -> [(Int, Int)] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ (Int -> (Int, Int)) -> [Int] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map Int -> (Int, Int)
bc [Int]
l0
  where
    bc :: Int -> (Int, Int)
    bc :: Int -> (Int, Int)
bc Int
node = (Int
node, if Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Int
0 else Vector Int
m Vector Int -> Int -> Int
forall a. Unbox a => Vector a -> Int -> a
VU.! (Int
len Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2))
      where
        len :: Int
len = Vector Int -> Int
forall a. Unbox a => Vector a -> Int
VU.length Vector Int
cs
        cs :: Vector Int
        cs :: Vector Int
cs =
          (UINode -> Int) -> Vector UINode -> Vector Int
forall a b. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
VU.map
            (\UINode
x -> Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Int -> [Int] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex (UINode -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral UINode
x) [Int]
l1))
            (CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
childrenNoVertical CGraph n e
g (Int -> UINode
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
node))
        m :: Vector Int
m = (forall s. MVector s Int -> ST s ()) -> Vector Int -> Vector Int
forall a.
Unbox a =>
(forall s. MVector s a -> ST s ()) -> Vector a -> Vector a
VU.modify MVector s Int -> ST s ()
MVector (PrimState (ST s)) Int -> ST s ()
forall s. MVector s Int -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) e.
(PrimMonad m, MVector v e, Ord e) =>
v (PrimState m) e -> m ()
I.sort Vector Int
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 :: Vector (YNode, YNode) -> Vector (YNode, YNode)
lexicographicSort Vector (YNode, YNode)
es = (forall s. MVector s (YNode, YNode) -> ST s ())
-> Vector (YNode, YNode) -> Vector (YNode, YNode)
forall a.
Unbox a =>
(forall s. MVector s a -> ST s ()) -> Vector a -> Vector a
VU.modify (Comparison (YNode, YNode)
-> MVector (PrimState (ST s)) (YNode, YNode) -> ST s ()
forall (m :: * -> *) (v :: * -> * -> *) e.
(PrimMonad m, MVector v e) =>
Comparison e -> v (PrimState m) e -> m ()
I.sortBy Comparison (YNode, YNode)
forall {a} {a} {a} {a} {c} {d} {c} {d} {c} {d} {c} {d}.
(Ord a, Ord a, Ord a, Ord a) =>
((a, a, c, d), (a, a, c, d))
-> ((a, a, c, d), (a, a, c, d)) -> Ordering
lexicographicOrdering) Vector (YNode, YNode)
es
  where
    lexicographicOrdering :: ((a, a, c, d), (a, a, c, d))
-> ((a, a, c, d), (a, a, c, d)) -> Ordering
lexicographicOrdering
      ((a
e0y0, a
e0n0, c
_, d
_), (a
e0y1, a
e0n1, c
_, d
_))
      ((a
e1y0, a
e1n0, c
_, d
_), (a
e1y1, a
e1n1, c
_, d
_))
        | (a
e0y0 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
e1y0)
            Bool -> Bool -> Bool
|| (a
e0y0 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
e1y0 Bool -> Bool -> Bool
&& a
e0n0 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
e1n0)
            Bool -> Bool -> Bool
|| (a
e0y0 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
e1y0 Bool -> Bool -> Bool
&& a
e0n0 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
e1n0 Bool -> Bool -> Bool
&& a
e0y1 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
e1y1)
            Bool -> Bool -> Bool
|| (a
e0y0 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
e1y0 Bool -> Bool -> Bool
&& a
e0n0 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
e1n0 Bool -> Bool -> Bool
&& a
e0y1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
e1y1 Bool -> Bool -> Bool
&& a
e0n1 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
e1n1) =
          Ordering
GT
        | a
e0y0 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
e1y0 Bool -> Bool -> Bool
&& a
e0n0 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
e1n0 Bool -> Bool -> Bool
&& a
e0y1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
e1y1 Bool -> Bool -> Bool
&& a
e0n1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
e1n1 = Ordering
EQ
        | Bool
otherwise = Ordering
LT

-- | See:  Simple and Efficient Bilayer Cross Counting by Barth, Mutzel, Jünger
primitiveInversionCount :: VU.Vector Int -> Int
primitiveInversionCount :: Vector Int -> Int
primitiveInversionCount Vector Int
xs =
  [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
    [ if (Vector Int
xs Vector Int -> Int -> Int
forall a. Unbox a => Vector a -> Int -> a
VU.! Int
i) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> (Vector Int
xs Vector Int -> Int -> Int
forall a. Unbox a => Vector a -> Int -> a
VU.! Int
j) then Int
1 else Int
0 | Int
i <- [Int
0 .. (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)], Int
j <- [Int
i .. (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)]
    ]
  where l :: Int
l = Vector Int -> Int
forall a. Unbox a => Vector a -> Int
VU.length Vector Int
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 :: ([Int], Int) -> ([Int], Int)
mergeSort ([], Int
_) = ([], Int
0)
mergeSort ([Int
x], Int
_) = ([Int
x], Int
0)
mergeSort ([Int]
xs, Int
_) =
  let ([Int]
as, [Int]
bs) = [Int] -> ([Int], [Int])
forall a. [a] -> ([a], [a])
split [Int]
xs -- num_inv
   in ([Int], Int) -> ([Int], Int) -> ([Int], Int)
merge (([Int], Int) -> ([Int], Int)
mergeSort ([Int]
as, Int
0)) (([Int], Int) -> ([Int], Int)
mergeSort ([Int]
bs, Int
0))
 where
  merge :: ([Int], Int) -> ([Int], Int) -> ([Int], Int)
  merge :: ([Int], Int) -> ([Int], Int) -> ([Int], Int)
merge ([], Int
_) ([Int]
ys, Int
inv) = ([Int]
ys, Int
inv)
  merge ([Int]
xs, Int
inv) ([], Int
_) = ([Int]
xs, Int
inv)
  merge (xs :: [Int]
xs@(Int
x : [Int]
xt), Int
inv0) (ys :: [Int]
ys@(Int
y : [Int]
yt), Int
inv1)
    | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
y = (Int
x Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: (([Int], Int) -> [Int]
forall a b. (a, b) -> a
fst (([Int], Int) -> ([Int], Int) -> ([Int], Int)
merge ([Int]
xt, Int
inv0) ([Int]
ys, Int
inv1))), Int
inv0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
inv1)
    | Bool
otherwise = (Int
y Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: (([Int], Int) -> [Int]
forall a b. (a, b) -> a
fst (([Int], Int) -> ([Int], Int) -> ([Int], Int)
merge ([Int]
xs, Int
inv0) ([Int]
yt, Int
inv1))), Int
inv0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
inv1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
xs)

  split :: [a] -> ([a], [a])
  split :: forall a. [a] -> ([a], [a])
split (a
x : a
y : [a]
zs) = let ([a]
xs, [a]
ys) = [a] -> ([a], [a])
forall a. [a] -> ([a], [a])
split [a]
zs in (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs, a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ys)
  split [a
x] = ([a
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 :: forall e n.
(EdgeClass e, NodeClass n) =>
CGraph n e -> [[UINode]] -> Vector Int
longestinfrequentPaths CGraph n e
_ [] = Vector Int
forall a. Unbox a => Vector a
VU.empty
longestinfrequentPaths CGraph n e
_ [[UINode]
_] = Vector Int
forall a. Unbox a => Vector a
VU.empty
longestinfrequentPaths CGraph n e
g ([UINode]
l0 : [UINode]
l1 : [[UINode]]
layers)
  | [Vector Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Vector Int]
r = Vector Int
forall a. Unbox a => Vector a
VU.empty
  | Bool
otherwise = Int -> Vector Int -> Vector Int
forall a. Unbox a => Int -> Vector a -> Vector a
VU.take ([[UINode]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[UINode]]
layers Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) (Vector Int -> Vector Int) -> Vector Int -> Vector Int
forall a b. (a -> b) -> a -> b
$ Int -> [Vector Int] -> Vector Int
forall a. Int -> [a] -> a
myHead Int
68 [Vector Int]
r
  where
    r :: [Vector Int]
r = (UINode -> Vector Int) -> [UINode] -> [Vector Int]
forall a b. (a -> b) -> [a] -> [b]
map (CGraph n e -> [[UINode]] -> [UINode] -> UINode -> Vector Int
forall e n.
(EdgeClass e, NodeClass n) =>
CGraph n e -> [[UINode]] -> [UINode] -> UINode -> Vector Int
liPaths CGraph n e
g ([UINode]
l1 [UINode] -> [[UINode]] -> [[UINode]]
forall a. a -> [a] -> [a]
: [[UINode]]
layers) []) (CGraph n e -> [UINode] -> [UINode] -> [UINode]
forall e n.
EdgeClass e =>
CGraph n e -> [UINode] -> [UINode] -> [UINode]
startNodes CGraph n e
g [UINode]
l0 [UINode]
l1)

startNodes :: EdgeClass e => CGraph n e -> [Word32] -> [Word32] -> [Word32]
startNodes :: forall e n.
EdgeClass e =>
CGraph n e -> [UINode] -> [UINode] -> [UINode]
startNodes CGraph n e
g [UINode]
l0 [UINode]
l1 = (UINode -> Maybe UINode) -> [UINode] -> [UINode]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([UINode] -> UINode -> Maybe UINode
nodeWithChildInLayer [UINode]
l1) [UINode]
l0
  where
    nodeWithChildInLayer :: [UINode] -> UINode -> Maybe UINode
nodeWithChildInLayer [UINode]
layer1 UINode
node
      | Vector UINode -> Bool
forall a. Unbox a => Vector a -> Bool
VU.null (Vector UINode -> Bool) -> Vector UINode -> Bool
forall a b. (a -> b) -> a -> b
$
          (UINode -> Bool) -> Vector UINode -> Vector UINode
forall a. Unbox a => (a -> Bool) -> Vector a -> Vector a
VU.filter
            (UINode -> [UINode] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UINode]
layer1)
            (CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
childrenNoVertical CGraph n e
g UINode
node) =
        Maybe UINode
forall a. Maybe a
Nothing
      | Bool
otherwise = UINode -> Maybe UINode
forall a. a -> Maybe a
Just UINode
node

liPaths :: EdgeClass e => NodeClass n => CGraph n e -> [[UINode]] -> [UINode] -> UINode -> Vector Int
liPaths :: forall e n.
(EdgeClass e, NodeClass n) =>
CGraph n e -> [[UINode]] -> [UINode] -> UINode -> Vector Int
liPaths CGraph n e
_ [] [UINode]
ns UINode
node = [Int] -> Vector Int
forall a. Unbox a => [a] -> Vector a
VU.fromList ((UINode -> Int) -> [UINode] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map UINode -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (UINode
node UINode -> [UINode] -> [UINode]
forall a. a -> [a] -> [a]
: [UINode]
ns))
liPaths CGraph n e
g ([UINode]
l0 : [[UINode]]
layers) [UINode]
ns UINode
node = (UINode -> Vector Int) -> Vector UINode -> Vector Int
forall a b.
(Unbox a, Unbox b) =>
(a -> Vector b) -> Vector a -> Vector b
VU.concatMap (CGraph n e -> [[UINode]] -> [UINode] -> UINode -> Vector Int
forall e n.
(EdgeClass e, NodeClass n) =>
CGraph n e -> [[UINode]] -> [UINode] -> UINode -> Vector Int
liPaths CGraph n e
g [[UINode]]
layers (UINode
node UINode -> [UINode] -> [UINode]
forall a. a -> [a] -> [a]
: [UINode]
ns)) Vector UINode
cs
  where
    cs :: Vector UINode
cs =
      (UINode -> Bool) -> Vector UINode -> Vector UINode
forall a. Unbox a => (a -> Bool) -> Vector a -> Vector a
VU.filter
        --        (\x -> (maybe False (not . isDummyLabel) (Graph.lookupNode x g)) && elem x l0)
        (\UINode
x -> Bool -> Bool
not (CGraph n e -> UINode -> Bool
forall e. EdgeClass e => CGraph n e -> UINode -> Bool
forall n e.
(NodeClass n, EdgeClass e) =>
CGraph n e -> UINode -> Bool
isDummy CGraph n e
g UINode
x) Bool -> Bool -> Bool
&& UINode -> [UINode] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem UINode
x [UINode]
l0)
        (CGraph n e -> UINode -> Vector UINode
forall e n. EdgeClass e => CGraph n e -> UINode -> Vector UINode
childrenNoVertical CGraph n e
g UINode
node)

------------------------------------------------------------------------------------------------------
-- * Helper functions
--   

fr :: (Int, n) -> (UINode, n)
fr :: forall n. (Int, n) -> (UINode, n)
fr (Int
n, n
nl) = (Int -> UINode
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n, n
nl)

fromAdj :: EdgeClass e => Map Word32 nl -> [(Word32, [Word32], [e])] -> Graph nl [e]
fromAdj :: forall e nl.
EdgeClass e =>
Map UINode nl -> [(UINode, [UINode], [e])] -> Graph nl [e]
fromAdj Map UINode nl
nodesMap [(UINode, [UINode], [e])]
adj = (Graph nl [e] -> (UINode, [UINode], [e]) -> Graph nl [e])
-> Graph nl [e] -> [(UINode, [UINode], [e])] -> Graph nl [e]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Map UINode nl
-> Graph nl [e] -> (UINode, [UINode], [e]) -> Graph nl [e]
forall e nl.
EdgeClass e =>
Map UINode nl
-> Graph nl [e] -> (UINode, [UINode], [e]) -> Graph nl [e]
newNodes Map UINode nl
nodesMap) Graph nl [e]
forall el nl. EdgeAttribute el => Graph nl el
Graph.empty [(UINode, [UINode], [e])]
adj
  where
    newNodes :: -- (Ord n, VU.Unbox n) =>
      EdgeClass e =>
      Map Word32 nl ->
      Graph nl [e] ->
      (Word32, [Word32], [e]) ->
      Graph nl [e]
    newNodes :: forall e nl.
EdgeClass e =>
Map UINode nl
-> Graph nl [e] -> (UINode, [UINode], [e]) -> Graph nl [e]
newNodes Map UINode nl
nm Graph nl [e]
g (UINode
n, [UINode]
ns, [e]
eLabel) =
      Maybe Bool
-> [((UINode, UINode), [e])] -> Graph nl [e] -> Graph nl [e]
forall el nl.
EdgeAttribute el =>
Maybe Bool
-> [((UINode, UINode), el)] -> Graph nl el -> Graph nl el
Graph.insertEdges (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) [((UINode, UINode), [e])]
edges (Graph nl [e] -> Graph nl [e]) -> Graph nl [e] -> Graph nl [e]
forall a b. (a -> b) -> a -> b
$
        (Graph nl [e] -> Graph nl [e])
-> (nl -> Graph nl [e] -> Graph nl [e])
-> Maybe nl
-> Graph nl [e]
-> Graph nl [e]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Graph nl [e] -> Graph nl [e]
forall a. a -> a
id (UINode -> nl -> Graph nl [e] -> Graph nl [e]
forall el nl.
EdgeAttribute el =>
UINode -> nl -> Graph nl el -> Graph nl el
Graph.insertNode (UINode -> UINode
forall a b. (Integral a, Num b) => a -> b
fromIntegral UINode
n)) (UINode -> Map UINode nl -> Maybe nl
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n Map UINode nl
nm) (Graph nl [e] -> Graph nl [e]) -> Graph nl [e] -> Graph nl [e]
forall a b. (a -> b) -> a -> b
$
          [(UINode, nl)] -> Graph nl [e] -> Graph nl [e]
forall el nl.
EdgeAttribute el =>
[(UINode, nl)] -> Graph nl el -> Graph nl el
Graph.insertNodes [(UINode, nl)]
lookedUpNodes Graph nl [e]
g
      where
        lookedUpNodes :: [(UINode, nl)]
lookedUpNodes = (UINode -> Maybe (UINode, nl)) -> [UINode] -> [(UINode, nl)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe UINode -> Maybe (UINode, nl)
addLabel [UINode]
ns
        addLabel :: UINode -> Maybe (UINode, nl)
addLabel UINode
n1 = (nl -> (UINode, nl)) -> Maybe nl -> Maybe (UINode, nl)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UINode
n1,) (UINode -> Map UINode nl -> Maybe nl
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UINode
n Map UINode nl
nm)
        edges :: [((UINode, UINode), [e])]
edges = [(UINode, UINode)] -> [[e]] -> [((UINode, UINode), [e])]
forall a b. [a] -> [b] -> [(a, b)]
zip [(UINode, UINode)]
es [[e]]
edgeLbls
        es :: [(UINode, UINode)]
es = (UINode -> (UINode, UINode)) -> [UINode] -> [(UINode, UINode)]
forall a b. (a -> b) -> [a] -> [b]
map (UINode
n,) [UINode]
ns
        edgeLbls :: [[e]]
edgeLbls = [e] -> [[e]]
forall a. a -> [a]
repeat [e]
eLabel

myTail :: [a] -> [a]
myTail [a]
ls | [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
ls = []
          | Bool
otherwise = [a] -> [a]
forall a. HasCallStack => [a] -> [a]
tail [a]
ls

myNub :: Ord a => [a] -> [a]
myNub :: forall a. Ord a => [a] -> [a]
myNub = ([a] -> a) -> [[a]] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [a] -> a
forall a. Int -> [a] -> a
myHead Int
69) ([[a]] -> [a]) -> ([a] -> [[a]]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [[a]]
forall a. Eq a => [a] -> [[a]]
group ([a] -> [[a]]) -> ([a] -> [a]) -> [a] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. Ord a => [a] -> [a]
sort -- nubOrd

myNub2 :: [(Int, UINode)] -> [(Int, UINode)]
myNub2 :: [(Int, UINode)] -> [(Int, UINode)]
myNub2 = ([(Int, UINode)] -> (Int, UINode))
-> [[(Int, UINode)]] -> [(Int, UINode)]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [(Int, UINode)] -> (Int, UINode)
forall a. Int -> [a] -> a
myHead Int
70) ([[(Int, UINode)]] -> [(Int, UINode)])
-> ([(Int, UINode)] -> [[(Int, UINode)]])
-> [(Int, UINode)]
-> [(Int, UINode)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, UINode) -> (Int, UINode) -> Bool)
-> [(Int, UINode)] -> [[(Int, UINode)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (Int, UINode) -> (Int, UINode) -> Bool
forall {a} {a} {a}. Eq a => (a, a) -> (a, a) -> Bool
nnn ([(Int, UINode)] -> [[(Int, UINode)]])
-> ([(Int, UINode)] -> [(Int, UINode)])
-> [(Int, UINode)]
-> [[(Int, UINode)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, UINode) -> (Int, UINode) -> Ordering)
-> [(Int, UINode)] -> [(Int, UINode)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Int, UINode) -> (Int, UINode) -> Ordering
forall {a} {a} {a}. Ord a => (a, a) -> (a, a) -> Ordering
nn -- nubOrd
  where
    nn :: (a, a) -> (a, a) -> Ordering
nn (a
_, a
n0) (a
_, a
n1) = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
n0 a
n1
    nnn :: (a, a) -> (a, a) -> Bool
nnn (a
_, a
n0) (a
_, a
n1) = a
n0 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
n1

sel1 :: (a, b, c) -> a
sel1 (a
x,b
y,c
z) = a
x
sel2 :: (a, b, c) -> b
sel2 (a
x,b
y,c
z) = b
y
sel3 :: (a, b, c) -> c
sel3 (a
x,b
y,c
z) = c
z

tuples :: [a] -> [(a, a)]
tuples :: forall a. [a] -> [(a, a)]
tuples (a
x : a
y : [a]
xs) = (a
x, a
y) (a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
: [a] -> [(a, a)]
forall a. [a] -> [(a, a)]
tuples (a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs)
tuples [a]
_ = []

vHead :: Vector a -> a
vHead = Vector a -> a
forall {a}. Unbox a => Vector a -> a
VU.head

------------------------------------------------------------------------------------------------------
-- * Debugging
--   

col :: Int -> UINode -> String
col :: Int -> UINode -> [Char]
col Int
i UINode
n = UINode -> [Char]
forall a. Show a => a -> [Char]
show UINode
n [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
c (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
5) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
  where
    c :: Int -> [Char]
c Int
m
      | Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = [Char]
"[color = red" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
width
      | Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = [Char]
"[color = green" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
width
      | Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 = [Char]
"[color = blue" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
width
      | Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3 = [Char]
"[color = yellow" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
width
      | Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4 = [Char]
"[color = turquoise" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
width
    c Int
_ = [Char]
"[color = black" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
width
    width :: [Char]
width = [Char]
",penwidth=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"]"

graphvizNodes :: (CGraph n e, Map.Map Int [Column]) -> String
graphvizNodes :: forall n e. (CGraph n e, Map Int [Column]) -> [Char]
graphvizNodes (CGraph n e
gr, Map Int [Column]
m) = ((Int, n) -> [Char]) -> [(Int, n)] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n") ShowS -> ((Int, n) -> [Char]) -> (Int, n) -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, n) -> [Char]
sh) (IntMap n -> [(Int, n)]
forall a. IntMap a -> [(Int, a)]
I.toList (CGraph n e -> IntMap n
forall nl el. Graph nl el -> IntMap nl
Graph.nodeLabels CGraph n e
gr))
  where
    sh :: (Int, n) -> [Char]
sh (Int
n, n
_nl) = Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" [ pos = \"" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Column] -> [Char]
forall a. Show a => a -> [Char]
show (Int -> Maybe [Column] -> [Column]
forall a. Int -> Maybe a -> a
myFromJust Int
499 (Maybe [Column] -> [Column]) -> Maybe [Column] -> [Column]
forall a b. (a -> b) -> a -> b
$ Int -> Map Int [Column] -> Maybe [Column]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
n Map Int [Column]
m) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"!\"]"

listShow :: Show a => [a] -> String
listShow :: forall a. Show a => [a] -> [Char]
listShow [a]
ls = (a -> [Char]) -> [a] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n")ShowS -> (a -> [Char]) -> a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Char]
forall a. Show a => a -> [Char]
show) [a]
ls